From: Chong Yidong Date: Mon, 28 Sep 2009 15:15:00 +0000 (+0000) Subject: CEDET (development tools) package merged. X-Git-Tag: emacs-pretest-23.1.90~1091 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=b90caf50d04d2c51742054bb6b0e836f6d425203;p=emacs.git CEDET (development tools) package merged. * cedet/*.el: * cedet/ede/*.el: * cedet/semantic/*.el: * cedet/srecode/*.el: New files. --- b90caf50d04d2c51742054bb6b0e836f6d425203 diff --cc lisp/ChangeLog index bea9900d56d,0739e79cf7a..2cbbc7e00f1 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@@ -1,41 -1,36 +1,50 @@@ -2009-09-27 Chong Yidong ++2009-09-28 Eric Ludlam + - * cedet/ede/system.el (ede-upload-html-documentation) - (ede-upload-distribution, ede-edit-web-page) - (ede-web-browse-home): Autoload. ++ CEDET (development tools) package merged. + - * cedet/ede/proj-elisp.el: Add autoload for - semantic-ede-proj-target-grammar. ++ * cedet/*.el: ++ * cedet/ede/*.el: ++ * cedet/semantic/*.el: ++ * cedet/srecode/*.el: New files. + - * cedet/semantic.el (navigate-menu): Show menu items only if - semantic-mode is enabled. +2009-09-28 Michael Albinus - * cedet/ede.el: Remove comments. + * Makefile.in (ELCFILES): Add net/tramp-imap.elc. - * cedet/cedet.el (cedet-menu-map): Minor doc fix. + * net/tramp.el (top): Require tramp-imap. - * cedet/semantic/grammar.el: - * cedet/semantic/grammar-wy.el: - * cedet/semantic/ede-grammar.el: New files. + * net/tramp-smb.el (tramp-smb-handle-directory-files-and-attributes): + Use `tramp-compat-handle-file-attributes'. - * cedet/semantic/db-mode.el (global-semanticdb-minor-mode): Define - using define-minor-mode, so that the usual mode variable exists. +2009-09-28 Teodor Zlatanov -2009-09-27 Chong Yidong + * net/tramp-imap.el: New package. + +2009-09-28 Eric Ludlam + + * emacs-lisp/chart.el: + * emacs-lisp/eieio-base.el: + * emacs-lisp/eieio-comp.el: + * emacs-lisp/eieio-custom.el: + * emacs-lisp/eieio-datadebug.el: + * emacs-lisp/eieio-opt.el: + * emacs-lisp/eieio-speedbar.el: + * emacs-lisp/eieio.el: New files. - * cedet/ede.el (global-ede-mode-map): Move menu to - global-ede-mode-map. - (ede-minor-mode, global-ede-mode): Use define-minor-mode. + * cedet/cedet-cscope.el: + * cedet/cedet-files.el: + * cedet/cedet-global.el: + * cedet/cedet-idutils.el: + * cedet/data-debug.el: + * cedet/inversion.el: + * cedet/mode-local.el: + * cedet/pulse.el: New files. - * cedet/semantic.el (semantic-mode-map): Use cedet-menu-map. +2009-09-27 Vinicius Jose Latorre - * cedet/cedet.el (cedet-menu-map): New var. Don't require - Semantic etc. + * whitespace.el (whitespace-trailing-regexp) + (whitespace-empty-at-bob-regexp, whitespace-empty-at-eob-regexp): + Fix doc string. 2009-09-27 Chong Yidong diff --cc lisp/cedet/ede.el index 00000000000,65da831660e..54c0c933739 mode 000000,100644..100644 --- a/lisp/cedet/ede.el +++ b/lisp/cedet/ede.el @@@ -1,0 -1,1995 +1,1986 @@@ + ;;; ede.el --- Emacs Development Environment gloss + + ;;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + ;;; 2007, 2008, 2009 Free Software Foundation, Inc. + + ;; Author: Eric M. Ludlam + ;; Keywords: project, make + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; + ;; EDE is the top level Lisp interface to a project management scheme + ;; for Emacs. Emacs does many things well, including editing, + ;; building, and debugging. Folks migrating from other IDEs don't + ;; seem to think this qualifies, however, because they still have to + ;; write the makefiles, and specify parameters to programs. + ;; + ;; This EDE mode will attempt to link these diverse programs together + ;; into a comprehensive single interface, instead of a bunch of + ;; different ones. + + ;;; Install + ;; + ;; This command enables project mode on all files. + ;; + ;; (global-ede-mode t) + + (require 'cedet) + (require 'eieio) + (require 'eieio-speedbar) + (require 'ede/source) + (require 'ede/loaddefs) + + (declare-function ede-convert-path "ede/files") + (declare-function ede-directory-get-open-project "ede/files") + (declare-function ede-directory-get-toplevel-open-project "ede/files") + (declare-function ede-directory-project-p "ede/files") + (declare-function ede-find-subproject-for-directory "ede/files") + (declare-function ede-project-directory-remove-hash "ede/files") + (declare-function ede-project-root "ede/files") + (declare-function ede-project-root-directory "ede/files") + (declare-function ede-toplevel "ede/files") + (declare-function ede-toplevel-project "ede/files") + (declare-function ede-up-directory "ede/files") + (declare-function data-debug-new-buffer "data-debug") + (declare-function data-debug-insert-object-slots "eieio-datadebug") + (declare-function semantic-lex-make-spp-table "semantic/lex-spp") + + (defconst ede-version "1.0pre7" + "Current version of the Emacs EDE.") + + ;;; Code: + (defun ede-version () + "Display the current running version of EDE." + (interactive) (message "EDE %s" ede-version)) + + (defgroup ede nil + "Emacs Development Environment gloss." + :group 'tools + :group 'convenience + ) + + (defcustom ede-auto-add-method 'ask + "Whether a new source file shoud be automatically added to a target. + Whenever a new file is encountered in a directory controlled by a + project file, all targets are queried to see if it should be added. + If the value is 'always, then the new file is added to the first + target encountered. If the value is 'multi-ask, then if more than one + target wants the file, the user is asked. If only one target wants + the file, then then it is automatically added to that target. If the + value is 'ask, then the user is always asked, unless there is no + target willing to take the file. 'never means never perform the check." + :group 'ede + :type '(choice (const always) + (const multi-ask) + (const ask) + (const never))) + + (defcustom ede-debug-program-function 'gdb + "Default Emacs command used to debug a target." + :group 'ede + :type 'sexp) ; make this be a list of options some day + + + ;;; Top level classes for projects and targets + + (defclass ede-project-autoload () + ((name :initarg :name + :documentation "Name of this project type") + (file :initarg :file + :documentation "The lisp file belonging to this class.") + (proj-file :initarg :proj-file + :documentation "Name of a project file of this type.") + (proj-root :initarg :proj-root + :type function + :documentation "A function symbol to call for the project root. + This function takes no arguments, and returns the current directories + root, if available. Leave blank to use the EDE directory walking + routine instead.") + (initializers :initarg :initializers + :initform nil + :documentation + "Initializers passed to the project object. + These are used so there can be multiple types of projects + associated with a single object class, based on the initilizeres used.") + (load-type :initarg :load-type + :documentation "Fn symbol used to load this project file.") + (class-sym :initarg :class-sym + :documentation "Symbol representing the project class to use.") + (new-p :initarg :new-p + :initform t + :documentation + "Non-nil if this is an option when a user creates a project.") + ) + "Class representing minimal knowledge set to run preliminary EDE functions. + When more advanced functionality is needed from a project type, that projects + type is required and the load function used.") + + (defvar ede-project-class-files + (list + (ede-project-autoload "edeproject-makefile" + :name "Make" :file 'ede/proj + :proj-file "Project.ede" + :load-type 'ede-proj-load + :class-sym 'ede-proj-project) + (ede-project-autoload "edeproject-automake" + :name "Automake" :file 'ede/proj + :proj-file "Project.ede" + :initializers '(:makefile-type Makefile.am) + :load-type 'ede-proj-load + :class-sym 'ede-proj-project) + (ede-project-autoload "automake" + :name "automake" :file 'ede/project-am + :proj-file "Makefile.am" + :load-type 'project-am-load + :class-sym 'project-am-makefile + :new-p nil) + (ede-project-autoload "cpp-root" + :name "CPP ROOT" :file 'ede/cpp-root + :proj-file 'ede-cpp-root-project-file-for-dir + :proj-root 'ede-cpp-root-project-root + :load-type 'ede-cpp-root-load + :class-sym 'ede-cpp-root + :new-p nil) + (ede-project-autoload "emacs" + :name "EMACS ROOT" :file 'ede/emacs + :proj-file "src/emacs.c" + :proj-root 'ede-emacs-project-root + :load-type 'ede-emacs-load + :class-sym 'ede-emacs-project + :new-p nil) + (ede-project-autoload "linux" + :name "LINUX ROOT" :file 'ede/linux + :proj-file "scripts/ver_linux" + :proj-root 'ede-linux-project-root + :load-type 'ede-linux-load + :class-sym 'ede-linux-project + :new-p nil) + (ede-project-autoload "simple-overlay" + :name "Simple" :file 'ede/simple + :proj-file 'ede-simple-projectfile-for-dir + :load-type 'ede-simple-load + :class-sym 'ede-simple-project)) + "List of vectos defining how to determine what type of projects exist.") + + ;;; Generic project information manager objects + + (defclass ede-target (eieio-speedbar-directory-button) + ((buttonface :initform speedbar-file-face) ;override for superclass + (name :initarg :name + :type string + :custom string + :label "Name" + :group (default name) + :documentation "Name of this target.") + ;; @todo - I think this should be "dir", and not "path". + (path :initarg :path + :type string + ;:custom string + ;:label "Path to target" + ;:group (default name) + :documentation "The path to the sources of this target. + Relative to the path of the project it belongs to.") + (source :initarg :source + :initform nil + ;; I'd prefer a list of strings. + :type list + :custom (repeat (string :tag "File")) + :label "Source Files" + :group (default source) + :documentation "Source files in this target.") + (versionsource :initarg :versionsource + :initform nil + :type list + :custom (repeat (string :tag "File")) + :label "Source Files with Version String" + :group (source) + :documentation + "Source files with a version string in them. + These files are checked for a version string whenever the EDE version + of the master project is changed. When strings are found, the version + previously there is updated.") + ;; Class level slots + ;; + ; (takes-compile-command :allocation :class + ; :initarg :takes-compile-command + ; :type boolean + ; :initform nil + ; :documentation + ; "Non-nil if this target requires a user approved command.") + (sourcetype :allocation :class + :type list ;; list of symbols + :documentation + "A list of `ede-sourcecode' objects this class will handle. + This is used to match target objects with the compilers they can use, and + which files this object is interested in." + :accessor ede-object-sourcecode) + (keybindings :allocation :class + :initform (("D" . ede-debug-target)) + :documentation + "Keybindings specialized to this type of target." + :accessor ede-object-keybindings) + (menu :allocation :class + :initform ( [ "Debug target" ede-debug-target + (and ede-object + (obj-of-class-p ede-object ede-target)) ] + ) + :documentation "Menu specialized to this type of target." + :accessor ede-object-menu) + ) + "A top level target to build.") + + (defclass ede-project-placeholder (eieio-speedbar-directory-button) + ((name :initarg :name + :initform "Untitled" + :type string + :custom string + :label "Name" + :group (default name) + :documentation "The name used when generating distribution files.") + (version :initarg :version + :initform "1.0" + :type string + :custom string + :label "Version" + :group (default name) + :documentation "The version number used when distributing files.") + (directory :type string + :initarg :directory + :documentation "Directory this project is associated with.") + (dirinode :documentation "The inode id for :directory.") + (file :type string + :initarg :file + :documentation "File name where this project is stored.") + (rootproject ; :initarg - no initarg, don't save this slot! + :initform nil + :type (or null ede-project-placeholder-child) + :documentation "Pointer to our root project.") + ) + "Placeholder object for projects not loaded into memory. + Projects placeholders will be stored in a user specific location + and querying them will cause the actual project to get loaded.") + + (defclass ede-project (ede-project-placeholder) + ((subproj :initform nil + :type list + :documentation "Sub projects controlled by this project. + For Automake based projects, each directory is treated as a project.") + (targets :initarg :targets + :type list + :custom (repeat (object :objectcreatefcn ede-new-target-custom)) + :label "Local Targets" + :group (targets) + :documentation "List of top level targets in this project.") + (locate-obj :type (or null ede-locate-base-child) + :documentation + "A locate object to use as a backup to `ede-expand-filename'.") + (tool-cache :initarg :tool-cache + :type list + :custom (repeat object) + :label "Tool: " + :group tools + :documentation "List of tool cache configurations in this project. + This allows any tool to create, manage, and persist project-specific settings.") + (mailinglist :initarg :mailinglist + :initform "" + :type string + :custom string + :label "Mailing List Address" + :group name + :documentation + "An email address where users might send email for help.") + (web-site-url :initarg :web-site-url + :initform "" + :type string + :custom string + :label "Web Site URL" + :group name + :documentation "URL to this projects web site. + This is a URL to be sent to a web site for documentation.") + (web-site-directory :initarg :web-site-directory + :initform "" + :custom string + :label "Web Page Directory" + :group name + :documentation + "A directory where web pages can be found by Emacs. + For remote locations use a path compatible with ange-ftp or EFS. + You can also use TRAMP for use with rcp & scp.") + (web-site-file :initarg :web-site-file + :initform "" + :custom string + :label "Web Page File" + :group name + :documentation + "A file which contains the home page for this project. + This file can be relative to slot `web-site-directory'. + This can be a local file, use ange-ftp, EFS, or TRAMP.") + (ftp-site :initarg :ftp-site + :initform "" + :type string + :custom string + :label "FTP site" + :group name + :documentation + "FTP site where this project's distribution can be found. + This FTP site should be in Emacs form, as needed by `ange-ftp', but can + also be of a form used by TRAMP for use with scp, or rcp.") + (ftp-upload-site :initarg :ftp-upload-site + :initform "" + :type string + :custom string + :label "FTP Upload site" + :group name + :documentation + "FTP Site to upload new distributions to. + This FTP site should be in Emacs form as needed by `ange-ftp'. + If this slot is nil, then use `ftp-site' instead.") + (configurations :initarg :configurations + :initform ("debug" "release") + :type list + :custom (repeat string) + :label "Configuration Options" + :group (settings) + :documentation "List of available configuration types. + Individual target/project types can form associations between a configuration, + and target specific elements such as build variables.") + (configuration-default :initarg :configuration-default + :initform "debug" + :custom string + :label "Current Configuration" + :group (settings) + :documentation "The default configuration.") + (local-variables :initarg :local-variables + :initform nil + :custom (repeat (cons (sexp :tag "Variable") + (sexp :tag "Value"))) + :label "Project Local Variables" + :group (settings) + :documentation "Project local variables") + (keybindings :allocation :class + :initform (("D" . ede-debug-target)) + :documentation "Keybindings specialized to this type of target." + :accessor ede-object-keybindings) + (menu :allocation :class + :initform + ( + [ "Update Version" ede-update-version ede-object ] + [ "Version Control Status" ede-vc-project-directory ede-object ] + [ "Edit Project Homepage" ede-edit-web-page + (and ede-object (oref (ede-toplevel) web-site-file)) ] + [ "Browse Project URL" ede-web-browse-home + (and ede-object + (not (string= "" (oref (ede-toplevel) web-site-url)))) ] + "--" + [ "Rescan Project Files" ede-rescan-toplevel t ] + [ "Edit Projectfile" ede-edit-file-target + (and ede-object + (or (listp ede-object) + (not (obj-of-class-p ede-object ede-project)))) ] + ) + :documentation "Menu specialized to this type of target." + :accessor ede-object-menu) + ) + "Top level EDE project specification. + All specific project types must derive from this project." + :method-invocation-order :depth-first) + + ;;; Management variables + + (defvar ede-projects nil + "A list of all active projects currently loaded in Emacs.") + + (defvar ede-object-root-project nil + "The current buffer's current root project. + If a file is under a project, this specifies the project that is at + the root of a project tree.") + (make-variable-buffer-local 'ede-object-root-project) + + (defvar ede-object-project nil + "The current buffer's current project at that level. + If a file is under a project, this specifies the project that contains the + current target.") + (make-variable-buffer-local 'ede-object-project) + + (defvar ede-object nil + "The current buffer's target object. + This object's class determines how to compile and debug from a buffer.") + (make-variable-buffer-local 'ede-object) + + (defvar ede-selected-object nil + "The currently user-selected project or target. + If `ede-object' is nil, then commands will operate on this object.") + + (defvar ede-constructing nil + "Non nil when constructing a project hierarchy.") + + (defvar ede-deep-rescan nil + "Non nil means scan down a tree, otherwise rescans are top level only. + Do not set this to non-nil globally. It is used internally.") + + ;;; The EDE persistent cache. + ;; + (defcustom ede-project-placeholder-cache-file + (expand-file-name "~/.projects.ede") + "File containing the list of projects EDE has viewed." + :group 'ede + :type 'file) + + (defvar ede-project-cache-files nil + "List of project files EDE has seen before.") + + (defun ede-save-cache () + "Save a cache of EDE objects that Emacs has seen before." + (interactive) + (let ((p ede-projects) + (c ede-project-cache-files) + (recentf-exclude '(ignore)) + ) + (condition-case nil + (progn + (set-buffer (find-file-noselect ede-project-placeholder-cache-file t)) + (erase-buffer) + (insert ";; EDE project cache file. + ;; This contains a list of projects you have visited.\n(") + (while p + (when (and (car p) (ede-project-p p)) + (let ((f (oref (car p) file))) + (when (file-exists-p f) + (insert "\n \"" f "\"")))) + (setq p (cdr p))) + (while c + (insert "\n \"" (car c) "\"") + (setq c (cdr c))) + (insert "\n)\n") + (condition-case nil + (save-buffer 0) + (error + (message "File %s could not be saved." + ede-project-placeholder-cache-file))) + (kill-buffer (current-buffer)) + ) + (error + (message "File %s could not be read." + ede-project-placeholder-cache-file)) + + ))) + + (defun ede-load-cache () + "Load the cache of EDE projects." + (save-excursion + (let ((cachebuffer nil)) + (condition-case nil + (progn + (setq cachebuffer + (find-file-noselect ede-project-placeholder-cache-file t)) + (set-buffer cachebuffer) + (goto-char (point-min)) + (let ((c (read (current-buffer))) + (new nil) + (p ede-projects)) + ;; Remove loaded projects from the cache. + (while p + (setq c (delete (oref (car p) file) c)) + (setq p (cdr p))) + ;; Remove projects that aren't on the filesystem + ;; anymore. + (while c + (when (file-exists-p (car c)) + (setq new (cons (car c) new))) + (setq c (cdr c))) + ;; Save it + (setq ede-project-cache-files (nreverse new)))) + (error nil)) + (when cachebuffer (kill-buffer cachebuffer)) + ))) + + ;;; Important macros for doing commands. + ;; + (defmacro ede-with-projectfile (obj &rest forms) + "For the project in which OBJ resides, execute FORMS." + (list 'save-window-excursion + (list 'let* (list + (list 'pf + (list 'if (list 'obj-of-class-p + obj 'ede-target) + ;; @todo -I think I can change + ;; this to not need ede-load-project-file + ;; but I'm not sure how to test well. + (list 'ede-load-project-file + (list 'oref obj 'path)) + obj)) + '(dbka (get-file-buffer (oref pf file)))) + '(if (not dbka) (find-file (oref pf file)) + (switch-to-buffer dbka)) + (cons 'progn forms) + '(if (not dbka) (kill-buffer (current-buffer)))))) + (put 'ede-with-projectfile 'lisp-indent-function 1) + + + ;;; Prompting + ;; + (defun ede-singular-object (prompt) + "Using PROMPT, choose a single object from the current buffer." + (if (listp ede-object) + (ede-choose-object prompt ede-object) + ede-object)) + + (defun ede-choose-object (prompt list-o-o) + "Using PROMPT, ask the user which OBJECT to use based on the name field. + Argument LIST-O-O is the list of objects to choose from." + (let* ((al (object-assoc-list 'name list-o-o)) + (ans (completing-read prompt al nil t))) + (setq ans (assoc ans al)) + (cdr ans))) + + ;;; Menu and Keymap + + (defvar ede-minor-mode-map + (let ((map (make-sparse-keymap)) + (pmap (make-sparse-keymap))) + (define-key pmap "e" 'ede-edit-file-target) + (define-key pmap "a" 'ede-add-file) + (define-key pmap "d" 'ede-remove-file) + (define-key pmap "t" 'ede-new-target) + (define-key pmap "g" 'ede-rescan-toplevel) + (define-key pmap "s" 'ede-speedbar) + (define-key pmap "l" 'ede-load-project-file) + (define-key pmap "f" 'ede-find-file) + (define-key pmap "C" 'ede-compile-project) + (define-key pmap "c" 'ede-compile-target) + (define-key pmap "\C-c" 'ede-compile-selected) + (define-key pmap "D" 'ede-debug-target) + ;; bind our submap into map + (define-key map "\C-c." pmap) + map) + "Keymap used in project minor mode.") + + (defvar global-ede-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [menu-bar cedet-menu] + (cons "Development" cedet-menu-map)) + map) + "Keymap used in `global-ede-mode'") + + ;; Activate the EDE items in cedet-menu-map + + (define-key cedet-menu-map [ede-find-file] + '(menu-item "Find File in Project..." ede-find-file :enable ede-object)) + (define-key cedet-menu-map [ede-speedbar] + '(menu-item "View Project Tree" ede-speedbar :enable ede-object)) + (define-key cedet-menu-map [ede] + '(menu-item "Load Project" ede)) + (define-key cedet-menu-map [ede-new] + '(menu-item "Create Project" ede-new + :enable (not ede-object))) + (define-key cedet-menu-map [ede-target-options] + '(menu-item "Target Options" ede-target-options + :filter ede-target-forms-menu)) + (define-key cedet-menu-map [ede-project-options] + '(menu-item "Project Options" ede-project-options + :filter ede-project-forms-menu)) + (define-key cedet-menu-map [ede-build-forms-menu] + '(menu-item "Build Project" ede-build-forms-menu + :filter ede-build-forms-menu + :enable ede-object)) + (define-key cedet-menu-map [semantic-menu-separator] 'undefined) + (define-key cedet-menu-map [cedet-menu-separator] 'undefined) + (define-key cedet-menu-map [ede-menu-separator] '("--")) + + (defun ede-menu-obj-of-class-p (class) + "Return non-nil if some member of `ede-object' is a child of CLASS." + (if (listp ede-object) - (ede-or (mapcar (lambda (o) (obj-of-class-p o class)) 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." - (ede-or (ede-map-targets this 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)) + - -;;; Lame stuff -;; -(defun ede-or (arg) - "Do `or' like stuff to ARG because you can't apply `or'." - (while (and arg (not (car arg))) - (setq arg (cdr arg))) - arg) - + + ;;; 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 --cc lisp/cedet/ede/pmake.el index 00000000000,348bc3e302b..420ae77e4b4 mode 000000,100644..100644 --- a/lisp/cedet/ede/pmake.el +++ b/lisp/cedet/ede/pmake.el @@@ -1,0 -1,663 +1,663 @@@ + ;;; ede-pmake.el --- EDE Generic Project Makefile code generator. + + ;;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + ;;; 2007, 2008, 2009 Free Software Foundation, Inc. + + ;; Author: Eric M. Ludlam + ;; Keywords: project, make + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; + ;; Code generator for Makefiles. + ;; + ;; Here is how it should work: + ;; 1) Collect information about the project and targets + ;; 2) Insert header into the Makefile + ;; 3) Insert basic variables (target/source) + ;; 4) Conditional + ;; a) Makefile + ;; 1) Insert support variables (compiler variables, etc) + ;; 2) Insert VERSION and DISTDIR + ;; 3) Specify top build dir if necessary + ;; 4) Specify compile/link commands (c, etc) + ;; 5) Specify dependency files + ;; 6) Specify all: target + ;; 7) Include dependency files + ;; 8) Insert commonized target specify rules + ;; 9) Insert clean: and dist: rules + ;; b) Automake file + ;; 1) Insert distribution source variables for targets + ;; 2) Insert user requested rules + + (require 'ede/proj) + (require 'ede/proj-obj) + (require 'ede/proj-comp) + + (declare-function ede-srecode-setup "ede/srecode") + (declare-function ede-srecode-insert "ede/srecode") + + ;;; Code: + (defmethod ede-proj-makefile-create ((this ede-proj-project) mfilename) + "Create a Makefile for all Makefile targets in THIS. + MFILENAME is the makefile to generate." + (require 'ede/srecode) + (let ((mt nil) + (isdist (string= mfilename (ede-proj-dist-makefile this))) + (depth 0) + (orig-buffer nil) + (buff-to-kill nil) + ) + ;; Find out how deep this project is. + (let ((tmp this)) + (while (setq tmp (ede-parent-project tmp)) + (setq depth (1+ depth)))) + ;; Collect the targets that belong in a makefile. + (mapc + (lambda (obj) + (if (and (obj-of-class-p obj 'ede-proj-target-makefile) + (string= (oref obj makefile) mfilename)) + (setq mt (cons obj mt)))) + (oref this targets)) + ;; Fix the order so things compile in the right direction. + (setq mt (nreverse mt)) + ;; Add in the header part of the Makefile* + (save-excursion + (setq orig-buffer (get-file-buffer mfilename)) + (set-buffer (setq buff-to-kill (find-file-noselect mfilename))) + (goto-char (point-min)) + (if (and + (not (eobp)) + (not (looking-at "# Automatically Generated \\w+ by EDE."))) + (if (not (y-or-n-p (format "Really replace %s? " mfilename))) + (error "Not replacing Makefile")) + (message "Replace EDE Makefile")) + (erase-buffer) + (ede-srecode-setup) + ;; Insert a giant pile of stuff that is common between + ;; one of our Makefiles, and a Makefile.in + (ede-srecode-insert + "file:ede-empty" + "MAKETYPE" + (with-slots (makefile-type) this + (cond ((eq makefile-type 'Makefile) "make") + ((eq makefile-type 'Makefile.in) "autoconf") + ((eq makefile-type 'Makefile.am) "automake") + (t (error ":makefile-type in project invalid"))))) + + ;; Just this project's variables + (ede-proj-makefile-insert-variables this) + + ;; Space + (insert "\n") + + (cond + ((eq (oref this makefile-type) 'Makefile) + ;; Make sure the user has the right kind of make + (ede-make-check-version) + + (let* ((targ (if isdist (oref this targets) mt)) + (sp (oref this subproj)) + (df (apply 'append + (mapcar (lambda (tg) + (ede-proj-makefile-dependency-files tg)) + targ)))) + ;; Distribution variables + (ede-compiler-begin-unique + (mapc 'ede-proj-makefile-insert-variables targ)) + ;; Only add the distribution stuff in when depth != 0 + (let ((top (ede-toplevel this)) + (tmp this) + (subdir "")) + (insert "VERSION=" (oref top version) "\n" + "DISTDIR=$(top)" (oref top name) "-$(VERSION)") + (while (ede-parent-project tmp) + (setq subdir + (concat + "/" + (file-name-nondirectory + (directory-file-name + (file-name-directory (oref tmp file)))) + subdir) + tmp (ede-parent-project tmp))) + (insert subdir "\n")) + ;; Some built in variables for C code + (if df + (let ((tc depth)) + (insert "top_builddir = ") + (while (/= 0 tc) + (setq tc (1- tc)) + (insert "..") + (if (/= tc 0) (insert "/"))) + (insert "\n"))) + (insert "\n") + ;; Create a variable with all the dependency files to include + ;; These methods borrowed from automake. + (if (and (oref this automatic-dependencies) df) + (progn + (insert "DEP_FILES=" + (mapconcat (lambda (f) + (concat ".deps/" + (file-name-nondirectory + (file-name-sans-extension + f)) ".P")) + df " ")))) + ;; + ;; Insert ALL Rule + ;; + (insert "\n\nall:") + (mapc (lambda (c) + (if (and (slot-exists-p c 'partofall) (oref c partofall)) + ;; Only insert this rule if it is a part of ALL. + (insert " " (ede-proj-makefile-target-name c)))) + targ) + (mapc (lambda (c) + (insert " " (ede-name c)) + ) + sp) + (insert "\n\n") + ;; + ;; Add in the include files + ;; + (mapc (lambda (c) + (insert "include " c "\n\n")) + (oref this include-file)) + ;; Some C inference rules + ;; Dependency rules borrowed from automake. + ;; + ;; NOTE: This is GNU Make specific. + (if (and (oref this automatic-dependencies) df) + (insert "DEPS_MAGIC := $(shell mkdir .deps > /dev/null " + "2>&1 || :)\n" + "-include $(DEP_FILES)\n\n")) + ;; + ;; General makefile rules stored in the individual targets + ;; + (ede-compiler-begin-unique + (ede-proj-makefile-insert-rules this) + (mapc 'ede-proj-makefile-insert-rules targ)) + ;; + ;; phony targets for sub projects + ;; + (mapc 'ede-proj-makefile-insert-subproj-rules sp) + ;; + ;; Distribution rules such as CLEAN and DIST + ;; + (when isdist + (ede-proj-makefile-tags this mt) + (ede-proj-makefile-insert-dist-rules this))) + (save-buffer)) + ((eq (oref this makefile-type) 'Makefile.in) + (error "Makefile.in is not supported")) + ((eq (oref this makefile-type) 'Makefile.am) + (require 'ede/pconf) + ;; Distribution variables + (let ((targ (if isdist (oref this targets) mt))) + (ede-compiler-begin-unique + (mapc 'ede-proj-makefile-insert-automake-pre-variables targ)) + (ede-compiler-begin-unique + (mapc 'ede-proj-makefile-insert-source-variables targ)) + (ede-compiler-begin-unique + (mapc 'ede-proj-makefile-insert-automake-post-variables targ)) + (ede-compiler-begin-unique + (ede-proj-makefile-insert-user-rules this)) + (insert "\n# End of Makefile.am\n") + (save-buffer)) + ) + (t (error "Unknown makefile type when generating Makefile"))) + ;; Put the cursor in a nice place + (goto-char (point-min))) + ;; If we have an original buffer, then don't kill it. + (when (not orig-buffer) + (kill-buffer buff-to-kill)) + )) + + ;;; VARIABLE insertion + ;; + (defun ede-pmake-end-of-variable () + "Move to the end of the variable declaration under point." + (end-of-line) + (while (= (preceding-char) ?\\) + (forward-char 1) + (end-of-line)) + ) + + (defmacro ede-pmake-insert-variable-shared (varname &rest body) + "Add VARNAME into the current Makefile. + Execute BODY in a location where a value can be placed." + `(let ((addcr t) (v ,varname)) + (if (re-search-backward (concat "^" v "\\s-*=") nil t) + (progn + (ede-pmake-end-of-variable) + (if (< (current-column) 40) + (if (and (/= (preceding-char) ?=) + (/= (preceding-char) ? )) + (insert " ")) + (insert "\\\n ")) + (setq addcr nil)) + (insert v "=")) + ,@body + (if addcr (insert "\n")) + (goto-char (point-max)))) + (put 'ede-pmake-insert-variable-shared 'lisp-indent-function 1) + + ;;; SOURCE VARIABLE NAME CONSTRUCTION + + (defsubst ede-pmake-varname (obj) + "Convert OBJ into a variable name name. + Change . to _ in the variable name." + (let ((name (oref obj name))) + (while (string-match "\\." name) + (setq name (replace-match "_" nil t name))) + name)) + + (defmethod ede-proj-makefile-sourcevar ((this ede-proj-target)) + "Return the variable name for THIS's sources." + (concat (ede-pmake-varname this) "_YOU_FOUND_A_BUG")) + + ;;; DEPENDENCY FILE GENERATOR LISTS + ;; + (defmethod ede-proj-makefile-dependency-files ((this ede-proj-target)) + "Return a list of source files to convert to dependencies. + Argument THIS is the target to get sources from." + nil) + + ;;; GENERIC VARIABLES + ;; + (defmethod ede-proj-makefile-configuration-variables ((this ede-proj-project) + configuration) + "Return a list of configuration variables from THIS. + Use CONFIGURATION as the current configuration to query." + (cdr (assoc configuration (oref this configuration-variables)))) + + (defmethod ede-proj-makefile-insert-variables-new ((this ede-proj-project)) + "Insert variables needed by target THIS. + + NOTE: Not yet in use! This is part of an SRecode conversion of + EDE that is in progress." + ; (let ((conf-table (ede-proj-makefile-configuration-variables + ; this (oref this configuration-default))) + ; (conf-done nil)) + ; + ; (ede-srecode-insert-with-dictionary + ; "declaration:ede-vars" + ; + ; ;; Insert all variables, and augment them with details from + ; ;; the current configuration. + ; (mapc (lambda (c) + ; + ; (let ((ldict (srecode-dictionary-add-section-dictionary + ; dict "VARIABLE")) + ; ) + ; (srecode-dictionary-set-value ldict "NAME" (car c)) + ; (if (assoc (car c) conf-table) + ; (let ((vdict (srecode-dictionary-add-section-dictionary + ; ldict "VALUE"))) + ; (srecode-dictionary-set-value + ; vdict "VAL" (cdr (assoc (car c) conf-table))) + ; (setq conf-done (cons (car c) conf-done)))) + ; (let ((vdict (srecode-dictionary-add-section-dictionary + ; ldict "VALUE"))) + ; (srecode-dictionary-set-value vdict "VAL" (cdr c)))) + ; ) + ; + ; (oref this variables)) + ; + ; ;; Add in all variables from the configuration not allready covered. + ; (mapc (lambda (c) + ; + ; (if (member (car c) conf-done) + ; nil + ; (let* ((ldict (srecode-dictionary-add-section-dictionary + ; dict "VARIABLE")) + ; (vdict (srecode-dictionary-add-section-dictionary + ; ldict "VALUE")) + ; ) + ; (srecode-dictionary-set-value ldict "NAME" (car c)) + ; (srecode-dictionary-set-value vdict "VAL" (cdr c)))) + ; ) + ; + ; conf-table) + ; + + ;; @TODO - finish off this function, and replace the below fcn + + ; )) + ) + + (defmethod ede-proj-makefile-insert-variables ((this ede-proj-project)) + "Insert variables needed by target THIS." + (let ((conf-table (ede-proj-makefile-configuration-variables + this (oref this configuration-default))) + (conf-done nil)) + ;; Insert all variables, and augment them with details from + ;; the current configuration. + (mapc (lambda (c) + (insert (car c) "=") + (if (assoc (car c) conf-table) + (progn + (insert (cdr (assoc (car c) conf-table)) " ") + (setq conf-done (cons (car c) conf-done)))) + (insert (cdr c) "\n")) + (oref this variables)) + ;; Add in all variables from the configuration not allready covered. + (mapc (lambda (c) + (if (member (car c) conf-done) + nil + (insert (car c) "=" (cdr c) "\n"))) + conf-table)) + (let* ((top "") + (tmp this)) + (while (ede-parent-project tmp) + (setq tmp (ede-parent-project tmp) + top (concat "../" top))) + (insert "\ntop=" top)) + (insert "\nede_FILES=" (file-name-nondirectory (oref this file)) " " + (file-name-nondirectory (ede-proj-dist-makefile this)) "\n")) + + (defmethod ede-proj-makefile-insert-source-variables ((this ede-proj-target) + &optional + moresource) + "Insert the source variables needed by THIS. + Optional argument MORESOURCE is a list of additional sources to add to the + sources variable." + (let ((sv (ede-proj-makefile-sourcevar this))) + ;; This variable may be shared between targets + (ede-pmake-insert-variable-shared (cond ((listp sv) (car sv)) + (t sv)) + (insert (mapconcat (lambda (a) a) (oref this source) " ")) + (if moresource + (insert " \\\n " (mapconcat (lambda (a) a) moresource " ") ""))))) + + (defmethod ede-proj-makefile-insert-variables ((this ede-proj-target) &optional + moresource) + "Insert variables needed by target THIS. + Optional argument MORESOURCE is a list of additional sources to add to the + sources variable." + (ede-proj-makefile-insert-source-variables this moresource) + ) + + (defmethod ede-proj-makefile-configuration-variables ((this ede-proj-target-makefile) + configuration) + "Return a list of configuration variables from THIS. + Use CONFIGURATION as the current configuration to query." + (cdr (assoc configuration (oref this configuration-variables)))) + + (defmethod ede-proj-makefile-insert-variables ((this ede-proj-target-makefile) + &optional moresource) + "Insert variables needed by target THIS. + Optional argument MORESOURCE is a list of additional sources to add to the + sources variable." + (call-next-method) + (let* ((proj (ede-target-parent this)) + (conf-table (ede-proj-makefile-configuration-variables + this (oref proj configuration-default))) + (conf-done nil) + ) + ;; Add in all variables from the configuration not allready covered. + (mapc (lambda (c) + (if (member (car c) conf-done) + nil + (insert (car c) "=" (cdr c) "\n"))) + conf-table)) + (let ((comp (ede-proj-compilers this)) + (link (ede-proj-linkers this)) + (name (ede-proj-makefile-target-name this)) + (src (oref this source))) + (while comp + (ede-compiler-only-once (car comp) + (ede-proj-makefile-insert-object-variables (car comp) name src) + (ede-proj-makefile-insert-variables (car comp))) + (setq comp (cdr comp))) + (while link + (ede-linker-only-once (car link) + (ede-proj-makefile-insert-variables (car link))) + (setq link (cdr link))))) + + (defmethod ede-proj-makefile-insert-automake-pre-variables + ((this ede-proj-target)) + "Insert variables needed by target THIS in Makefile.am before SOURCES." + nil) + + (defmethod ede-proj-makefile-insert-automake-post-variables + ((this ede-proj-target)) + "Insert variables needed by target THIS in Makefile.am after SOURCES." + nil) + + ;;; GARBAGE PATTERNS + ;; + (defmethod ede-proj-makefile-garbage-patterns ((this ede-proj-project)) + "Return a list of patterns that are considered garbage to THIS. + These are removed with make clean." + (let ((mc (ede-map-targets + this (lambda (c) (ede-proj-makefile-garbage-patterns c)))) + (uniq nil)) + (setq mc (sort (apply 'append mc) 'string<)) + ;; Filter out duplicates from the targets. + (while mc + (if (and (car uniq) (string= (car uniq) (car mc))) + nil + (setq uniq (cons (car mc) uniq))) + (setq mc (cdr mc))) + (nreverse uniq))) + + (defmethod ede-proj-makefile-garbage-patterns ((this ede-proj-target)) + "Return a list of patterns that are considered garbage to THIS. + These are removed with make clean." + ;; Get the the source object from THIS, and use the specified garbage. + (let ((src (ede-target-sourcecode this)) + (garb nil)) + (while src + (setq garb (append (oref (car src) garbagepattern) garb) + src (cdr src))) + garb)) + + + ;;; RULES + ;; + (defmethod ede-proj-makefile-insert-subproj-rules ((this ede-proj-project)) + "Insert a rule for the project THIS which should be a subproject." + (insert ".PHONY:" (ede-name this)) + (newline) + (insert (ede-name this) ":") + (newline) + (insert "\t$(MAKE) -C " (directory-file-name (ede-subproject-relative-path this))) + (newline) + (newline) + ) + + (defmethod ede-proj-makefile-insert-rules ((this ede-proj-project)) + "Insert rules needed by THIS target." + (mapc 'ede-proj-makefile-insert-rules (oref this inference-rules)) + ) + + (defmethod ede-proj-makefile-insert-dist-dependencies ((this ede-proj-project)) + "Insert any symbols that the DIST rule should depend on. + Argument THIS is the project that should insert stuff." + (mapc 'ede-proj-makefile-insert-dist-dependencies (oref this targets)) + ) + + (defmethod ede-proj-makefile-insert-dist-dependencies ((this ede-proj-target)) + "Insert any symbols that the DIST rule should depend on. + Argument THIS is the target that should insert stuff." + nil) + + (defmethod ede-proj-makefile-insert-dist-filepatterns ((this ede-proj-target)) + "Insert any symbols that the DIST rule should depend on. + Argument THIS is the target that should insert stuff." + (ede-proj-makefile-insert-dist-dependencies this) + ) + + (defmethod ede-proj-makefile-insert-dist-rules ((this ede-proj-project)) + "Insert distribution rules for THIS in a Makefile, such as CLEAN and DIST." + (let ((junk (ede-proj-makefile-garbage-patterns this)) + tmp) + ;; Build CLEAN, DIST, TAG, and other rules here. + (if junk + (insert "\nclean:\n" + "\trm -f " + (mapconcat (lambda (c) c) junk " ") + "\n\n")) + ;; @TODO: ^^^ Clean should also recurse. ^^^ + + (insert ".PHONY: dist\n") + (insert "\ndist:") + (ede-proj-makefile-insert-dist-dependencies this) + (insert "\n") + (unless (or (ede-subproject-p this) + (oref this metasubproject)) + ;; Only delete if we are the toplevel project. + (insert "\trm -rf $(DISTDIR)\n")) + (insert "\tmkdir $(DISTDIR)\n") ;We may need a -p, but I think not. + (setq tmp (oref this targets)) + (insert "\tcp") + (while tmp + (let ((sv (ede-proj-makefile-sourcevar (car tmp)))) + (if (listp sv) + ;; Handle special case variables. + (cond ((eq (cdr sv) 'share) + ;; This variable may be shared between multiple targets. + (if (re-search-backward (concat "\\$(" (car sv) ")") + (save-excursion + (beginning-of-line) + (point)) + t) + ;; If its already in the dist target, then skip it. + nil + (setq sv (car sv)))) + (t (setq sv (car sv))))) + (if (stringp sv) + (insert " $(" sv ")")) + (ede-proj-makefile-insert-dist-filepatterns (car tmp)) + (setq tmp (cdr tmp)))) + (insert " $(ede_FILES) $(DISTDIR)\n") + + ;; Call our sub projects. + (ede-map-subprojects + this (lambda (sproj) + (let ((rp (directory-file-name (ede-subproject-relative-path sproj)))) + (insert "\t$(MAKE) -C " rp " $(MFLAGS) DISTDIR=$(DISTDIR)/" rp + " dist" + "\n")))) + + ;; Tar up the stuff. + (unless (or (ede-subproject-p this) + (oref this metasubproject)) + (insert "\ttar -cvzf $(DISTDIR).tar.gz $(DISTDIR)\n" + "\trm -rf $(DISTDIR)\n")) + + ;; Make sure the Makefile is ok. + (insert "\n" + (file-name-nondirectory (buffer-file-name)) ": " + (file-name-nondirectory (oref this file)) "\n" + ;; "$(EMACS) -batch Project.ede -l ede -f ede-proj-regenerate" + "\t@echo Makefile is out of date! " + "It needs to be regenerated by EDE.\n" + "\t@echo If you have not modified Project.ede, you can" + " use 'touch' to update the Makefile time stamp.\n" + "\t@false\n\n" + "\n\n# End of Makefile\n"))) + + (defmethod ede-proj-makefile-insert-rules ((this ede-proj-target)) + "Insert rules needed by THIS target." + nil) + + (defmethod ede-proj-makefile-insert-rules ((this ede-proj-target-makefile)) + "Insert rules needed by THIS target." + (mapc 'ede-proj-makefile-insert-rules (oref this rules)) + (let ((c (ede-proj-compilers this))) + (when c + (mapc 'ede-proj-makefile-insert-rules c) + (if (oref this phony) + (insert ".PHONY: " (ede-proj-makefile-target-name this) "\n")) + (insert (ede-proj-makefile-target-name this) ": " + (ede-proj-makefile-dependencies this) "\n") + (ede-proj-makefile-insert-commands this) + ))) + + (defmethod ede-proj-makefile-insert-commands ((this ede-proj-target-makefile)) + "Insert the commands needed by target THIS. + For targets, insert the commands needed by the chosen compiler." + (mapc 'ede-proj-makefile-insert-commands (ede-proj-compilers this)) + (when (object-assoc t :uselinker (ede-proj-compilers this)) + (mapc 'ede-proj-makefile-insert-commands (ede-proj-linkers this)))) + + + (defmethod ede-proj-makefile-insert-user-rules ((this ede-proj-project)) + "Insert user specified rules needed by THIS target. + This is different from `ede-proj-makefile-insert-rules' in that this + function won't create the building rules which are auto created with + automake." + (mapc 'ede-proj-makefile-insert-user-rules (oref this inference-rules))) + + (defmethod ede-proj-makefile-insert-user-rules ((this ede-proj-target)) + "Insert user specified rules needed by THIS target." + (mapc 'ede-proj-makefile-insert-rules (oref this rules))) + + (defmethod ede-proj-makefile-dependencies ((this ede-proj-target-makefile)) + "Return a string representing the dependencies for THIS. + Some compilers only use the first element in the dependencies, others + have a list of intermediates (object files), and others don't care. + This allows customization of how these elements appear." + (let* ((c (ede-proj-compilers this)) - (io (ede-or (mapcar 'ede-compiler-intermediate-objects-p c))) ++ (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 --cc lisp/cedet/ede/proj-comp.el index 00000000000,90b65ea8a8e..4c94b18f8f6 mode 000000,100644..100644 --- a/lisp/cedet/ede/proj-comp.el +++ b/lisp/cedet/ede/proj-comp.el @@@ -1,0 -1,346 +1,346 @@@ -;;; ede-proj-comp.el --- EDE Generic Project compiler/rule driver ++;;; ede/proj-comp.el --- EDE Generic Project compiler/rule driver + + ;;; Copyright (C) 1999, 2000, 2001, 2004, 2005, 2007, 2009 + ;;; Free Software Foundation, Inc. + + ;; Author: Eric M. Ludlam + ;; Keywords: project, make + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; + ;; This software handles the maintenance of compiler and rule definitions + ;; for different object types. + ;; + ;; The `ede-compiler' class lets different types of project objects create + ;; definitions of compilers that can be swapped in and out for compiling + ;; source code. Users can also define new compiler types whenever they + ;; some customized behavior. + ;; + ;; The `ede-makefile-rule' class lets users add customized rules into thier + ;; objects, and also lets different compilers add chaining rules to their + ;; behaviors. + ;; + ;; It is important that all new compiler types be registered once. That + ;; way the chaining rules and variables are inserted into any given Makefile + ;; only once. + ;; + ;; To insert many compiler elements, wrap them in `ede-compiler-begin-unique' + ;; before calling their insert methods. + ;; To write a method that inserts a variable or rule for a compiler + ;; based object, wrap the body of your call in `ede-compiler-only-once' + + (require 'ede) ;source object + (require 'ede/autoconf-edit) + + ;;; Types: + (defclass ede-compilation-program (eieio-instance-inheritor) + ((name :initarg :name + :type string + :custom string + :documentation "Name of this type of compiler.") + (variables :initarg :variables + :type list + :custom (repeat (cons (string :tag "Variable") + (string :tag "Value"))) + :documentation + "Variables needed in the Makefile for this compiler. + An assoc list where each element is (VARNAME . VALUE) where VARNAME + is a string, and VALUE is either a string, or a list of strings. + For example, GCC would define CC=gcc, and emacs would define EMACS=emacs.") + (sourcetype :initarg :sourcetype + :type list ;; of symbols + :documentation + "A list of `ede-sourcecode' objects this class will handle. + This is used to match target objects with the compilers and linkers + they can use, and which files this object is interested in." + :accessor ede-object-sourcecode) + (rules :initarg :rules + :initform nil + :type list + :custom (repeat (object :objecttype ede-makefile-rule)) + :documentation + "Auxiliary rules needed for this compiler to run. + For example, yacc/lex files need additional chain rules, or inferences.") + (commands :initarg :commands + :type list + :custom (repeat string) + :documentation + "The commands used to execute this compiler. + The object which uses this compiler will place these commands after + it's rule definition.") + (autoconf :initarg :autoconf + :initform nil + :type list + :custom (repeat string) + :documentation + "Autoconf function to call if this type of compiler is used. + When a project is in Automake mode, this defines the autoconf function to + call to initialize automake to use this compiler. + For example, there may be multiple C compilers, but they all probably + use the same autoconf form.") + (objectextention :initarg :objectextention + :type string + :documentation + "A string which is the extention used for object files. + For example, C code uses .o on unix, and Emacs Lisp uses .elc.") + ) + "A program used to compile or link a program via a Makefile. + Contains everything needed to output code into a Makefile, or autoconf + file.") + + (defclass ede-compiler (ede-compilation-program) + ((makedepends :initarg :makedepends + :initform nil + :type boolean + :documentation + "Non-nil if this compiler can make dependencies.") + (uselinker :initarg :uselinker + :initform nil + :type boolean + :documentation + "Non-nil if this compiler creates code that can be linked. + This requires that the containing target also define a list of available + linkers that can be used.") + ) + "Definition for a compiler. + Different types of objects will provide different compilers for + different situations.") + + (defclass ede-linker (ede-compilation-program) + () + "Contains information needed to link many generated object files together.") + + (defclass ede-makefile-rule () + ((target :initarg :target + :initform "" + :type string + :custom string + :documentation "The target pattern. + A pattern of \"%.o\" is used for inference rules, and would match object files. + A target of \"foo.o\" explicitly matches the file foo.o.") + (dependencies :initarg :dependencies + :initform "" + :type string + :custom string + :documentation "Dependencies on this target. + A pattern of \"%.o\" would match a file of the same prefix as the target + if that target is also an inference rule pattern. + A dependency of \"foo.c\" explicitly lists foo.c as a dependency. + A variable such as $(name_SOURCES) will list all the source files + belonging to the target name.") + (rules :initarg :rules + :initform nil + :type list + :custom (repeat string) + :documentation "Scripts to execute. + These scripst will be executed in sh (Unless the SHELL variable is overriden). + Do not prefix with TAB. + Each individual element of this list can be either a string, or + a lambda function. (The custom element does not yet express that.") + (phony :initarg :phony + :initform nil + :type boolean + :custom boolean + :documentation "Is this a phony rule? + Adds this rule to a .PHONY list.")) + "A single rule for building some target.") + + ;;; Code: + (defvar ede-compiler-list nil + "The master list of all EDE compilers.") + + (defvar ede-linker-list nil + "The master list of all EDE compilers.") + + (defvar ede-current-build-list nil + "List of EDE compilers that have already inserted parts of themselves. + This is used when creating a Makefile to prevend duplicate variables and + rules from being created.") + + (defmethod initialize-instance :AFTER ((this ede-compiler) &rest fields) + "Make sure that all ede compiler objects are cached in + `ede-compiler-list'." + (add-to-list 'ede-compiler-list this)) + + (defmethod initialize-instance :AFTER ((this ede-linker) &rest fields) + "Make sure that all ede compiler objects are cached in + `ede-linker-list'." + (add-to-list 'ede-linker-list this)) + + (defmacro ede-compiler-begin-unique (&rest body) + "Execute BODY, making sure that `ede-current-build-list' is maintained. + This will prevent rules from creating duplicate variables or rules." + `(let ((ede-current-build-list nil)) + ,@body)) + + (defmacro ede-compiler-only-once (object &rest body) + "Using OBJECT, execute BODY only once per Makefile generation." + `(if (not (member ,object ede-current-build-list)) + (progn + (add-to-list 'ede-current-build-list ,object) + ,@body))) + + (defmacro ede-linker-begin-unique (&rest body) + "Execute BODY, making sure that `ede-current-build-list' is maintained. + This will prevent rules from creating duplicate variables or rules." + `(let ((ede-current-build-list nil)) + ,@body)) + + (defmacro ede-linker-only-once (object &rest body) + "Using OBJECT, execute BODY only once per Makefile generation." + `(if (not (member ,object ede-current-build-list)) + (progn + (add-to-list 'ede-current-build-list ,object) + ,@body))) + + (add-hook 'edebug-setup-hook + (lambda () + (def-edebug-spec ede-compiler-begin-unique def-body) + (def-edebug-spec ede-compiler-only-once (form def-body)) + (def-edebug-spec ede-linker-begin-unique def-body) + (def-edebug-spec ede-linker-only-once (form def-body)) + (def-edebug-spec ede-pmake-insert-variable-shared (form def-body)) + )) + + ;;; Querys + (defun ede-proj-find-compiler (compilers sourcetype) + "Return a compiler from the list COMPILERS that will compile SOURCETYPE." + (while (and compilers + (not (member sourcetype (oref (car compilers) sourcetype)))) + (setq compilers (cdr compilers))) + (car-safe compilers)) + + (defun ede-proj-find-linker (linkers sourcetype) + "Return a compiler from the list LINKERS to be used with SOURCETYPE." + (while (and linkers + (slot-boundp (car linkers) 'sourcetype) + (not (member sourcetype (oref (car linkers) sourcetype)))) + (setq linkers (cdr linkers))) + (car-safe linkers)) + + ;;; Methods: + (defmethod ede-proj-tweak-autoconf ((this ede-compilation-program)) + "Tweak the configure file (current buffer) to accomodate THIS." + (mapcar + (lambda (obj) + (cond ((stringp obj) + (autoconf-insert-new-macro obj)) + ((consp obj) + (autoconf-insert-new-macro (car obj) (cdr obj))) + (t (error "Autoconf directives must be a string, or cons cell"))) + ) + (oref this autoconf))) + + (defmethod ede-proj-flush-autoconf ((this ede-compilation-program)) + "Flush the configure file (current buffer) to accomodate THIS." + nil) + + (defmethod ede-proj-makefile-insert-variables ((this ede-compilation-program)) + "Insert variables needed by the compiler THIS." + (if (eieio-instance-inheritor-slot-boundp this 'variables) + (with-slots (variables) this + (mapcar + (lambda (var) + (insert (car var) "=") + (let ((cd (cdr var))) + (if (listp cd) + (mapc (lambda (c) (insert " " c)) cd) + (insert cd))) + (insert "\n")) + variables)))) + + (defmethod ede-compiler-intermediate-objects-p ((this ede-compiler)) + "Return non-nil if THIS has intermediate object files. + If this compiler creates code that can be linked together, + then the object files created by the compiler are considered intermediate." + (oref this uselinker)) + + (defmethod ede-compiler-intermediate-object-variable ((this ede-compiler) + targetname) + "Return a string based on THIS representing a make object variable. + TARGETNAME is the name of the target that these objects belong to." + (concat targetname "_OBJ")) + + (defmethod ede-proj-makefile-insert-object-variables ((this ede-compiler) + targetname sourcefiles) + "Insert an OBJ variable to specify object code to be generated for THIS. + The name of the target is TARGETNAME as a string. SOURCEFILES is the list of + files to be objectified. + Not all compilers do this." + (if (ede-compiler-intermediate-objects-p this) + (progn + (insert (ede-compiler-intermediate-object-variable this targetname) + "=") + (let ((src (oref this sourcetype))) + (mapc (lambda (s) + (let ((ts src)) + (while (and ts (not (ede-want-file-source-p + (symbol-value (car ts)) s))) + (setq ts (cdr ts))) + ;; Only insert the object if the given file is a major + ;; source-code type. + (if ts;; a match as a source file. + (insert " " (file-name-sans-extension s) + (oref this objectextention))))) + sourcefiles) + (insert "\n"))))) + + (defmethod ede-proj-makefile-insert-rules ((this ede-compilation-program)) + "Insert rules needed for THIS compiler object." + (ede-compiler-only-once this + (mapc 'ede-proj-makefile-insert-rules (oref this rules)))) + + (defmethod ede-proj-makefile-insert-rules ((this ede-makefile-rule)) + "Insert rules needed for THIS rule object." + (if (oref this phony) (insert ".PHONY: (oref this target)\n")) + (insert (oref this target) ": " (oref this dependencies) "\n\t" + (mapconcat (lambda (c) c) (oref this rules) "\n\t") + "\n\n")) + + (defmethod ede-proj-makefile-insert-commands ((this ede-compilation-program)) + "Insert the commands needed to use compiler THIS. + The object creating makefile rules must call this method for the + compiler it decides to use after inserting in the rule." + (when (slot-boundp this 'commands) + (with-slots (commands) this + (mapc + (lambda (obj) (insert "\t" + (cond ((stringp obj) + obj) + ((and (listp obj) + (eq (car obj) 'lambda)) + (funcall obj)) + (t + (format "%S" obj))) + "\n")) + commands)) + (insert "\n"))) + + ;;; Some details about our new macro + ;; + (add-hook 'edebug-setup-hook + (lambda () + (def-edebug-spec ede-compiler-begin-unique def-body))) + (put 'ede-compiler-begin-unique 'lisp-indent-function 0) + (put 'ede-compiler-only-once 'lisp-indent-function 1) + (put 'ede-linker-begin-unique 'lisp-indent-function 0) + (put 'ede-linker-only-once 'lisp-indent-function 1) + + (provide 'ede/proj-comp) + + ;;; ede/proj-comp.el ends here diff --cc lisp/cedet/ede/proj-elisp.el index 00000000000,1838bad00e0..b2ec7124605 mode 000000,100644..100644 --- a/lisp/cedet/ede/proj-elisp.el +++ b/lisp/cedet/ede/proj-elisp.el @@@ -1,0 -1,395 +1,395 @@@ + ;;; ede-proj-elisp.el --- EDE Generic Project Emacs Lisp support + + ;;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + ;;; 2007, 2008, 2009 Free Software Foundation, Inc. + + ;; Author: Eric M. Ludlam + ;; Keywords: project, make + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; -;; Handle Emacs Lisp in and EDE Project file. ++;; 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 --cc lisp/cedet/ede/proj.el index 00000000000,d74050e758f..185af9cf389 mode 000000,100644..100644 --- a/lisp/cedet/ede/proj.el +++ b/lisp/cedet/ede/proj.el @@@ -1,0 -1,675 +1,675 @@@ -;;; ede-proj.el --- EDE Generic Project file driver ++;;; ede/proj.el --- EDE Generic Project file driver + + ;;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2007, 2008, 2009 + ;;; Free Software Foundation, Inc. + + ;; Author: Eric M. Ludlam + ;; Keywords: project, make + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; + ;; EDE defines a method for managing a project. EDE-PROJ aims to be a + ;; generic project file format based on the EIEIO object stream + ;; methods. Changes in the project structure will require Makefile + ;; rebuild. The targets provided in ede-proj can be augmented with + ;; additional target types inherited directly from `ede-proj-target'. + + ;; (eval-and-compile '(require 'ede)) + (require 'ede/proj-comp) + (require 'ede/make) + + (declare-function ede-proj-makefile-create "ede/pmake") + (declare-function ede-proj-configure-synchronize "ede/pconf") + + (autoload 'ede-proj-target-aux "ede/proj-aux" + "Target class for a group of lisp files." nil nil) + (autoload 'ede-proj-target-elisp "ede/proj-elisp" + "Target class for a group of lisp files." nil nil) + (autoload 'ede-proj-target-elisp-autoloads "ede/proj-elisp" + "Target class for generating autoload files." nil nil) + (autoload 'ede-proj-target-scheme "ede/proj-scheme" + "Target class for a group of lisp files." nil nil) + (autoload 'ede-proj-target-makefile-miscelaneous "ede/proj-misc" + "Target class for a group of miscelaneous w/ a special makefile." nil nil) + (autoload 'ede-proj-target-makefile-program "ede/proj-prog" + "Target class for building a program." nil nil) + (autoload 'ede-proj-target-makefile-archive "ede/proj-archive" + "Target class for building an archive of object code." nil nil) + (autoload 'ede-proj-target-makefile-shared-object "ede/proj-shared" + "Target class for building a shared object." nil nil) + (autoload 'ede-proj-target-makefile-info "ede/proj-info" + "Target class for info files." nil nil) + + ;;; Class Definitions: + (defclass ede-proj-target (ede-target) + ((auxsource :initarg :auxsource + :initform nil + :type list + :custom (repeat (string :tag "File")) + :label "Auxiliary Source Files" + :group (default source) + :documentation "Auxilliary source files included in this target. + Each of these is considered equivalent to a source file, but it is not + distributed, and each should have a corresponding rule to build it.") + (dirty :initform nil + :type boolean + :documentation "Non-nil when generated files needs updating.") + (compiler :initarg :compiler + :initform nil + :type (or null symbol) + :custom (choice (const :tag "None" nil) + :slotofchoices availablecompilers) + :label "Compiler for building sources" + :group make + :documentation + "The compiler to be used to compile this object. + This should be a symbol, which contains the object defining the compiler. + This enables save/restore to do so by name, permitting the sharing + of these compiler resources, and global customization thereof.") + (linker :initarg :linker + :initform nil + :type (or null symbol) + :custom (choice (const :tag "None" nil) + :slotofchoices availablelinkers) + :label "Linker for combining intermediate object files." + :group make + :documentation + "The linker to be used to link compiled sources for this object. + This should be a symbol, which contains the object defining the linker. + This enables save/restore to do so by name, permitting the sharing + of these linker resources, and global customization thereof.") + ;; Class allocated slots + (phony :allocation :class + :initform nil + :type boolean + :documentation + "A phony target is one where the build target does not relate to a file. + Such targets are always built, but make knows how to deal with them..") + (availablecompilers :allocation :class + :initform nil + :type (or null list) + :documentation + "A list of `ede-compiler' objects. + These are the compilers the user can choose from when setting the + `compiler' slot.") + (availablelinkers :allocation :class + :initform nil + :type (or null list) + :documentation + "A list of `ede-linker' objects. + These are the linkers the user can choose from when setting the + `linker' slot.") + ) + "Abstract class for ede-proj targets.") + + (defclass ede-proj-target-makefile (ede-proj-target) + ((makefile :initarg :makefile + :initform "Makefile" + :type string + :custom string + :label "Parent Makefile" + :group make + :documentation "File name of generated Makefile.") + (partofall :initarg :partofall + :initform t + :type boolean + :custom boolean + :label "Part of `all:' target" + :group make + :documentation + "Non nil means the rule created is part of the all target. + Setting this to nil creates the rule to build this item, but does not + include it in the ALL`all:' rule.") + (configuration-variables + :initarg :configuration-variables + :initform nil + :type list + :custom (repeat (cons (string :tag "Configuration") + (repeat + (cons (string :tag "Name") + (string :tag "Value"))))) + :label "Environment Variables for configurations" + :group make + :documentation "Makefile variables appended to use in different configurations. + These variables are used in the makefile when a configuration becomes active. + Target variables are always renamed such as foo_CFLAGS, then included into + commands where the variable would usually appear.") + (rules :initarg :rules + :initform nil + :type list + :custom (repeat (object :objecttype ede-makefile-rule)) + :label "Additional Rules" + :group (make) + :documentation + "Arbitrary rules and dependencies needed to make this target. + It is safe to leave this blank.") + ) + "Abstract class for Makefile based targets.") + + (defvar ede-proj-target-alist + '(("program" . ede-proj-target-makefile-program) + ("archive" . ede-proj-target-makefile-archive) + ("sharedobject" . ede-proj-target-makefile-shared-object) + ("emacs lisp" . ede-proj-target-elisp) + ("emacs lisp autoloads" . ede-proj-target-elisp-autoloads) + ("info" . ede-proj-target-makefile-info) + ("auxiliary" . ede-proj-target-aux) + ("scheme" . ede-proj-target-scheme) + ("miscellaneous" . ede-proj-target-makefile-miscelaneous) + ) + "Alist of names to class types for available project target classes.") + + (defun ede-proj-register-target (name class) + "Register a new target class with NAME and class symbol CLASS. + This enables the creation of your target type." + (let ((a (assoc name ede-proj-target-alist))) + (if a + (setcdr a class) + (setq ede-proj-target-alist + (cons (cons name class) ede-proj-target-alist))))) + + (defclass ede-proj-project (ede-project) + ((makefile-type :initarg :makefile-type + :initform Makefile + :type symbol + :custom (choice (const Makefile) + ;(const Makefile.in) + (const Makefile.am) + ;(const cook) + ) + :documentation "The type of Makefile to generate. + Can be one of 'Makefile, 'Makefile.in, or 'Makefile.am. + If this value is NOT 'Makefile, then that overrides the :makefile slot + in targets.") + (variables :initarg :variables + :initform nil + :type list + :custom (repeat (cons (string :tag "Name") + (string :tag "Value"))) + :group (settings) + :documentation "Variables to set in this Makefile.") + (configuration-variables + :initarg :configuration-variables + :initform ("debug" (("DEBUG" . "1"))) + :type list + :custom (repeat (cons (string :tag "Configuration") + (repeat + (cons (string :tag "Name") + (string :tag "Value"))))) + :group (settings) + :documentation "Makefile variables to use in different configurations. + These variables are used in the makefile when a configuration becomes active.") + (inference-rules :initarg :inference-rules + :initform nil + :custom (repeat + (object :objecttype ede-makefile-rule)) + :documentation "Inference rules to add to the makefile.") + (include-file :initarg :include-file + :initform nil + :custom (repeat + (string :tag "Include File")) + :documentation "Additional files to include. + These files can contain additional rules, variables, and customizations.") + (automatic-dependencies + :initarg :automatic-dependencies + :initform t + :type boolean + :custom boolean + :group (default settings) + :documentation + "Non-nil to do implement automatic dependencies in the Makefile.") + (menu :initform + ( + [ "Regenerate Makefiles" ede-proj-regenerate t ] + [ "Upload Distribution" ede-upload-distribution t ] + ) + ) + (metasubproject + :initarg :metasubproject + :initform nil + :type boolean + :custom boolean + :group (default settings) + :documentation + "Non-nil if this is a metasubproject. + Usually, a subproject is determined by a parent project. If multiple top level + projects are grouped into a large project not maintained by EDE, then you need + to set this to non-nil. The only effect is that the `dist' rule will then avoid + making a tar file.") + ) + "The EDE-PROJ project definition class.") + + ;;; Code: + (defun ede-proj-load (project &optional rootproj) + "Load a project file from PROJECT directory. + If optional ROOTPROJ is provided then ROOTPROJ is the root project + for the tree being read in. If ROOTPROJ is nil, then assume that + the PROJECT being read in is the root project." + (save-excursion + (let ((ret nil) + (subdirs (directory-files project nil "[^.].*" nil))) + (set-buffer (get-buffer-create " *tmp proj read*")) + (unwind-protect + (progn + (insert-file-contents (concat project "Project.ede") + nil nil nil t) + (goto-char (point-min)) + (setq ret (read (current-buffer))) + (if (not (eq (car ret) 'ede-proj-project)) + (error "Corrupt project file")) + (setq ret (eval ret)) + (oset ret file (concat project "Project.ede")) + (oset ret directory project) + (oset ret rootproject rootproj) + ) + (kill-buffer " *tmp proj read*")) + (while subdirs + (let ((sd (file-name-as-directory + (expand-file-name (car subdirs) project)))) + (if (and (file-directory-p sd) + (ede-directory-project-p sd)) + (oset ret subproj + (cons (ede-proj-load sd (or rootproj ret)) + (oref ret subproj)))) + (setq subdirs (cdr subdirs)))) + ret))) + + (defun ede-proj-save (&optional project) + "Write out object PROJECT into its file." + (save-excursion + (if (not project) (setq project (ede-current-project))) + (let ((b (set-buffer (get-buffer-create " *tmp proj write*"))) + (cfn (oref project file)) + (cdir (oref project directory))) + (unwind-protect + (save-excursion + (erase-buffer) + (let ((standard-output (current-buffer))) + (oset project file (file-name-nondirectory cfn)) + (slot-makeunbound project :directory) + (object-write project ";; EDE project file.")) + (write-file cfn nil) + ) + ;; Restore the :file on exit. + (oset project file cfn) + (oset project directory cdir) + (kill-buffer b))))) + + (defmethod ede-commit-local-variables ((proj ede-proj-project)) + "Commit change to local variables in PROJ." + (ede-proj-save proj)) + + (defmethod eieio-done-customizing ((proj ede-proj-project)) + "Call this when a user finishes customizing this object. + Argument PROJ is the project to save." + (call-next-method) + (ede-proj-save proj)) + + (defmethod eieio-done-customizing ((target ede-proj-target)) + "Call this when a user finishes customizing this object. + Argument TARGET is the project we are completing customization on." + (call-next-method) + (ede-proj-save (ede-current-project))) + + (defmethod ede-commit-project ((proj ede-proj-project)) + "Commit any change to PROJ to its file." + (ede-proj-save proj)) + + (defmethod ede-buffer-mine ((this ede-proj-project) buffer) + "Return t if object THIS lays claim to the file in BUFFER." + (let ((f (ede-convert-path this (buffer-file-name buffer)))) + (or (string= (file-name-nondirectory (oref this file)) f) + (string= (ede-proj-dist-makefile this) f) + (string-match "Makefile\\(\\.\\(in\\|am\\)\\)?$" f) + (string-match "config\\(ure\\.in\\|\\.stutus\\)?$" f) + ))) + + (defmethod ede-buffer-mine ((this ede-proj-target) buffer) + "Return t if object THIS lays claim to the file in BUFFER." + (or (call-next-method) + (ede-target-buffer-in-sourcelist this buffer (oref this auxsource)))) + + + ;;; EDE command functions + ;; + (defvar ede-proj-target-history nil + "History when querying for a target type.") + + (defmethod project-new-target ((this ede-proj-project) + &optional name type autoadd) + "Create a new target in THIS based on the current buffer." + (let* ((name (or name (read-string "Name: " ""))) + (type (or type + (completing-read "Type: " ede-proj-target-alist + nil t nil '(ede-proj-target-history . 1)))) + (ot nil) + (src (if (and (buffer-file-name) + (if (and autoadd (stringp autoadd)) + (string= autoadd "y") + (y-or-n-p (format "Add %s to %s? " (buffer-name) name)))) + (buffer-file-name))) + (fcn (cdr (assoc type ede-proj-target-alist))) + ) + + (when (not fcn) + (error "Unknown target type %s for EDE Project." type)) + + (setq ot (funcall fcn name :name name + :path (ede-convert-path this default-directory) + :source (if src + (list (file-name-nondirectory src)) + nil))) + ;; If we added it, set the local buffer's object. + (if src (progn + (setq ede-object ot) + (ede-apply-object-keymap))) + ;; Add it to the project object + ;;(oset this targets (cons ot (oref this targets))) + ;; New form: Add to the end using fancy eieio function. + ;; @todone - Some targets probably want to be in the front. + ;; How to do that? + ;; @ans - See elisp autoloads for answer + (object-add-to-list this 'targets ot t) + ;; And save + (ede-proj-save this))) + + (defmethod project-new-target-custom ((this ede-proj-project)) + "Create a new target in THIS for custom." + (let* ((name (read-string "Name: " "")) + (type (completing-read "Type: " ede-proj-target-alist + nil t nil '(ede-proj-target-history . 1)))) + (funcall (cdr (assoc type ede-proj-target-alist)) name :name name + :path (ede-convert-path this default-directory) + :source nil))) + + (defmethod project-delete-target ((this ede-proj-target)) + "Delete the current target THIS from it's parent project." + (let ((p (ede-current-project)) + (ts (oref this source))) + ;; Loop across all sources. If it exists in a buffer, + ;; clear it's object. + (while ts + (let* ((default-directory (oref this path)) + (b (get-file-buffer (car ts)))) + (if b + (save-excursion + (set-buffer b) + (if (eq ede-object this) + (progn + (setq ede-object nil) + (ede-apply-object-keymap)))))) + (setq ts (cdr ts))) + ;; Remove THIS from it's parent. + ;; The two vectors should be pointer equivalent. + (oset p targets (delq this (oref p targets))) + (ede-proj-save (ede-current-project)))) + + (defmethod project-add-file ((this ede-proj-target) file) + "Add to target THIS the current buffer represented as FILE." + (let ((file (ede-convert-path this file)) + (src (ede-target-sourcecode this))) + (while (and src (not (ede-want-file-p (car src) file))) + (setq src (cdr src))) + (when src + (setq src (car src)) + (cond ((ede-want-file-source-p this file) + (object-add-to-list this 'source file t)) + ((ede-want-file-auxiliary-p this file) + (object-add-to-list this 'auxsource file t)) + (t (error "`project-add-file(ede-target)' source mismatch error"))) + (ede-proj-save)))) + + (defmethod project-remove-file ((target ede-proj-target) file) + "For TARGET, remove FILE. + FILE must be massaged by `ede-convert-path'." + ;; Speedy delete should be safe. + (object-remove-from-list target 'source (ede-convert-path target file)) + (object-remove-from-list target 'auxsource (ede-convert-path target file)) + (ede-proj-save)) + + (defmethod project-update-version ((this ede-proj-project)) + "The :version of project THIS has changed." + (ede-proj-save)) + + (defmethod project-make-dist ((this ede-proj-project)) + "Build a distribution for the project based on THIS target." + ;; I'm a lazy bum, so I'll make a makefile for doing this sort + ;; of thing, and rely only on that small section of code. + (let ((pm (ede-proj-dist-makefile this)) + (df (project-dist-files this))) + (if (and (file-exists-p (car df)) + (not (y-or-n-p "Dist file already exists. Rebuild? "))) + (error "Try `ede-update-version' before making a distribution")) + (ede-proj-setup-buildenvironment this) + (if (string= pm "Makefile.am") (setq pm "Makefile")) + (compile (concat ede-make-command " -f " pm " dist")) + )) + + (defmethod project-dist-files ((this ede-proj-project)) + "Return a list of files that constitutes a distribution of THIS project." + (list + ;; Note to self, keep this first for the above fn to check against. + (concat (oref this name) "-" (oref this version) ".tar.gz") + )) + + (defmethod project-compile-project ((proj ede-proj-project) &optional command) + "Compile the entire current project PROJ. + Argument COMMAND is the command to use when compiling." + (let ((pm (ede-proj-dist-makefile proj)) + (default-directory (file-name-directory (oref proj file)))) + (ede-proj-setup-buildenvironment proj) + (if (string= pm "Makefile.am") (setq pm "Makefile")) + (compile (concat ede-make-command" -f " pm " all")))) + + ;;; Target type specific compilations/debug + ;; + (defmethod project-compile-target ((obj ede-proj-target) &optional command) + "Compile the current target OBJ. + Argument COMMAND is the command to use for compiling the target." + (project-compile-project (ede-current-project) command)) + + (defmethod project-compile-target ((obj ede-proj-target-makefile) + &optional command) + "Compile the current target program OBJ. + Optional argument COMMAND is the s the alternate command to use." + (ede-proj-setup-buildenvironment (ede-current-project)) + (compile (concat ede-make-command " -f " (oref obj makefile) " " + (ede-proj-makefile-target-name obj)))) + + (defmethod project-debug-target ((obj ede-proj-target)) + "Run the current project target OBJ in a debugger." + (error "Debug-target not supported by %s" (object-name obj))) + + (defmethod ede-proj-makefile-target-name ((this ede-proj-target)) + "Return the name of the main target for THIS target." + (ede-name this)) + + ;;; Compiler and source code generators + ;; + (defmethod ede-want-file-auxiliary-p ((this ede-target) file) + "Return non-nil if THIS target wants FILE." + ;; By default, all targets reference the source object, and let it decide. + (let ((src (ede-target-sourcecode this))) + (while (and src (not (ede-want-file-auxiliary-p (car src) file))) + (setq src (cdr src))) + src)) + + (defmethod ede-proj-compilers ((obj ede-proj-target)) + "List of compilers being used by OBJ. + If the `compiler' slot is empty, concoct one on a first match found + basis for any given type from the `availablecompilers' slot. + Otherwise, return the `compiler' slot. + Converts all symbols into the objects to be used." + (when (slot-exists-p obj 'compiler) + (let ((comp (oref obj compiler))) + (if comp + ;; Now that we have a pre-set compilers to use, convert tye symbols + ;; into objects for ease of use + (if (listp comp) + (setq comp (mapcar 'symbol-value comp)) + (setq comp (list (symbol-value comp)))) + (let* ((acomp (oref obj availablecompilers)) + (avail (mapcar 'symbol-value acomp)) + (st (oref obj sourcetype)) + (sources (oref obj source))) + ;; COMP is not specified, so generate a list from the available + ;; compilers list. + (while st + (if (ede-want-any-source-files-p (symbol-value (car st)) sources) + (let ((c (ede-proj-find-compiler avail (car st)))) + (if c (setq comp (cons c comp))))) + (setq st (cdr st))))) + ;; Return the disovered compilers + comp))) + + (defmethod ede-proj-linkers ((obj ede-proj-target)) + "List of linkers being used by OBJ. + If the `linker' slot is empty, concoct one on a first match found + basis for any given type from the `availablelinkers' slot. + Otherwise, return the `linker' slot. + Converts all symbols into the objects to be used." + (when (slot-exists-p obj 'linker) + (let ((link (oref obj linker))) + (if link + ;; Now that we have a pre-set linkers to use, convert type symbols + ;; into objects for ease of use + (if (symbolp link) + (setq link (list (symbol-value link))) + (error ":linker is not a symbol. Howd you do that?")) + (let* ((alink (oref obj availablelinkers)) + (avail (mapcar 'symbol-value alink)) + (st (oref obj sourcetype)) + (sources (oref obj source))) + ;; LINKER is not specified, so generate a list from the available + ;; compilers list. + (while st + (if (ede-want-any-source-files-p (symbol-value (car st)) sources) + (let ((c (ede-proj-find-linker avail (car st)))) + (if c (setq link (cons c link))))) + (setq st (cdr st))) + (unless link + ;; No linker stands out! Loop over our linkers and pull out + ;; the first that has no source type requirement. + (while (and avail (not (eieio-instance-inheritor-slot-boundp (car avail) 'sourcetype))) + (setq avail (cdr avail))) + (setq link (cdr avail))))) + ;; Return the disovered linkers + link))) + + + ;;; Target type specific autogenerating gobbldegook. + ;; + + (defun ede-proj-makefile-type (&optional proj) + "Makefile type of the current project PROJ." + (oref (or proj (ede-current-project)) makefile-type)) + + (defun ede-proj-automake-p (&optional proj) + "Return non-nil if the current project PROJ is automake mode." + (eq (ede-proj-makefile-type proj) 'Makefile.am)) + + (defun ede-proj-autoconf-p (&optional proj) + "Return non-nil if the current project PROJ is automake mode." + (eq (ede-proj-makefile-type proj) 'Makefile.in)) + + (defun ede-proj-make-p (&optional proj) + "Return non-nil if the current project PROJ is automake mode." + (eq (ede-proj-makefile-type proj) 'Makefile)) + + (defmethod ede-proj-dist-makefile ((this ede-proj-project)) + "Return the name of the Makefile with the DIST target in it for THIS." + (cond ((eq (oref this makefile-type) 'Makefile.am) + (concat (file-name-directory (oref this file)) + "Makefile.am")) + ((eq (oref this makefile-type) 'Makefile.in) + (concat (file-name-directory (oref this file)) + "Makefile.in")) + ((object-assoc "Makefile" 'makefile (oref this targets)) + (concat (file-name-directory (oref this file)) + "Makefile")) + (t + (let ((targets (oref this targets))) + (while (and targets + (not (obj-of-class-p + (car targets) + 'ede-proj-target-makefile))) + (setq targets (cdr targets))) + (if targets (oref (car targets) makefile) + (concat (file-name-directory (oref this file)) + "Makefile")))))) + + (defun ede-proj-regenerate () + "Regenerate Makefiles for and edeproject project." + (interactive) + (ede-proj-setup-buildenvironment (ede-current-project) t)) + + (defmethod ede-proj-makefile-create-maybe ((this ede-proj-project) mfilename) + "Create a Makefile for all Makefile targets in THIS if needed. + MFILENAME is the makefile to generate." + ;; For now, pass through until dirty is implemented. + (require 'ede/pmake) + (if (or (not (file-exists-p mfilename)) + (file-newer-than-file-p (oref this file) mfilename)) + (ede-proj-makefile-create this mfilename))) + + (defmethod ede-proj-setup-buildenvironment ((this ede-proj-project) + &optional force) + "Setup the build environment for project THIS. + Handles the Makefile, or a Makefile.am configure.in combination. + Optional argument FORCE will force items to be regenerated." + (if (not force) + (ede-proj-makefile-create-maybe this (ede-proj-dist-makefile this)) + (require 'ede/pmake) + (ede-proj-makefile-create this (ede-proj-dist-makefile this))) + ;; Rebuild all subprojects + (ede-map-subprojects + this (lambda (sproj) (ede-proj-setup-buildenvironment sproj force))) + ;; Autoconf projects need to do other kinds of initializations. + (when (and (ede-proj-automake-p this) + (eq this (ede-toplevel this))) + (require 'ede/pconf) + ;; If the user wants to force this, do it some other way? + (ede-proj-configure-synchronize this) + ;; Now run automake to fill in the blanks, autoconf, and other + ;; auto thingies so that we can just say "make" when done. + ) + ) + + + ;;; Lower level overloads + ;; + (defmethod project-rescan ((this ede-proj-project)) + "Rescan the EDE proj project THIS." + (let ((root (or (ede-project-root this) this)) + ) + (setq ede-projects (delq root ede-projects)) + (ede-proj-load (ede-project-root-directory root)) + )) + + (defmethod project-rescan ((this ede-proj-target) readstream) + "Rescan target THIS from the read list READSTREAM." + (setq readstream (cdr (cdr readstream))) ;; constructor/name + (while readstream + (let ((tag (car readstream)) + (val (car (cdr readstream)))) + (eieio-oset this tag val)) + (setq readstream (cdr (cdr readstream))))) + + (provide 'ede/proj) + + ;;; ede/proj.el ends here diff --cc lisp/cedet/semantic.el index 00000000000,dfed8a8c194..5e78513b0ad mode 000000,100644..100644 --- a/lisp/cedet/semantic.el +++ b/lisp/cedet/semantic.el @@@ -1,0 -1,1116 +1,1115 @@@ + ;;; semantic.el --- Semantic buffer evaluator. + + ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, + ;;; 2007, 2008, 2009 Free Software Foundation, Inc. + + ;; Author: Eric M. Ludlam + ;; Keywords: syntax + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; + ;; API for providing the semantic content of a buffer. + ;; + ;; The semantic API provides an interface to a series of different parser + ;; implementations. Each parser outputs a parse tree in a similar format + ;; designed to handle typical functional and object oriented languages. + -(require 'assoc) + (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 --cc lisp/cedet/semantic/analyze.el index 00000000000,55f8db4aaad..4948bba794e mode 000000,100644..100644 --- a/lisp/cedet/semantic/analyze.el +++ b/lisp/cedet/semantic/analyze.el @@@ -1,0 -1,797 +1,798 @@@ + ;;; semantic/analyze.el --- Analyze semantic tags against local context + + ;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009 + ;;; Free Software Foundation, Inc. + + ;; Author: Eric M. Ludlam + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; + ;; Semantic, as a tool, provides a nice list of searchable tags. + ;; That information can provide some very accurate answers if the current + ;; context of a position is known. + ;; + ;; Semantic-ctxt provides ways of analyzing, and manipulating the + ;; semantic context of a language in code. + ;; + ;; This library provides routines for finding intelligent answers to + ;; tough problems, such as if an argument to a function has the correct + ;; return type, or all possible tags that fit in a given local context. + ;; + + ;;; Vocabulary: + ;; + ;; Here are some words used to describe different things in the analyzer: + ;; + ;; tag - A single entity + ;; prefix - The beginning of a symbol, usually used to look up something + ;; incomplete. + ;; type - The name of a datatype in the langauge. + ;; metatype - If a type is named in a declaration like: + ;; struct moose somevariable; + ;; that name "moose" can be turned into a concrete type. + ;; tag sequence - In C code, a list of dereferences, such as: + ;; this.that.theother(); + ;; parent - For a datatype in an OO language, another datatype + ;; inherited from. This excludes interfaces. + ;; scope - A list of tags that can be dereferenced that cannot + ;; be found from the global namespace. + ;; scopetypes - A list of tags which are datatype that contain + ;; the scope. The scopetypes need to have the scope extracted + ;; in a way that honors the type of inheritance. + ;; nest/nested - When one tag is contained entirely in another. + ;; + ;; context - A semantic datatype representing a point in a buffer. + ;; + ;; constriant - If a context specifies a specific datatype is needed, + ;; that is a constraint. + ;; constants - Some datatypes define elements of themselves as a + ;; constant. These need to be returned as there would be no + ;; other possible completions. -;; ++ + (require 'semantic) + (require 'semantic/format) + (require 'semantic/ctxt) -(require 'semantic/sort) -(eval-when-compile (require 'semantic/find)) + (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. ++ "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 --cc lisp/cedet/semantic/analyze/complete.el index 00000000000,c0914cefe4c..5d858e59949 mode 000000,100644..100644 --- a/lisp/cedet/semantic/analyze/complete.el +++ b/lisp/cedet/semantic/analyze/complete.el @@@ -1,0 -1,281 +1,263 @@@ + ;;; semantic/analyze/complete.el --- Smart Completions + + ;;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + + ;; Author: Eric M. Ludlam + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; + ;; Caclulate smart completions. + ;; + ;; Uses the analyzer context routine to determine the best possible + ;; list of completions. + ;; + ;;; History: + ;; + ;; Code was moved here from semantic-analyze.el + + (require 'semantic/analyze) + + ;; For semantic-find-* macros: + (eval-when-compile (require 'semantic/find)) + + ;;; Code: + + ;;; Helper Fcns + ;; + ;; + ;;;###autoload + (define-overloadable-function semantic-analyze-type-constants (type) + "For the tag TYPE, return any constant symbols of TYPE. + Used as options when completing.") + + (defun semantic-analyze-type-constants-default (type) + "Do nothing with TYPE." + nil) + -;; Old impl of the above. I'm not sure what the issue is -; (let ((ans -; (:override-with-args -; ((semantic-analyze-find-tag (semantic-tag-name type))) -; ;; Be default, we don't know. -; nil)) -; (out nil)) -; (dolist (elt ans) -; (cond -; ((stringp elt) -; (push (semantic-tag-new-variable -; elt (semantic-tag-name type) nil) -; out)) -; ((semantic-tag-p elt) -; (push elt out)) -; (t nil))) -; (nreverse out))) - + (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 --cc lisp/cedet/semantic/analyze/fcn.el index 00000000000,e0059896fb3..c86a79a226d mode 000000,100644..100644 --- a/lisp/cedet/semantic/analyze/fcn.el +++ b/lisp/cedet/semantic/analyze/fcn.el @@@ -1,0 -1,340 +1,337 @@@ + ;;; semantic/analyze/fcn.el --- Analyzer support functions. + + ;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + + ;; Author: Eric M. Ludlam + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; + ;; Analyzer support functions. + + ;;; Code: + -(require 'mode-local) + (require 'semantic) -(require 'semantic/tag) - + (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 --cc lisp/cedet/semantic/bovine.el index 00000000000,a9d06c16db0..d11fc16e07c mode 000000,100644..100644 --- a/lisp/cedet/semantic/bovine.el +++ b/lisp/cedet/semantic/bovine.el @@@ -1,0 -1,289 +1,297 @@@ + ;;; semantic/bovine.el --- LL Parser/Analyzer core. + + ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007 + ;;; Free Software Foundation, Inc. + + ;; Author: Eric M. Ludlam + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; + ;; Semantix 1.x uses an LL parser named the "bovinator". This parser + ;; had several conveniences in it which made for parsing tags out of + ;; languages with list characters easy. This parser lives on as one + ;; of many available parsers for semantic the tool. + ;; + ;; This parser should be used when the language is simple, such as + ;; makefiles or other data-declaritive langauges. + + ;;; Code: + (require 'semantic) -(require 'semantic/bovine/debug) ++ ++(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 semantic-debug-enabled ++ (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 (semantic-bovine-debug-create-frame - db-nt db-midx db-tidx cvl (car s))) ++ (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)) - (if semantic-debug-enabled - (let ((frame (semantic-create-bovine-debug-error-frame - debug-condition))) - (semantic-debug-break frame) - )) - )) ++ (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 --cc lisp/cedet/semantic/bovine/c-by.el index 00000000000,e68a04a352c..e6be8a6822e mode 000000,100644..100644 --- a/lisp/cedet/semantic/bovine/c-by.el +++ b/lisp/cedet/semantic/bovine/c-by.el @@@ -1,0 -1,2200 +1,2196 @@@ + ;;; semantic/bovine/c-by.el --- Generated parser support file + + ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, + ;;; 2007, 2008, 2009 Free Software Foundation, Inc. + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; + ;; This file was generated from the grammar file semantic/bovine/c.by + ;; in the CEDET repository. + + ;;; Code: + ++(require 'semantic/lex) + (eval-when-compile (require 'semantic/bovine)) ++ + (declare-function semantic-c-reconstitute-token "semantic/bovine/c") + (declare-function semantic-c-reconstitute-template "semantic/bovine/c") + (declare-function semantic-expand-c-tag "semantic/bovine/c") + + (defconst semantic-c-by--keyword-table + (semantic-lex-make-keyword-table + '(("extern" . EXTERN) + ("static" . STATIC) + ("const" . CONST) + ("volatile" . VOLATILE) + ("register" . REGISTER) + ("signed" . SIGNED) + ("unsigned" . UNSIGNED) + ("inline" . INLINE) + ("virtual" . VIRTUAL) + ("mutable" . MUTABLE) + ("struct" . STRUCT) + ("union" . UNION) + ("enum" . ENUM) + ("typedef" . TYPEDEF) + ("class" . CLASS) + ("typename" . TYPENAME) + ("namespace" . NAMESPACE) + ("using" . USING) + ("new" . NEW) + ("delete" . DELETE) + ("template" . TEMPLATE) + ("throw" . THROW) + ("reentrant" . REENTRANT) + ("try" . TRY) + ("catch" . CATCH) + ("operator" . OPERATOR) + ("public" . PUBLIC) + ("private" . PRIVATE) + ("protected" . PROTECTED) + ("friend" . FRIEND) + ("if" . IF) + ("else" . ELSE) + ("do" . DO) + ("while" . WHILE) + ("for" . FOR) + ("switch" . SWITCH) + ("case" . CASE) + ("default" . DEFAULT) + ("return" . RETURN) + ("break" . BREAK) + ("continue" . CONTINUE) + ("sizeof" . SIZEOF) + ("void" . VOID) + ("char" . CHAR) + ("wchar_t" . WCHAR) + ("short" . SHORT) + ("int" . INT) + ("long" . LONG) + ("float" . FLOAT) + ("double" . DOUBLE) + ("bool" . BOOL) + ("_P" . UNDERP) + ("__P" . UNDERUNDERP)) + '(("__P" summary "Common macro to eliminate prototype compatibility on some compilers") + ("_P" summary "Common macro to eliminate prototype compatibility on some compilers") + ("bool" summary "Primitive boolean type") + ("double" summary "Primitive floating-point type (double-precision 64-bit IEEE 754)") + ("float" summary "Primitive floating-point type (single-precision 32-bit IEEE 754)") + ("long" summary "Integral primitive type (-9223372036854775808 to 9223372036854775807)") + ("int" summary "Integral Primitive Type: (-2147483648 to 2147483647)") + ("short" summary "Integral Primitive Type: (-32768 to 32767)") + ("wchar_t" summary "Wide Character Type") + ("char" summary "Integral Character Type: (0 to 256)") + ("void" summary "Built in typeless type: void") + ("sizeof" summary "Compile time macro: sizeof() // size in bytes") + ("continue" summary "Non-local continue within a loop (for, do/while): continue;") + ("break" summary "Non-local exit within a loop or switch (for, do/while, switch): break;") + ("return" summary "return ;") + ("default" summary "switch () { case : code; ... default: code; }") + ("case" summary "switch () { case : code; ... default: code; }") + ("switch" summary "switch () { case : code; ... default: code; }") + ("for" summary "for(; ; ) { code }") + ("while" summary "do { code } while (); or while () { code };") + ("do" summary " do { code } while ();") + ("else" summary "if () { code } [ else { code } ]") + ("if" summary "if () { code } [ else { code } ]") + ("friend" summary "friend class ") + ("catch" summary "try { } catch { }") + ("try" summary "try { } catch { }") + ("reentrant" summary " () reentrant ...") + ("throw" summary " () throw () ...") + ("template" summary "template TYPE_OR_FUNCTION") + ("delete" summary "delete ;") + ("new" summary "new ();") + ("using" summary "using ;") + ("namespace" summary "Namespace Declaration: namespace { ... };") + ("typename" summary "typename is used to handle a qualified name as a typename;") + ("class" summary "Class Declaration: class [:parents] { ... };") + ("typedef" summary "Arbitrary Type Declaration: typedef ;") + ("enum" summary "Enumeration Type Declaration: enum [name] { ... };") + ("union" summary "Union Type Declaration: union [name] { ... };") + ("struct" summary "Structure Type Declaration: struct [name] { ... };") + ("mutable" summary "Member Declaration Modifier: mutable ...") + ("virtual" summary "Method Modifier: virtual (...) ...") + ("inline" summary "Function Modifier: inline (...) {...};") + ("unsigned" summary "Numeric Type Modifier: unsigned ...") + ("signed" summary "Numeric Type Modifier: signed ...") + ("register" summary "Declaration Modifier: register ...") + ("volatile" summary "Declaration Modifier: volatile ...") + ("const" summary "Declaration Modifier: const ...") + ("static" summary "Declaration Modifier: static ...") + ("extern" summary "Declaration Modifier: extern ..."))) + "Table of language keywords.") + + (defconst semantic-c-by--token-table + (semantic-lex-make-type-table + '(("semantic-list" + (BRACKETS . "\\[\\]") + (PARENS . "()") + (VOID_BLCK . "^(void)$") + (BRACE_BLCK . "^{") + (PAREN_BLCK . "^(") + (BRACK_BLCK . "\\[.*\\]$")) + ("close-paren" + (RBRACE . "}") + (RPAREN . ")")) + ("open-paren" + (LBRACE . "{") + (LPAREN . "(")) + ("symbol" + (RESTRICT . "\\<\\(__\\)?restrict\\>")) + ("number" + (ZERO . "^0$")) + ("string" + (CPP . "\"C\\+\\+\"") + (C . "\"C\"")) + ("punctuation" + (OR . "\\`[|]\\'") + (HAT . "\\`\\^\\'") + (MOD . "\\`[%]\\'") + (TILDE . "\\`[~]\\'") + (COMA . "\\`[,]\\'") + (GREATER . "\\`[>]\\'") + (LESS . "\\`[<]\\'") + (EQUAL . "\\`[=]\\'") + (BANG . "\\`[!]\\'") + (MINUS . "\\`[-]\\'") + (PLUS . "\\`[+]\\'") + (DIVIDE . "\\`[/]\\'") + (AMPERSAND . "\\`[&]\\'") + (STAR . "\\`[*]\\'") + (SEMICOLON . "\\`[;]\\'") + (COLON . "\\`[:]\\'") + (PERIOD . "\\`[.]\\'") + (HASH . "\\`[#]\\'"))) + 'nil) + "Table of lexical tokens.") + + (defconst semantic-c-by--parse-table + `( + (bovine-toplevel + (declaration) + ) ;; end bovine-toplevel + + (bovine-inner-scope + (codeblock) + ) ;; end bovine-inner-scope + + (declaration + (macro) + (type) + (define) + (var-or-fun) + (extern-c) + (template) + (using) + ) ;; end declaration + + (codeblock + (define) + (codeblock-var-or-fun) + (type) + (using) + ) ;; end codeblock + + (extern-c-contents + (open-paren + ,(semantic-lambda + (list nil)) + ) + (declaration) + (close-paren + ,(semantic-lambda + (list nil)) + ) + ) ;; end extern-c-contents + + (extern-c + (EXTERN + string + "\"C\"" + semantic-list + ,(semantic-lambda + (semantic-tag + "C" + 'extern :members + (semantic-parse-region + (car + (nth 2 vals)) + (cdr + (nth 2 vals)) + 'extern-c-contents + 1))) + ) + (EXTERN + string + "\"C\\+\\+\"" + semantic-list + ,(semantic-lambda + (semantic-tag + "C" + 'extern :members + (semantic-parse-region + (car + (nth 2 vals)) + (cdr + (nth 2 vals)) + 'extern-c-contents + 1))) + ) + (EXTERN + string + "\"C\"" + ,(semantic-lambda + (list nil)) + ) + (EXTERN + string + "\"C\\+\\+\"" + ,(semantic-lambda + (list nil)) + ) + ) ;; end extern-c + + (macro + (spp-macro-def + ,(semantic-lambda + (semantic-tag-new-variable + (nth 0 vals) nil nil :constant-flag t)) + ) + (spp-system-include + ,(semantic-lambda + (semantic-tag-new-include + (nth 0 vals) t)) + ) + (spp-include + ,(semantic-lambda + (semantic-tag-new-include + (nth 0 vals) nil)) + ) + ) ;; end macro + + (define + (spp-macro-def + ,(semantic-lambda + (semantic-tag-new-variable + (nth 0 vals) nil nil :constant-flag t)) + ) + (spp-macro-undef + ,(semantic-lambda + (list nil)) + ) + ) ;; end define + + (unionparts + (semantic-list + ,(semantic-lambda + (semantic-parse-region + (car + (nth 0 vals)) + (cdr + (nth 0 vals)) + 'classsubparts + 1)) + ) + ) ;; end unionparts + + (opt-symbol + (symbol) + ( ;;EMPTY + ) + ) ;; end opt-symbol + + (classsubparts + (open-paren + "{" + ,(semantic-lambda + (list nil)) + ) + (close-paren + "}" + ,(semantic-lambda + (list nil)) + ) + (class-protection + opt-symbol + punctuation + "\\`[:]\\'" + ,(semantic-lambda + (semantic-tag + (car + (nth 0 vals)) + 'label)) + ) + (var-or-fun) + (FRIEND + func-decl + ,(semantic-lambda + (semantic-tag + (car + (nth 1 vals)) + 'friend)) + ) + (FRIEND + CLASS + symbol + ,(semantic-lambda + (semantic-tag + (nth 2 vals) + 'friend)) + ) + (type) + (define) + (template) + ( ;;EMPTY + ) + ) ;; end classsubparts + + (opt-class-parents + (punctuation + "\\`[:]\\'" + class-parents + opt-template-specifier + ,(semantic-lambda + (list + (nth 1 vals))) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end opt-class-parents + + (one-class-parent + (opt-class-protection + opt-class-declmods + namespace-symbol + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 2 vals)) + "class" nil nil :protection + (car + (nth 0 vals)))) + ) + (opt-class-declmods + opt-class-protection + namespace-symbol + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 2 vals)) + "class" nil nil :protection + (car + (nth 1 vals)))) + ) + ) ;; end one-class-parent + + (class-parents + (one-class-parent + punctuation + "\\`[,]\\'" + class-parents + ,(semantic-lambda + (cons + (nth 0 vals) + (nth 2 vals))) + ) + (one-class-parent + ,(semantic-lambda + (list + (nth 0 vals))) + ) + ) ;; end class-parents + + (opt-class-declmods + (class-declmods + opt-class-declmods + ,(semantic-lambda + (list nil)) + ) + ( ;;EMPTY + ) + ) ;; end opt-class-declmods + + (class-declmods + (VIRTUAL) + ) ;; end class-declmods + + (class-protection + (PUBLIC) + (PRIVATE) + (PROTECTED) + ) ;; end class-protection + + (opt-class-protection + (class-protection + ,(semantic-lambda + (nth 0 vals)) + ) + ( ;;EMPTY + ,(semantic-lambda + (list + "unspecified")) + ) + ) ;; end opt-class-protection + + (namespaceparts + (semantic-list + ,(semantic-lambda + (semantic-parse-region + (car + (nth 0 vals)) + (cdr + (nth 0 vals)) + 'namespacesubparts + 1)) + ) + ) ;; end namespaceparts + + (namespacesubparts + (open-paren + "{" + ,(semantic-lambda + (list nil)) + ) + (close-paren + "}" + ,(semantic-lambda + (list nil)) + ) + (type) + (var-or-fun) + (define) + (class-protection + punctuation + "\\`[:]\\'" + ,(semantic-lambda + (semantic-tag + (car + (nth 0 vals)) + 'label)) + ) + (template) + (using) + ( ;;EMPTY + ) + ) ;; end namespacesubparts + + (enumparts + (semantic-list + ,(semantic-lambda + (semantic-parse-region + (car + (nth 0 vals)) + (cdr + (nth 0 vals)) + 'enumsubparts + 1)) + ) + ) ;; end enumparts + + (enumsubparts + (symbol + opt-assign + ,(semantic-lambda + (semantic-tag-new-variable + (nth 0 vals) + "int" + (car + (nth 1 vals)) :constant-flag t)) + ) + (open-paren + "{" + ,(semantic-lambda + (list nil)) + ) + (close-paren + "}" + ,(semantic-lambda + (list nil)) + ) + (punctuation + "\\`[,]\\'" + ,(semantic-lambda + (list nil)) + ) + ) ;; end enumsubparts + + (opt-name + (symbol) + ( ;;EMPTY + ,(semantic-lambda + (list + "")) + ) + ) ;; end opt-name + + (typesimple + (struct-or-class + opt-class + opt-name + opt-template-specifier + opt-class-parents + semantic-list + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 2 vals)) + (car + (nth 0 vals)) + (let + ( + (semantic-c-classname + (cons + (car + (nth 2 vals)) + (car + (nth 0 vals))))) + (semantic-parse-region + (car + (nth 5 vals)) + (cdr + (nth 5 vals)) + 'classsubparts + 1)) + (nth 4 vals) :template-specifier + (nth 3 vals) :parent + (car + (nth 1 vals)))) + ) + (struct-or-class + opt-class + opt-name + opt-template-specifier + opt-class-parents + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 2 vals)) + (car + (nth 0 vals)) nil + (nth 4 vals) :template-specifier + (nth 3 vals) :prototype t :parent + (car + (nth 1 vals)))) + ) + (UNION + opt-class + opt-name + unionparts + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 2 vals)) + (nth 0 vals) + (nth 3 vals) nil :parent + (car + (nth 1 vals)))) + ) + (ENUM + opt-class + opt-name + enumparts + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 2 vals)) + (nth 0 vals) + (nth 3 vals) nil :parent + (car + (nth 1 vals)))) + ) + (TYPEDEF + declmods + typeformbase + cv-declmods + typedef-symbol-list + ,(semantic-lambda + (semantic-tag-new-type + (nth 4 vals) + (nth 0 vals) nil + (list + (nth 2 vals)))) + ) + ) ;; end typesimple + + (typedef-symbol-list + (typedefname + punctuation + "\\`[,]\\'" + typedef-symbol-list + ,(semantic-lambda + (cons + (nth 0 vals) + (nth 2 vals))) + ) + (typedefname + ,(semantic-lambda + (list + (nth 0 vals))) + ) + ) ;; end typedef-symbol-list + + (typedefname + (opt-stars + symbol + opt-bits + opt-array + ,(semantic-lambda + (list + (nth 0 vals) + (nth 1 vals))) + ) + ) ;; end typedefname + + (struct-or-class + (STRUCT) + (CLASS) + ) ;; end struct-or-class + + (type + (typesimple + punctuation + "\\`[;]\\'" + ,(semantic-lambda + (nth 0 vals)) + ) + (NAMESPACE + symbol + namespaceparts + ,(semantic-lambda + (semantic-tag-new-type + (nth 1 vals) + (nth 0 vals) + (nth 2 vals) nil)) + ) + (NAMESPACE + namespaceparts + ,(semantic-lambda + (semantic-tag-new-type + "unnamed" + (nth 0 vals) + (nth 1 vals) nil)) + ) + (NAMESPACE + symbol + punctuation + "\\`[=]\\'" + typeformbase + punctuation + "\\`[;]\\'" + ,(semantic-lambda + (semantic-tag-new-type + (nth 1 vals) + (nth 0 vals) + (list + (semantic-tag-new-type + (car + (nth 3 vals)) + (nth 0 vals) nil nil)) nil :kind + 'alias)) + ) + ) ;; end type + + (using + (USING + usingname + punctuation + "\\`[;]\\'" + ,(semantic-lambda + (semantic-tag + (car + (nth 1 vals)) + 'using :type + (nth 1 vals))) + ) + ) ;; end using + + (usingname + (typeformbase + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 0 vals)) + "class" nil nil :prototype t)) + ) + (NAMESPACE + typeformbase + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 1 vals)) + "namespace" nil nil :prototype t)) + ) + ) ;; end usingname + + (template + (TEMPLATE + template-specifier + opt-friend + template-definition + ,(semantic-lambda + (semantic-c-reconstitute-template + (nth 3 vals) + (nth 1 vals))) + ) + ) ;; end template + + (opt-friend + (FRIEND) + ( ;;EMPTY + ) + ) ;; end opt-friend + + (opt-template-specifier + (template-specifier + ,(semantic-lambda + (nth 0 vals)) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end opt-template-specifier + + (template-specifier + (punctuation + "\\`[<]\\'" + template-specifier-types + punctuation + "\\`[>]\\'" + ,(semantic-lambda + (nth 1 vals)) + ) + ) ;; end template-specifier + + (template-specifier-types + (template-var + template-specifier-type-list + ,(semantic-lambda + (cons + (nth 0 vals) + (nth 1 vals))) + ) + ( ;;EMPTY + ) + ) ;; end template-specifier-types + + (template-specifier-type-list + (punctuation + "\\`[,]\\'" + template-specifier-types + ,(semantic-lambda + (nth 1 vals)) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end template-specifier-type-list + + (template-var + (template-type + opt-template-equal + ,(semantic-lambda + (cons + (car + (nth 0 vals)) + (cdr + (nth 0 vals)))) + ) + (string + ,(semantic-lambda + (list + (nth 0 vals))) + ) + (number + ,(semantic-lambda + (list + (nth 0 vals))) + ) + (opt-stars + opt-ref + namespace-symbol + ,(semantic-lambda + (nth 2 vals)) + ) + (semantic-list + ,(semantic-lambda + (list + (nth 0 vals))) + ) + (SIZEOF + semantic-list + ,(semantic-lambda + (list + (nth 1 vals))) + ) + ) ;; end template-var + + (opt-template-equal + (punctuation + "\\`[=]\\'" + symbol + punctuation + "\\`[<]\\'" + template-specifier-types + punctuation + "\\`[>]\\'" + ,(semantic-lambda + (list + (nth 1 vals))) + ) + (punctuation + "\\`[=]\\'" + symbol + ,(semantic-lambda + (list + (nth 1 vals))) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end opt-template-equal + + (template-type + (CLASS + symbol + ,(semantic-lambda + (semantic-tag-new-type + (nth 1 vals) + "class" nil nil)) + ) + (STRUCT + symbol + ,(semantic-lambda + (semantic-tag-new-type + (nth 1 vals) + "struct" nil nil)) + ) + (TYPENAME + symbol + ,(semantic-lambda + (semantic-tag-new-type + (nth 1 vals) + "class" nil nil)) + ) + (declmods + typeformbase + cv-declmods + opt-stars + opt-ref + variablearg-opt-name + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 1 vals)) nil nil nil :constant-flag + (if + (member + "const" + (append + (nth 0 vals) + (nth 2 vals))) t nil) :typemodifiers + (delete + "const" + (append + (nth 0 vals) + (nth 2 vals))) :reference + (car + (nth 4 vals)) :pointer + (car + (nth 3 vals)))) + ) + ) ;; end template-type + + (template-definition + (type + ,(semantic-lambda + (nth 0 vals)) + ) + (var-or-fun + ,(semantic-lambda + (nth 0 vals)) + ) + ) ;; end template-definition + + (opt-stars + (punctuation + "\\`[*]\\'" + opt-starmod + opt-stars + ,(semantic-lambda + (list + (1+ + (car + (nth 2 vals))))) + ) + ( ;;EMPTY + ,(semantic-lambda + (list + 0)) + ) + ) ;; end opt-stars + + (opt-starmod + (STARMOD + opt-starmod + ,(semantic-lambda + (cons + (car + (nth 0 vals)) + (nth 1 vals))) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end opt-starmod + + (STARMOD + (CONST) + ) ;; end STARMOD + + (declmods + (DECLMOD + declmods + ,(semantic-lambda + (cons + (car + (nth 0 vals)) + (nth 1 vals))) + ) + (DECLMOD + ,(semantic-lambda + (nth 0 vals)) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end declmods + + (DECLMOD + (EXTERN) + (STATIC) + (CVDECLMOD) + (INLINE) + (REGISTER) + (FRIEND) + (TYPENAME) + (METADECLMOD) + (VIRTUAL) + ) ;; end DECLMOD + + (metadeclmod + (METADECLMOD + ,(semantic-lambda) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end metadeclmod + + (CVDECLMOD + (CONST) + (VOLATILE) + ) ;; end CVDECLMOD + + (cv-declmods + (CVDECLMOD + cv-declmods + ,(semantic-lambda + (cons + (car + (nth 0 vals)) + (nth 1 vals))) + ) + (CVDECLMOD + ,(semantic-lambda + (nth 0 vals)) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end cv-declmods + + (METADECLMOD + (VIRTUAL) + (MUTABLE) + ) ;; end METADECLMOD + + (opt-ref + (punctuation + "\\`[&]\\'" + ,(semantic-lambda + (list + 1)) + ) + ( ;;EMPTY + ,(semantic-lambda + (list + 0)) + ) + ) ;; end opt-ref + + (typeformbase + (typesimple + ,(semantic-lambda + (nth 0 vals)) + ) + (STRUCT + symbol + ,(semantic-lambda + (semantic-tag-new-type + (nth 1 vals) + (nth 0 vals) nil nil)) + ) + (UNION + symbol + ,(semantic-lambda + (semantic-tag-new-type + (nth 1 vals) + (nth 0 vals) nil nil)) + ) + (ENUM + symbol + ,(semantic-lambda + (semantic-tag-new-type + (nth 1 vals) + (nth 0 vals) nil nil)) + ) + (builtintype + ,(semantic-lambda + (nth 0 vals)) + ) + (symbol + template-specifier + ,(semantic-lambda + (semantic-tag-new-type + (nth 0 vals) + "class" nil nil :template-specifier + (nth 1 vals))) + ) + (namespace-symbol-for-typeformbase + opt-template-specifier + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 0 vals)) + "class" nil nil :template-specifier + (nth 1 vals))) + ) + (symbol + ,(semantic-lambda + (list + (nth 0 vals))) + ) + ) ;; end typeformbase + + (signedmod + (UNSIGNED) + (SIGNED) + ) ;; end signedmod + + (builtintype-types + (VOID) + (CHAR) + (WCHAR) + (SHORT + INT + ,(semantic-lambda + (list + (concat + (nth 0 vals) + " " + (nth 1 vals)))) + ) + (SHORT) + (INT) + (LONG + INT + ,(semantic-lambda + (list + (concat + (nth 0 vals) + " " + (nth 1 vals)))) + ) + (FLOAT) + (DOUBLE) + (BOOL) + (LONG + DOUBLE + ,(semantic-lambda + (list + (concat + (nth 0 vals) + " " + (nth 1 vals)))) + ) + (LONG + LONG + ,(semantic-lambda + (list + (concat + (nth 0 vals) + " " + (nth 1 vals)))) + ) + (LONG) + ) ;; end builtintype-types + + (builtintype + (signedmod + builtintype-types + ,(semantic-lambda + (list + (concat + (car + (nth 0 vals)) + " " + (car + (nth 1 vals))))) + ) + (builtintype-types + ,(semantic-lambda + (nth 0 vals)) + ) + (signedmod + ,(semantic-lambda + (list + (concat + (car + (nth 0 vals)) + " int"))) + ) + ) ;; end builtintype + + (codeblock-var-or-fun + (declmods + typeformbase + declmods + opt-ref + var-or-func-decl + ,(semantic-lambda + (semantic-c-reconstitute-token + (nth 4 vals) + (nth 0 vals) + (nth 1 vals))) + ) + ) ;; end codeblock-var-or-fun + + (var-or-fun + (codeblock-var-or-fun + ,(semantic-lambda + (nth 0 vals)) + ) + (declmods + var-or-func-decl + ,(semantic-lambda + (semantic-c-reconstitute-token + (nth 1 vals) + (nth 0 vals) nil)) + ) + ) ;; end var-or-fun + + (var-or-func-decl + (func-decl + ,(semantic-lambda + (nth 0 vals)) + ) + (var-decl + ,(semantic-lambda + (nth 0 vals)) + ) + ) ;; end var-or-func-decl + + (func-decl + (opt-stars + opt-class + opt-destructor + functionname + opt-template-specifier + opt-under-p + arg-list + opt-post-fcn-modifiers + opt-throw + opt-initializers + fun-or-proto-end + ,(semantic-lambda + (nth 3 vals) + (list + 'function + (nth 1 vals) + (nth 2 vals) + (nth 6 vals) + (nth 8 vals) + (nth 7 vals)) + (nth 0 vals) + (nth 10 vals) + (nth 4 vals)) + ) + (opt-stars + opt-class + opt-destructor + functionname + opt-template-specifier + opt-under-p + opt-post-fcn-modifiers + opt-throw + opt-initializers + fun-try-end + ,(semantic-lambda + (nth 3 vals) + (list + 'function + (nth 1 vals) + (nth 2 vals) nil + (nth 7 vals) + (nth 6 vals)) + (nth 0 vals) + (nth 9 vals) + (nth 4 vals)) + ) + ) ;; end func-decl + + (var-decl + (varnamelist + punctuation + "\\`[;]\\'" + ,(semantic-lambda + (list + (nth 0 vals) + 'variable)) + ) + ) ;; end var-decl + + (opt-under-p + (UNDERP + ,(semantic-lambda + (list nil)) + ) + (UNDERUNDERP + ,(semantic-lambda + (list nil)) + ) + ( ;;EMPTY + ) + ) ;; end opt-under-p + + (opt-initializers + (punctuation + "\\`[:]\\'" + namespace-symbol + semantic-list + opt-initializers) + (punctuation + "\\`[,]\\'" + namespace-symbol + semantic-list + opt-initializers) + ( ;;EMPTY + ) + ) ;; end opt-initializers + + (opt-post-fcn-modifiers + (post-fcn-modifiers + opt-post-fcn-modifiers + ,(semantic-lambda + (cons + (nth 0 vals) + (nth 1 vals))) + ) + ( ;;EMPTY + ,(semantic-lambda + (list nil)) + ) + ) ;; end opt-post-fcn-modifiers + + (post-fcn-modifiers + (REENTRANT) + (CONST) + ) ;; end post-fcn-modifiers + + (opt-throw + (THROW + semantic-list + ,(lambda (vals start end) + (semantic-bovinate-from-nonterminal + (car + (nth 1 vals)) + (cdr + (nth 1 vals)) + 'throw-exception-list)) + ) + ( ;;EMPTY + ) + ) ;; end opt-throw + + (throw-exception-list + (namespace-symbol + punctuation + "\\`[,]\\'" + throw-exception-list + ,(semantic-lambda + (cons + (car + (nth 0 vals)) + (nth 2 vals))) + ) + (namespace-symbol + close-paren + ")" + ,(semantic-lambda + (nth 0 vals)) + ) + (symbol + close-paren + ")" + ,(semantic-lambda + (list + (nth 0 vals))) + ) + (open-paren + "(" + throw-exception-list + ,(semantic-lambda + (nth 1 vals)) + ) + (close-paren + ")" + ,(semantic-lambda) + ) + ) ;; end throw-exception-list + + (opt-bits + (punctuation + "\\`[:]\\'" + number + ,(semantic-lambda + (list + (nth 1 vals))) + ) + ( ;;EMPTY + ,(semantic-lambda + (list nil)) + ) + ) ;; end opt-bits + + (opt-array + (semantic-list + "\\[.*\\]$" + opt-array + ,(semantic-lambda + (list + (cons + 1 + (car + (nth 1 vals))))) + ) + ( ;;EMPTY + ,(semantic-lambda + (list nil)) + ) + ) ;; end opt-array + + (opt-assign + (punctuation + "\\`[=]\\'" + expression + ,(semantic-lambda + (list + (nth 1 vals))) + ) + ( ;;EMPTY + ,(semantic-lambda + (list nil)) + ) + ) ;; end opt-assign + + (opt-restrict + (symbol + "\\<\\(__\\)?restrict\\>") + ( ;;EMPTY + ) + ) ;; end opt-restrict + + (varname + (opt-stars + opt-restrict + namespace-symbol + opt-bits + opt-array + opt-assign + ,(semantic-lambda + (nth 2 vals) + (nth 0 vals) + (nth 3 vals) + (nth 4 vals) + (nth 5 vals)) + ) + ) ;; end varname + + (variablearg + (declmods + typeformbase + cv-declmods + opt-ref + variablearg-opt-name + ,(semantic-lambda + (semantic-tag-new-variable + (list + (nth 4 vals)) + (nth 1 vals) nil :constant-flag + (if + (member + "const" + (append + (nth 0 vals) + (nth 2 vals))) t nil) :typemodifiers + (delete + "const" + (append + (nth 0 vals) + (nth 2 vals))) :reference + (car + (nth 3 vals)))) + ) + ) ;; end variablearg + + (variablearg-opt-name + (varname + ,(semantic-lambda + (nth 0 vals)) + ) + (opt-stars + ,(semantic-lambda + (list + "") + (nth 0 vals) + (list nil nil nil)) + ) + ) ;; end variablearg-opt-name + + (varnamelist + (opt-ref + varname + punctuation + "\\`[,]\\'" + varnamelist + ,(semantic-lambda + (cons + (nth 1 vals) + (nth 3 vals))) + ) + (opt-ref + varname + ,(semantic-lambda + (list + (nth 1 vals))) + ) + ) ;; end varnamelist + + (namespace-symbol + (symbol + opt-template-specifier + punctuation + "\\`[:]\\'" + punctuation + "\\`[:]\\'" + namespace-symbol + ,(semantic-lambda + (list + (concat + (nth 0 vals) + "::" + (car + (nth 4 vals))))) + ) + (symbol + opt-template-specifier + ,(semantic-lambda + (list + (nth 0 vals))) + ) + ) ;; end namespace-symbol + + (namespace-symbol-for-typeformbase + (symbol + opt-template-specifier + punctuation + "\\`[:]\\'" + punctuation + "\\`[:]\\'" + namespace-symbol-for-typeformbase + ,(semantic-lambda + (list + (concat + (nth 0 vals) + "::" + (car + (nth 4 vals))))) + ) + (symbol + ,(semantic-lambda + (list + (nth 0 vals))) + ) + ) ;; end namespace-symbol-for-typeformbase + + (namespace-opt-class + (symbol + punctuation + "\\`[:]\\'" + punctuation + "\\`[:]\\'" + namespace-opt-class + ,(semantic-lambda + (list + (concat + (nth 0 vals) + "::" + (car + (nth 3 vals))))) + ) + (symbol + opt-template-specifier + punctuation + "\\`[:]\\'" + punctuation + "\\`[:]\\'" + ,(semantic-lambda + (list + (nth 0 vals))) + ) + ) ;; end namespace-opt-class + + (opt-class + (namespace-opt-class + ,(semantic-lambda + (nth 0 vals)) + ) + ( ;;EMPTY + ,(semantic-lambda + (list nil)) + ) + ) ;; end opt-class + + (opt-destructor + (punctuation + "\\`[~]\\'" + ,(semantic-lambda + (list t)) + ) + ( ;;EMPTY + ,(semantic-lambda + (list nil)) + ) + ) ;; end opt-destructor + + (arg-list + (semantic-list + "^(" + knr-arguments + ,(semantic-lambda + (nth 1 vals)) + ) + (semantic-list + "^(" + ,(semantic-lambda + (semantic-parse-region + (car + (nth 0 vals)) + (cdr + (nth 0 vals)) + 'arg-sub-list + 1)) + ) + (semantic-list + "^(void)$" + ,(semantic-lambda) + ) + ) ;; end arg-list + + (knr-varnamelist + (varname + punctuation + "\\`[,]\\'" + knr-varnamelist + ,(semantic-lambda + (cons + (nth 0 vals) + (nth 2 vals))) + ) + (varname + ,(semantic-lambda + (list + (nth 0 vals))) + ) + ) ;; end knr-varnamelist + + (knr-one-variable-decl + (declmods + typeformbase + cv-declmods + knr-varnamelist + ,(semantic-lambda + (semantic-tag-new-variable + (nreverse + (nth 3 vals)) + (nth 1 vals) nil :constant-flag + (if + (member + "const" + (append + (nth 2 vals))) t nil) :typemodifiers + (delete + "const" + (nth 2 vals)))) + ) + ) ;; end knr-one-variable-decl + + (knr-arguments + (knr-one-variable-decl + punctuation + "\\`[;]\\'" + knr-arguments + ,(semantic-lambda + (append + (semantic-expand-c-tag + (nth 0 vals)) + (nth 2 vals))) + ) + (knr-one-variable-decl + punctuation + "\\`[;]\\'" + ,(semantic-lambda + (semantic-expand-c-tag + (nth 0 vals))) + ) + ) ;; end knr-arguments + + (arg-sub-list + (variablearg + ,(semantic-lambda + (nth 0 vals)) + ) + (punctuation + "\\`[.]\\'" + punctuation + "\\`[.]\\'" + punctuation + "\\`[.]\\'" + close-paren + ")" + ,(semantic-lambda + (semantic-tag-new-variable + "..." + "vararg" nil)) + ) + (punctuation + "\\`[,]\\'" + ,(semantic-lambda + (list nil)) + ) + (open-paren + "(" + ,(semantic-lambda + (list nil)) + ) + (close-paren + ")" + ,(semantic-lambda + (list nil)) + ) + ) ;; end arg-sub-list + + (operatorsym + (punctuation + "\\`[<]\\'" + punctuation + "\\`[<]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "<<=")) + ) + (punctuation + "\\`[>]\\'" + punctuation + "\\`[>]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + ">>=")) + ) + (punctuation + "\\`[<]\\'" + punctuation + "\\`[<]\\'" + ,(semantic-lambda + (list + "<<")) + ) + (punctuation + "\\`[>]\\'" + punctuation + "\\`[>]\\'" + ,(semantic-lambda + (list + ">>")) + ) + (punctuation + "\\`[=]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "==")) + ) + (punctuation + "\\`[<]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "<=")) + ) + (punctuation + "\\`[>]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + ">=")) + ) + (punctuation + "\\`[!]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "!=")) + ) + (punctuation + "\\`[+]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "+=")) + ) + (punctuation + "\\`[-]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "-=")) + ) + (punctuation + "\\`[*]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "*=")) + ) + (punctuation + "\\`[/]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "/=")) + ) + (punctuation + "\\`[%]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "%=")) + ) + (punctuation + "\\`[&]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "&=")) + ) + (punctuation + "\\`[|]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "|=")) + ) + (punctuation + "\\`[-]\\'" + punctuation + "\\`[>]\\'" + punctuation + "\\`[*]\\'" + ,(semantic-lambda + (list + "->*")) + ) + (punctuation + "\\`[-]\\'" + punctuation + "\\`[>]\\'" + ,(semantic-lambda + (list + "->")) + ) + (semantic-list + "()" + ,(semantic-lambda + (list + "()")) + ) + (semantic-list + "\\[\\]" + ,(semantic-lambda + (list + "[]")) + ) + (punctuation + "\\`[<]\\'") + (punctuation + "\\`[>]\\'") + (punctuation + "\\`[*]\\'") + (punctuation + "\\`[+]\\'" + punctuation + "\\`[+]\\'" + ,(semantic-lambda + (list + "++")) + ) + (punctuation + "\\`[+]\\'") + (punctuation + "\\`[-]\\'" + punctuation + "\\`[-]\\'" + ,(semantic-lambda + (list + "--")) + ) + (punctuation + "\\`[-]\\'") + (punctuation + "\\`[&]\\'" + punctuation + "\\`[&]\\'" + ,(semantic-lambda + (list + "&&")) + ) + (punctuation + "\\`[&]\\'") + (punctuation + "\\`[|]\\'" + punctuation + "\\`[|]\\'" + ,(semantic-lambda + (list + "||")) + ) + (punctuation + "\\`[|]\\'") + (punctuation + "\\`[/]\\'") + (punctuation + "\\`[=]\\'") + (punctuation + "\\`[!]\\'") + (punctuation + "\\`[~]\\'") + (punctuation + "\\`[%]\\'") + (punctuation + "\\`[,]\\'") + (punctuation + "\\`\\^\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "^=")) + ) + (punctuation + "\\`\\^\\'") + ) ;; end operatorsym + + (functionname + (OPERATOR + operatorsym + ,(semantic-lambda + (nth 1 vals)) + ) + (semantic-list + ,(lambda (vals start end) + (semantic-bovinate-from-nonterminal + (car + (nth 0 vals)) + (cdr + (nth 0 vals)) + 'function-pointer)) + ) + (symbol + ,(semantic-lambda + (list + (nth 0 vals))) + ) + ) ;; end functionname + + (function-pointer + (open-paren + "(" + punctuation + "\\`[*]\\'" + symbol + close-paren + ")" + ,(semantic-lambda + (list + (concat + "*" + (nth 2 vals)))) + ) + ) ;; end function-pointer + + (fun-or-proto-end + (punctuation + "\\`[;]\\'" + ,(semantic-lambda + (list t)) + ) + (semantic-list + ,(semantic-lambda + (list nil)) + ) + (punctuation + "\\`[=]\\'" + number + "^0$" + punctuation + "\\`[;]\\'" + ,(semantic-lambda + (list ':pure-virtual-flag)) + ) + (fun-try-end + ,(semantic-lambda + (list nil)) + ) + ) ;; end fun-or-proto-end + + (fun-try-end + (TRY + opt-initializers + semantic-list + "^{" + fun-try-several-catches + ,(semantic-lambda + (list nil)) + ) + ) ;; end fun-try-end + + (fun-try-several-catches + (CATCH + semantic-list + "^(" + semantic-list + "^{" + fun-try-several-catches + ,(semantic-lambda) + ) + (CATCH + semantic-list + "^{" + fun-try-several-catches + ,(semantic-lambda) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end fun-try-several-catches + + (type-cast + (semantic-list + ,(lambda (vals start end) + (semantic-bovinate-from-nonterminal + (car + (nth 0 vals)) + (cdr + (nth 0 vals)) + 'type-cast-list)) + ) + ) ;; end type-cast + + (type-cast-list + (open-paren + typeformbase + close-paren) + ) ;; end type-cast-list + + (opt-stuff-after-symbol + (semantic-list + "^(") + (semantic-list + "\\[.*\\]$") + ( ;;EMPTY + ) + ) ;; end opt-stuff-after-symbol + + (multi-stage-dereference + (namespace-symbol + opt-stuff-after-symbol + punctuation + "\\`[.]\\'" + multi-stage-dereference) + (namespace-symbol + opt-stuff-after-symbol + punctuation + "\\`[-]\\'" + punctuation + "\\`[>]\\'" + multi-stage-dereference) + (namespace-symbol + opt-stuff-after-symbol) + ) ;; end multi-stage-dereference + + (string-seq + (string + string-seq + ,(semantic-lambda + (list + (concat + (nth 0 vals) + (car + (nth 1 vals))))) + ) + (string + ,(semantic-lambda + (list + (nth 0 vals))) + ) + ) ;; end string-seq + + (expr-start + (punctuation + "\\`[-]\\'") + (punctuation + "\\`[+]\\'") + (punctuation + "\\`[*]\\'") + (punctuation + "\\`[&]\\'") + ) ;; end expr-start + + (expression + (number + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + (multi-stage-dereference + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + (NEW + multi-stage-dereference + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + (NEW + builtintype-types + semantic-list + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + (namespace-symbol + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + (string-seq + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + (type-cast + expression + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + (semantic-list + expression + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + (semantic-list + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + (expr-start + expression + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + ) ;; end expression + ) + "Parser table.") + + (defun semantic-c-by--install-parser () + "Setup the Semantic Parser." + (setq semantic--parse-table semantic-c-by--parse-table + semantic-debug-parser-source "c.by" + semantic-debug-parser-class 'semantic-bovine-debug-parser + semantic-flex-keywords-obarray semantic-c-by--keyword-table + semantic-equivalent-major-modes '(c-mode c++-mode) + )) - - -;;; Analyzers -;; -(require 'semantic/lex) - + + ;;; Epilogue + ;; + + (provide 'semantic/bovine/c-by) + + ;;; semantic/bovine/c-by.el ends here diff --cc lisp/cedet/semantic/bovine/c.el index 00000000000,0d250e2795f..b9077a2ef0b mode 000000,100644..100644 --- a/lisp/cedet/semantic/bovine/c.el +++ b/lisp/cedet/semantic/bovine/c.el @@@ -1,0 -1,1739 +1,1736 @@@ + ;;; semantic/bovine/c.el --- Semantic details for C + + ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, + ;;; 2007, 2008, 2009 Free Software Foundation, Inc. + + ;; Author: Eric M. Ludlam + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; + ;; Support for the C/C++ bovine parser for Semantic. + ;; + ;; @todo - can I support c++-font-lock-extra-types ? + + (require 'semantic) + (require 'semantic/analyze) + (require 'semantic/bovine/gcc) -(require 'semantic/format) + (require 'semantic/idle) + (require 'semantic/lex-spp) -(require 'backquote) + (require 'semantic/bovine/c-by) + + (eval-when-compile - ;; For semantic-find-tags-* macros: + (require 'semantic/find)) + + (declare-function semantic-brute-find-tag-by-attribute "semantic/find") + (declare-function semanticdb-minor-mode-p "semantic/db-mode") + (declare-function semanticdb-needs-refresh-p "semantic/db") + (declare-function c-forward-conditional "cc-cmds") + (declare-function ede-system-include-path "ede") + + ;;; Compatibility + ;; + (eval-when-compile (require 'cc-mode)) + + (if (fboundp 'c-end-of-macro) + (eval-and-compile + (defalias 'semantic-c-end-of-macro 'c-end-of-macro)) + ;; From cc-mode 5.30 + (defun semantic-c-end-of-macro () + "Go to the end of a preprocessor directive. + More accurately, move point to the end of the closest following line + that doesn't end with a line continuation backslash. + + This function does not do any hidden buffer changes." + (while (progn + (end-of-line) + (when (and (eq (char-before) ?\\) + (not (eobp))) + (forward-char) + t)))) + ) + + ;;; Code: + (define-child-mode c++-mode c-mode + "`c++-mode' uses the same parser as `c-mode'.") + + + ;;; Include Paths + ;; + (defcustom-mode-local-semantic-dependency-system-include-path + c-mode semantic-c-dependency-system-include-path + '("/usr/include") + "The system include path used by the C langauge.") + + (defcustom semantic-default-c-path nil + "Default set of include paths for C code. + Used by `semantic-dep' to define an include path. + NOTE: In process of obsoleting this." + :group 'c + :group 'semantic + :type '(repeat (string :tag "Path"))) + + (defvar-mode-local c-mode semantic-dependency-include-path + semantic-default-c-path + "System path to search for include files.") + + ;;; Compile Options + ;; + ;; Compiler options need to show up after path setup, but before + ;; the preprocessor section. + + (when (member system-type '(gnu gnu/linux darwin cygwin)) + (semantic-gcc-setup)) + + ;;; Pre-processor maps + ;; + ;;; Lexical analysis + (defvar semantic-lex-c-preprocessor-symbol-map-builtin + '( ("__THROW" . "") + ("__const" . "const") + ("__restrict" . "") + ("__declspec" . ((spp-arg-list ("foo") 1 . 2))) + ("__attribute__" . ((spp-arg-list ("foo") 1 . 2))) + ) + "List of symbols to include by default.") + + (defvar semantic-c-in-reset-preprocessor-table nil + "Non-nil while resetting the preprocessor symbol map. + Used to prevent a reset while trying to parse files that are + part of the preprocessor map.") + + (defvar semantic-lex-c-preprocessor-symbol-file) + (defvar semantic-lex-c-preprocessor-symbol-map) + + (defun semantic-c-reset-preprocessor-symbol-map () + "Reset the C preprocessor symbol map based on all input variables." + (when (featurep 'semantic/bovine/c) + (let ((filemap nil) + ) + (when (and (not semantic-c-in-reset-preprocessor-table) + (featurep 'semantic/db-mode) + (semanticdb-minor-mode-p)) + (let ( ;; Don't use external parsers. We need the internal one. + (semanticdb-out-of-buffer-create-table-fcn nil) + ;; Don't recurse while parsing these files the first time. + (semantic-c-in-reset-preprocessor-table t) + ) + (dolist (sf semantic-lex-c-preprocessor-symbol-file) + ;; Global map entries + (let* ((table (semanticdb-file-table-object sf t))) + (when table + (when (semanticdb-needs-refresh-p table) + (condition-case nil + ;; Call with FORCE, as the file is very likely to + ;; not be in a buffer. + (semanticdb-refresh-table table t) + (error (message "Error updating tables for %S" + (object-name table))))) + (setq filemap (append filemap (oref table lexical-table))) + ) + )))) + + (setq-mode-local c-mode + semantic-lex-spp-macro-symbol-obarray + (semantic-lex-make-spp-table + (append semantic-lex-c-preprocessor-symbol-map-builtin + semantic-lex-c-preprocessor-symbol-map + filemap)) + ) + ))) + + (defcustom semantic-lex-c-preprocessor-symbol-map nil + "Table of C Preprocessor keywords used by the Semantic C lexer. + Each entry is a cons cell like this: + ( \"KEYWORD\" . \"REPLACEMENT\" ) + Where KEYWORD is the macro that gets replaced in the lexical phase, + and REPLACEMENT is a string that is inserted in it's place. Empty string + implies that the lexical analyzer will discard KEYWORD when it is encountered. + + Alternately, it can be of the form: + ( \"KEYWORD\" ( LEXSYM1 \"str\" 1 1 ) ... ( LEXSYMN \"str\" 1 1 ) ) + where LEXSYM is a symbol that would normally be produced by the + lexical analyzer, such as `symbol' or `string'. The string in the + second position is the text that makes up the replacement. This is + the way to have multiple lexical symbols in a replacement. Using the + first way to specify text like \"foo::bar\" would not work, because : + is a sepearate lexical symbol. + + A quick way to see what you would need to insert is to place a + definition such as: + + #define MYSYM foo::bar + + into a C file, and do this: + \\[semantic-lex-spp-describe] + + The output table will describe the symbols needed." + :group 'c + :type '(repeat (cons (string :tag "Keyword") + (sexp :tag "Replacement"))) + :set (lambda (sym value) + (set-default sym value) + (condition-case nil + (semantic-c-reset-preprocessor-symbol-map) + (error nil)) + ) + ) + + (defcustom semantic-lex-c-preprocessor-symbol-file nil + "List of C/C++ files that contain preprocessor macros for the C lexer. + Each entry is a filename and each file is parsed, and those macros + are included in every C/C++ file parsed by semantic. + You can use this variable instead of `semantic-lex-c-preprocessor-symbol-map' + to store your global macros in a more natural way." + :group 'c + :type '(repeat (file :tag "File")) + :set (lambda (sym value) + (set-default sym value) + (condition-case nil + (semantic-c-reset-preprocessor-symbol-map) + (error nil)) + ) + ) + + (defcustom semantic-c-member-of-autocast 't + "Non-nil means classes with a '->' operator will cast to it's return type. + + For Examples: + + class Foo { + Bar *operator->(); + } + + Foo foo; + + if `semantic-c-member-of-autocast' is non-nil : + foo->[here completion will list method of Bar] + + if `semantic-c-member-of-autocast' is nil : + foo->[here completion will list method of Foo]" + :group 'c + :type 'boolean) + + (define-lex-spp-macro-declaration-analyzer semantic-lex-cpp-define + "A #define of a symbol with some value. + Record the symbol in the semantic preprocessor. + Return the the defined symbol as a special spp lex token." + "^\\s-*#\\s-*define\\s-+\\(\\(\\sw\\|\\s_\\)+\\)" 1 + (goto-char (match-end 0)) + (skip-chars-forward " \t") + (if (eolp) + nil + (let* ((name (buffer-substring-no-properties + (match-beginning 1) (match-end 1))) + (with-args (save-excursion + (goto-char (match-end 0)) + (looking-at "("))) + (semantic-lex-spp-replacements-enabled nil) + ;; Temporarilly override the lexer to include + ;; special items needed inside a macro + (semantic-lex-analyzer #'semantic-cpp-lexer) + (raw-stream + (semantic-lex-spp-stream-for-macro (save-excursion + (semantic-c-end-of-macro) + (point)))) + ) + + ;; Only do argument checking if the paren was immediatly after + ;; the macro name. + (if with-args + (semantic-lex-spp-first-token-arg-list (car raw-stream))) + + ;; Magical spp variable for end point. + (setq semantic-lex-end-point (point)) + + ;; Handled nested macro streams. + (semantic-lex-spp-merge-streams raw-stream) + ))) + + (define-lex-spp-macro-undeclaration-analyzer semantic-lex-cpp-undef + "A #undef of a symbol. + Remove the symbol from the semantic preprocessor. + Return the the defined symbol as a special spp lex token." + "^\\s-*#\\s-*undef\\s-+\\(\\(\\sw\\|\\s_\\)+\\)" 1) + + + ;;; Conditional Skipping + ;; + (defcustom semantic-c-obey-conditional-section-parsing-flag t + "*Non-nil means to interpret preprocessor #if sections. + This implies that some blocks of code will not be parsed based on the + values of the conditions in the #if blocks." + :group 'c + :type 'boolean) + + (defun semantic-c-skip-conditional-section () + "Skip one section of a conditional. + Moves forward to a matching #elif, #else, or #endif. + Moves completely over balanced #if blocks." + (require 'cc-cmds) + (let ((done nil)) + ;; (if (looking-at "^\\s-*#if") + ;; (semantic-lex-spp-push-if (point)) + (end-of-line) + (while (and semantic-c-obey-conditional-section-parsing-flag + (and (not done) + (re-search-forward + "^\\s-*#\\s-*\\(if\\(n?def\\)?\\|el\\(if\\|se\\)\\|endif\\)\\>" + nil t))) + (goto-char (match-beginning 0)) + (cond + ((looking-at "^\\s-*#\\s-*if") + ;; We found a nested if. Skip it. + (c-forward-conditional 1)) + ((looking-at "^\\s-*#\\s-*elif") + ;; We need to let the preprocessor analize this one. + (beginning-of-line) + (setq done t) + ) + ((looking-at "^\\s-*#\\s-*\\(endif\\|else\\)\\>") + ;; We are at the end. Pop our state. + ;; (semantic-lex-spp-pop-if) + ;; Note: We include ELSE and ENDIF the same. If skip some previous + ;; section, then we should do the else by default, making it much + ;; like the endif. + (end-of-line) + (forward-char 1) + (setq done t)) + (t + ;; We found an elif. Stop here. + (setq done t)))))) + + (define-lex-regex-analyzer semantic-lex-c-if + "Code blocks wrapped up in #if, or #ifdef. + Uses known macro tables in SPP to determine what block to skip." + "^\\s-*#\\s-*\\(if\\|ifndef\\|ifdef\\|elif\\)\\s-+\\(!?defined(\\|\\)\\s-*\\(\\(\\sw\\|\\s_\\)+\\)\\(\\s-*)\\)?\\s-*$" + (semantic-c-do-lex-if)) + + (defun semantic-c-do-lex-if () + "Handle lexical CPP if statements." + (let* ((sym (buffer-substring-no-properties + (match-beginning 3) (match-end 3))) + (defstr (buffer-substring-no-properties + (match-beginning 2) (match-end 2))) + (defined (string= defstr "defined(")) + (notdefined (string= defstr "!defined(")) + (ift (buffer-substring-no-properties + (match-beginning 1) (match-end 1))) + (ifdef (or (string= ift "ifdef") + (and (string= ift "if") defined) + (and (string= ift "elif") defined) + )) + (ifndef (or (string= ift "ifndef") + (and (string= ift "if") notdefined) + (and (string= ift "elif") notdefined) + )) + ) + (if (or (and (or (string= ift "if") (string= ift "elif")) + (string= sym "0")) + (and ifdef (not (semantic-lex-spp-symbol-p sym))) + (and ifndef (semantic-lex-spp-symbol-p sym))) + ;; The if indecates to skip this preprocessor section + (let ((pt nil)) + ;; (message "%s %s yes" ift sym) + (beginning-of-line) + (setq pt (point)) + ;;(c-forward-conditional 1) + ;; This skips only a section of a conditional. Once that section + ;; is opened, encountering any new #else or related conditional + ;; should be skipped. + (semantic-c-skip-conditional-section) + (setq semantic-lex-end-point (point)) + (semantic-push-parser-warning (format "Skip #%s %s" ift sym) + pt (point)) + ;; (semantic-lex-push-token + ;; (semantic-lex-token 'c-preprocessor-skip pt (point))) + nil) + ;; Else, don't ignore it, but do handle the internals. + ;;(message "%s %s no" ift sym) + (end-of-line) + (setq semantic-lex-end-point (point)) + nil))) + + (define-lex-regex-analyzer semantic-lex-c-macro-else + "Ignore an #else block. + We won't see the #else due to the macro skip section block + unless we are actively parsing an open #if statement. In that + case, we must skip it since it is the ELSE part." + "^\\s-*#\\s-*\\(else\\)" + (let ((pt (point))) + (semantic-c-skip-conditional-section) + (setq semantic-lex-end-point (point)) + (semantic-push-parser-warning "Skip #else" pt (point)) + ;; (semantic-lex-push-token + ;; (semantic-lex-token 'c-preprocessor-skip pt (point))) + nil)) + + (define-lex-regex-analyzer semantic-lex-c-macrobits + "Ignore various forms of #if/#else/#endif conditionals." + "^\\s-*#\\s-*\\(if\\(n?def\\)?\\|endif\\|elif\\|else\\)" + (semantic-c-end-of-macro) + (setq semantic-lex-end-point (point)) + nil) + + (define-lex-spp-include-analyzer semantic-lex-c-include-system + "Identify include strings, and return special tokens." + "^\\s-*#\\s-*include\\s-*<\\([^ \t\n>]+\\)>" 0 + ;; Hit 1 is the name of the include. + (goto-char (match-end 0)) + (setq semantic-lex-end-point (point)) + (cons (buffer-substring-no-properties (match-beginning 1) + (match-end 1)) + 'system)) + + (define-lex-spp-include-analyzer semantic-lex-c-include + "Identify include strings, and return special tokens." + "^\\s-*#\\s-*include\\s-*\"\\([^ \t\n>]+\\)\"" 0 + ;; Hit 1 is the name of the include. + (goto-char (match-end 0)) + (setq semantic-lex-end-point (point)) + (cons (buffer-substring-no-properties (match-beginning 1) + (match-end 1)) + nil)) + + + (define-lex-regex-analyzer semantic-lex-c-ignore-ending-backslash + "Skip backslash ending a line. + Go to the next line." + "\\\\\\s-*\n" + (setq semantic-lex-end-point (match-end 0))) + + (define-lex-regex-analyzer semantic-lex-c-namespace-begin-macro + "Handle G++'s namespace macros which the pre-processor can't handle." + "\\(_GLIBCXX_BEGIN_NAMESPACE\\)(\\s-*\\(\\(?:\\w\\|\\s_\\)+\\)\\s-*)" + (let* ((nsend (match-end 1)) + (sym-start (match-beginning 2)) + (sym-end (match-end 2)) + (ms (buffer-substring-no-properties sym-start sym-end))) + ;; Push the namespace keyword. + (semantic-lex-push-token + (semantic-lex-token 'NAMESPACE (match-beginning 0) nsend "namespace")) + ;; Push the name. + (semantic-lex-push-token + (semantic-lex-token 'symbol sym-start sym-end ms)) + ) + (goto-char (match-end 0)) + (let ((start (point)) + (end 0)) + ;; If we can't find a matching end, then create the fake list. + (when (re-search-forward "_GLIBCXX_END_NAMESPACE" nil t) + (setq end (point)) + (semantic-lex-push-token + (semantic-lex-token 'semantic-list start end + (list 'prefix-fake))))) + (setq semantic-lex-end-point (point))) + + (defcustom semantic-lex-c-nested-namespace-ignore-second t + "Should _GLIBCXX_BEGIN_NESTED_NAMESPACE ignore the second namespace? + It is really there, but if a majority of uses is to squeeze out + the second namespace in use, then it should not be included. + + If you are having problems with smart completion and STL templates, + it may that this is set incorrectly. After changing the value + of this flag, you will need to delete any semanticdb cache files + that may have been incorrectly parsed." + :group 'semantic + :type 'boolean) + + (define-lex-regex-analyzer semantic-lex-c-VC++-begin-std-namespace + "Handle VC++'s definition of the std namespace." + "\\(_STD_BEGIN\\)" + (semantic-lex-push-token + (semantic-lex-token 'NAMESPACE (match-beginning 0) (match-end 0) "namespace")) + (semantic-lex-push-token + (semantic-lex-token 'symbol (match-beginning 0) (match-end 0) "std")) + (goto-char (match-end 0)) + (let ((start (point)) + (end 0)) + (when (re-search-forward "_STD_END" nil t) + (setq end (point)) + (semantic-lex-push-token + (semantic-lex-token 'semantic-list start end + (list 'prefix-fake))))) + (setq semantic-lex-end-point (point))) + + (define-lex-regex-analyzer semantic-lex-c-VC++-end-std-namespace + "Handle VC++'s definition of the std namespace." + "\\(_STD_END\\)" + (goto-char (match-end 0)) + (setq semantic-lex-end-point (point))) + + (define-lex-regex-analyzer semantic-lex-c-namespace-begin-nested-macro + "Handle G++'s namespace macros which the pre-processor can't handle." + "\\(_GLIBCXX_BEGIN_NESTED_NAMESPACE\\)(\\s-*\\(\\(?:\\w\\|\\s_\\)+\\)\\s-*,\\s-*\\(\\(?:\\w\\|\\s_\\)+\\)\\s-*)" + (goto-char (match-end 0)) + (let* ((nsend (match-end 1)) + (sym-start (match-beginning 2)) + (sym-end (match-end 2)) + (ms (buffer-substring-no-properties sym-start sym-end)) + (sym2-start (match-beginning 3)) + (sym2-end (match-end 3)) + (ms2 (buffer-substring-no-properties sym2-start sym2-end))) + ;; Push the namespace keyword. + (semantic-lex-push-token + (semantic-lex-token 'NAMESPACE (match-beginning 0) nsend "namespace")) + ;; Push the name. + (semantic-lex-push-token + (semantic-lex-token 'symbol sym-start sym-end ms)) + + (goto-char (match-end 0)) + (let ((start (point)) + (end 0)) + ;; If we can't find a matching end, then create the fake list. + (when (re-search-forward "_GLIBCXX_END_NESTED_NAMESPACE" nil t) + (setq end (point)) + (if semantic-lex-c-nested-namespace-ignore-second + ;; The same as _GLIBCXX_BEGIN_NAMESPACE + (semantic-lex-push-token + (semantic-lex-token 'semantic-list start end + (list 'prefix-fake))) + ;; Do both the top and second level namespace + (semantic-lex-push-token + (semantic-lex-token 'semantic-list start end + ;; We'll depend on a quick hack + (list 'prefix-fake-plus + (semantic-lex-token 'NAMESPACE + sym-end sym2-start + "namespace") + (semantic-lex-token 'symbol + sym2-start sym2-end + ms2) + (semantic-lex-token 'semantic-list start end + (list 'prefix-fake))) + ))) + ))) + (setq semantic-lex-end-point (point))) + + (define-lex-regex-analyzer semantic-lex-c-namespace-end-macro + "Handle G++'s namespace macros which the pre-processor can't handle." + "_GLIBCXX_END_\\(NESTED_\\)?NAMESPACE" + (goto-char (match-end 0)) + (setq semantic-lex-end-point (point))) + + (define-lex-regex-analyzer semantic-lex-c-string + "Detect and create a C string token." + "L?\\(\\s\"\\)" + ;; Zing to the end of this string. + (semantic-lex-push-token + (semantic-lex-token + 'string (point) + (save-excursion + ;; Skip L prefix if present. + (goto-char (match-beginning 1)) + (semantic-lex-unterminated-syntax-protection 'string + (forward-sexp 1) + (point)) + )))) + + (define-lex-regex-analyzer semantic-c-lex-ignore-newline + "Detect and ignore newline tokens. + Use this ONLY if newlines are not whitespace characters (such as when + they are comment end characters)." + ;; Just like semantic-lex-ignore-newline, but also ignores + ;; trailing \. + "\\s-*\\\\?\\s-*\\(\n\\|\\s>\\)" + (setq semantic-lex-end-point (match-end 0))) + + + (define-lex semantic-c-lexer + "Lexical Analyzer for C code. + Use semantic-cpp-lexer for parsing text inside a CPP macro." + ;; C preprocessor features + semantic-lex-cpp-define + semantic-lex-cpp-undef + semantic-lex-c-if + semantic-lex-c-macro-else + semantic-lex-c-macrobits + semantic-lex-c-include + semantic-lex-c-include-system + semantic-lex-c-ignore-ending-backslash + ;; Whitespace handling + semantic-lex-ignore-whitespace + semantic-c-lex-ignore-newline + ;; Non-preprocessor features + semantic-lex-number + ;; Must detect C strings before symbols because of possible L prefix! + semantic-lex-c-string + ;; Custom handlers for some macros come before the macro replacement analyzer. + semantic-lex-c-namespace-begin-macro + semantic-lex-c-namespace-begin-nested-macro + semantic-lex-c-namespace-end-macro + semantic-lex-c-VC++-begin-std-namespace + semantic-lex-c-VC++-end-std-namespace + ;; Handle macros, symbols, and keywords + semantic-lex-spp-replace-or-symbol-or-keyword + semantic-lex-charquote + semantic-lex-paren-or-list + semantic-lex-close-paren + semantic-lex-ignore-comments + semantic-lex-punctuation + semantic-lex-default-action) + + (define-lex-simple-regex-analyzer semantic-lex-cpp-hashhash + "Match ## inside a CPP macro as special." + "##" 'spp-concat) + + (define-lex semantic-cpp-lexer + "Lexical Analyzer for CPP macros in C code." + ;; CPP special + semantic-lex-cpp-hashhash + ;; C preprocessor features + semantic-lex-cpp-define + semantic-lex-cpp-undef + semantic-lex-c-if + semantic-lex-c-macro-else + semantic-lex-c-macrobits + semantic-lex-c-include + semantic-lex-c-include-system + semantic-lex-c-ignore-ending-backslash + ;; Whitespace handling + semantic-lex-ignore-whitespace + semantic-c-lex-ignore-newline + ;; Non-preprocessor features + semantic-lex-number + ;; Must detect C strings before symbols because of possible L prefix! + semantic-lex-c-string + ;; Parsing inside a macro means that we don't do macro replacement. + ;; semantic-lex-spp-replace-or-symbol-or-keyword + semantic-lex-symbol-or-keyword + semantic-lex-charquote + semantic-lex-paren-or-list + semantic-lex-close-paren + semantic-lex-ignore-comments + semantic-lex-punctuation + semantic-lex-default-action) + + (define-mode-local-override semantic-parse-region c-mode + (start end &optional nonterminal depth returnonerror) + "Calls 'semantic-parse-region-default', except in a macro expansion. + MACRO expansion mode is handled through the nature of Emacs's non-lexical + binding of variables. + START, END, NONTERMINAL, DEPTH, and RETURNONERRORS are the same + as for the parent." + (if (and (boundp 'lse) (or (/= start 1) (/= end (point-max)))) + (let* ((last-lexical-token lse) + (llt-class (semantic-lex-token-class last-lexical-token)) + (llt-fakebits (car (cdr last-lexical-token))) + (macroexpand (stringp (car (cdr last-lexical-token))))) + (if macroexpand + (progn + ;; It is a macro expansion. Do something special. + ;;(message "MOOSE %S %S, %S : %S" start end nonterminal lse) + (semantic-c-parse-lexical-token + lse nonterminal depth returnonerror) + ) + ;; Not a macro expansion, but perhaps a funny semantic-list + ;; is at the start? Remove the depth if our semantic list is not + ;; made of list tokens. + (if (and depth (= depth 1) + (eq llt-class 'semantic-list) + (not (null llt-fakebits)) + (consp llt-fakebits) + (symbolp (car llt-fakebits)) + ) + (progn + (setq depth 0) + + ;; This is a copy of semantic-parse-region-default where we + ;; are doing something special with the lexication of the + ;; contents of the semantic-list token. Stuff not used by C + ;; removed. + (let ((tokstream + (if (and (consp llt-fakebits) + (eq (car llt-fakebits) 'prefix-fake-plus)) + ;; If our semantic-list is special, then only stick in the + ;; fake tokens. + (cdr llt-fakebits) + ;; Lex up the region with a depth of 0 + (semantic-lex start end 0)))) + + ;; Do the parse + (nreverse + (semantic-repeat-parse-whole-stream tokstream + nonterminal + returnonerror)) + + )) + + ;; It was not a macro expansion, nor a special semantic-list. + ;; Do old thing. + (semantic-parse-region-default start end + nonterminal depth + returnonerror) + ))) + ;; Do the parse + (semantic-parse-region-default start end nonterminal + depth returnonerror) + )) + + (defvar semantic-c-parse-token-hack-depth 0 + "Current depth of recursive calls to `semantic-c-parse-lexical-token'") + + (defun semantic-c-parse-lexical-token (lexicaltoken nonterminal depth + returnonerror) + "Do a region parse on the contents of LEXICALTOKEN. + Presumably, this token has a string in it from a macro. + The text of the token is inserted into a different buffer, and + parsed there. + Argument NONTERMINAL, DEPTH, and RETURNONERROR are passed into + the regular parser." + (let* ((semantic-c-parse-token-hack-depth (1+ semantic-c-parse-token-hack-depth)) + (buf (get-buffer-create (format " *C parse hack %d*" + semantic-c-parse-token-hack-depth))) + (mode major-mode) + (spp-syms semantic-lex-spp-dynamic-macro-symbol-obarray) + (stream nil) + (start (semantic-lex-token-start lexicaltoken)) + (end (semantic-lex-token-end lexicaltoken)) + (symtext (semantic-lex-token-text lexicaltoken)) + (macros (get-text-property 0 'macros symtext)) + ) + (save-excursion + (set-buffer buf) + (erase-buffer) + (when (not (eq major-mode mode)) + (save-match-data + + ;; Protect against user hooks throwing errors. + (condition-case nil + (funcall mode) + (error nil)) + + ;; Hack in mode-local + (activate-mode-local-bindings) + ;; CHEATER! The following 3 lines are from + ;; `semantic-new-buffer-fcn', but we don't want to turn + ;; on all the other annoying modes for this little task. + (setq semantic-new-buffer-fcn-was-run t) + (semantic-lex-init) + (semantic-clear-toplevel-cache) + (remove-hook 'semantic-lex-reset-hooks 'semantic-lex-spp-reset-hook + t) + )) + ;; Get the macro symbol table right. + (setq semantic-lex-spp-dynamic-macro-symbol-obarray spp-syms) + ;; (message "%S" macros) + (dolist (sym macros) + (semantic-lex-spp-symbol-set (car sym) (cdr sym))) + + (insert symtext) + + (setq stream + (semantic-parse-region-default + (point-min) (point-max) nonterminal depth returnonerror)) + + ;; Clean up macro symbols + (dolist (sym macros) + (semantic-lex-spp-symbol-remove (car sym))) + + ;; Convert the text of the stream. + (dolist (tag stream) + ;; Only do two levels here 'cause I'm lazy. + (semantic--tag-set-overlay tag (list start end)) + (dolist (stag (semantic-tag-components-with-overlays tag)) + (semantic--tag-set-overlay stag (list start end)) + )) + ) + stream)) + + (defun semantic-expand-c-tag (tag) + "Expand TAG into a list of equivalent tags, or nil." + (let ((return-list nil) + ) + ;; Expand an EXTERN C first. + (when (eq (semantic-tag-class tag) 'extern) + (let* ((mb (semantic-tag-get-attribute tag :members)) + (ret mb)) + (while mb + (let ((mods (semantic-tag-get-attribute (car mb) :typemodifiers))) + (setq mods (cons "extern" (cons "\"C\"" mods))) + (semantic-tag-put-attribute (car mb) :typemodifiers mods)) + (setq mb (cdr mb))) + (setq return-list ret))) + + ;; Function or variables that have a :type that is some complex + ;; thing, extract it, and replace it with a reference. + ;; + ;; Thus, struct A { int a; } B; + ;; + ;; will create 2 toplevel tags, one is type A, and the other variable B + ;; where the :type of B is just a type tag A that is a prototype, and + ;; the actual struct info of A is it's own toplevel tag. + (when (or (semantic-tag-of-class-p tag 'function) + (semantic-tag-of-class-p tag 'variable)) + (let* ((basetype (semantic-tag-type tag)) + (typeref nil) + (tname (when (consp basetype) + (semantic-tag-name basetype)))) + ;; Make tname be a string. + (when (consp tname) (setq tname (car (car tname)))) + ;; Is the basetype a full type with a name of its own? + (when (and basetype (semantic-tag-p basetype) + (not (semantic-tag-prototype-p basetype)) + tname + (not (string= tname ""))) + ;; a type tag referencing the type we are extracting. + (setq typeref (semantic-tag-new-type + (semantic-tag-name basetype) + (semantic-tag-type basetype) + nil nil + :prototype t)) + ;; Convert original tag to only have a reference. + (setq tag (semantic-tag-copy tag)) + (semantic-tag-put-attribute tag :type typeref) + ;; Convert basetype to have the location information. + (semantic--tag-copy-properties tag basetype) + (semantic--tag-set-overlay basetype + (semantic-tag-overlay tag)) + ;; Store the base tag as part of the return list. + (setq return-list (cons basetype return-list))))) + + ;; Name of the tag is a list, so expand it. Tag lists occur + ;; for variables like this: int var1, var2, var3; + ;; + ;; This will expand that to 3 tags that happen to share the + ;; same overlay information. + (if (consp (semantic-tag-name tag)) + (let ((rl (semantic-expand-c-tag-namelist tag))) + (cond + ;; If this returns nothing, then return nil overall + ;; because that will restore the old TAG input. + ((not rl) (setq return-list nil)) + ;; If we have a return, append it to the existing list + ;; of returns. + ((consp rl) + (setq return-list (append rl return-list))) + )) + ;; If we didn't have a list, but the return-list is non-empty, + ;; that means we still need to take our existing tag, and glom + ;; it onto our extracted type. + (if (consp return-list) + (setq return-list (cons tag return-list))) + ) + + ;; Default, don't change the tag means returning nil. + return-list)) + + (defun semantic-expand-c-tag-namelist (tag) + "Expand TAG whose name is a list into a list of tags, or nil." + (cond ((semantic-tag-of-class-p tag 'variable) + ;; The name part comes back in the form of: + ;; ( NAME NUMSTARS BITS ARRAY ASSIGN ) + (let ((vl nil) + (basety (semantic-tag-type tag)) + (ty "") + (mods (semantic-tag-get-attribute tag :typemodifiers)) + (suffix "") + (lst (semantic-tag-name tag)) + (default nil) + (cur nil)) + ;; Open up each name in the name list. + (while lst + (setq suffix "" ty "") + (setq cur (car lst)) + (if (nth 2 cur) + (setq suffix (concat ":" (nth 2 cur)))) + (if (= (length basety) 1) + (setq ty (car basety)) + (setq ty basety)) + (setq default (nth 4 cur)) + (setq vl (cons + (semantic-tag-new-variable + (car cur) ;name + ty ;type + (if default + (buffer-substring-no-properties + (car default) (car (cdr default)))) + :constant-flag (semantic-tag-variable-constant-p tag) + :suffix suffix + :typemodifiers mods + :dereference (length (nth 3 cur)) + :pointer (nth 1 cur) + :reference (semantic-tag-get-attribute tag :reference) + :documentation (semantic-tag-docstring tag) ;doc + ) + vl)) + (semantic--tag-copy-properties tag (car vl)) + (semantic--tag-set-overlay (car vl) + (semantic-tag-overlay tag)) + (setq lst (cdr lst))) + ;; Return the list + (nreverse vl))) + ((semantic-tag-of-class-p tag 'type) + ;; We may someday want to add an extra check for a type + ;; of type "typedef". + ;; Each elt of NAME is ( STARS NAME ) + (let ((vl nil) + (names (semantic-tag-name tag))) + (while names + (setq vl (cons (semantic-tag-new-type + (nth 1 (car names)) ; name + "typedef" + (semantic-tag-type-members tag) + ;; parent is just tbe name of what + ;; is passed down as a tag. + (list + (semantic-tag-name + (semantic-tag-type-superclasses tag))) + :pointer + (let ((stars (car (car (car names))))) + (if (= stars 0) nil stars)) + ;; This specifies what the typedef + ;; is expanded out as. Just the + ;; name shows up as a parent of this + ;; typedef. + :typedef + (semantic-tag-get-attribute tag :superclasses) + ;;(semantic-tag-type-superclasses tag) + :documentation + (semantic-tag-docstring tag)) + vl)) + (semantic--tag-copy-properties tag (car vl)) + (semantic--tag-set-overlay (car vl) + (semantic-tag-overlay tag)) + (setq names (cdr names))) + vl)) + ((and (listp (car tag)) + (semantic-tag-of-class-p (car tag) 'variable)) + ;; Argument lists come in this way. Append all the expansions! + (let ((vl nil)) + (while tag + (setq vl (append (semantic-tag-components (car vl)) + vl) + tag (cdr tag))) + vl)) + (t nil))) + + (defvar-mode-local c-mode semantic-tag-expand-function 'semantic-expand-c-tag + "Function used to expand tags generated in the C bovine parser.") + + (defvar semantic-c-classname nil + "At parse time, assign a class or struct name text here. + It is picked up by `semantic-c-reconstitute-token' to determine + if something is a constructor. Value should be: + ( TYPENAME . TYPEOFTYPE) + where typename is the name of the type, and typeoftype is \"class\" + or \"struct\".") + + (defun semantic-c-reconstitute-token (tokenpart declmods typedecl) + "Reconstitute a token TOKENPART with DECLMODS and TYPEDECL. + This is so we don't have to match the same starting text several times. + Optional argument STAR and REF indicate the number of * and & in the typedef." + (when (and (listp typedecl) + (= 1 (length typedecl)) + (stringp (car typedecl))) + (setq typedecl (car typedecl))) + (cond ((eq (nth 1 tokenpart) 'variable) + (semantic-tag-new-variable + (car tokenpart) + (or typedecl "int") ;type + nil ;default value (filled with expand) + :constant-flag (if (member "const" declmods) t nil) + :typemodifiers (delete "const" declmods) + ) + ) + ((eq (nth 1 tokenpart) 'function) + ;; We should look at part 4 (the arglist) here, and throw an + ;; error of some sort if it contains parser errors so that we + ;; don't parser function calls, but that is a little beyond what + ;; is available for data here. + (let* ((constructor + (and (or (and semantic-c-classname + (string= (car semantic-c-classname) + (car tokenpart))) + (and (stringp (car (nth 2 tokenpart))) + (string= (car (nth 2 tokenpart)) (car tokenpart))) + ) + (not (car (nth 3 tokenpart))))) + (fcnpointer (string-match "^\\*" (car tokenpart))) + (fnname (if fcnpointer + (substring (car tokenpart) 1) + (car tokenpart))) + (operator (if (string-match "[a-zA-Z]" fnname) + nil + t)) + ) + (if fcnpointer + ;; Function pointers are really variables. + (semantic-tag-new-variable + fnname + typedecl + nil + ;; It is a function pointer + :functionpointer-flag t + ) + ;; The function + (semantic-tag-new-function + fnname + (or typedecl ;type + (cond ((car (nth 3 tokenpart) ) + "void") ; Destructors have no return? + (constructor + ;; Constructors return an object. + (semantic-tag-new-type + ;; name + (or (car semantic-c-classname) + (car (nth 2 tokenpart))) + ;; type + (or (cdr semantic-c-classname) + "class") + ;; members + nil + ;; parents + nil + )) + (t "int"))) + (nth 4 tokenpart) ;arglist + :constant-flag (if (member "const" declmods) t nil) + :typemodifiers (delete "const" declmods) + :parent (car (nth 2 tokenpart)) + :destructor-flag (if (car (nth 3 tokenpart) ) t) + :constructor-flag (if constructor t) + :pointer (nth 7 tokenpart) + :operator-flag operator + ;; Even though it is "throw" in C++, we use + ;; `throws' as a common name for things that toss + ;; exceptions about. + :throws (nth 5 tokenpart) + ;; Reemtrant is a C++ thingy. Add it here + :reentrant-flag (if (member "reentrant" (nth 6 tokenpart)) t) + ;; A function post-const is funky. Try stuff + :methodconst-flag (if (member "const" (nth 6 tokenpart)) t) + ;; prototypes are functions w/ no body + :prototype-flag (if (nth 8 tokenpart) t) + ;; Pure virtual + :pure-virtual-flag (if (eq (nth 8 tokenpart) :pure-virtual-flag) t) + ;; Template specifier. + :template-specifier (nth 9 tokenpart) + ))) + ) + )) + + (defun semantic-c-reconstitute-template (tag specifier) + "Reconstitute the token TAG with the template SPECIFIER." + (semantic-tag-put-attribute tag :template (or specifier "")) + tag) + + + ;;; Override methods & Variables + ;; + (define-mode-local-override semantic-format-tag-name + c-mode (tag &optional parent color) + "Convert TAG to a string that is the print name for TAG. + Optional PARENT and COLOR are ignored." + (let ((name (semantic-format-tag-name-default tag parent color)) + (fnptr (semantic-tag-get-attribute tag :functionpointer-flag)) + ) + (if (not fnptr) + name + (concat "(*" name ")")) + )) + + (define-mode-local-override semantic-format-tag-canonical-name + c-mode (tag &optional parent color) + "Create a cannonical name for TAG. + PARENT specifies a parent class. + COLOR indicates that the text should be type colorized. + Enhances the base class to search for the entire parent + tree to make the name accurate." + (semantic-format-tag-canonical-name-default tag parent color) + ) + + (define-mode-local-override semantic-format-tag-type c-mode (tag color) + "Convert the data type of TAG to a string usable in tag formatting. + Adds pointer and reference symbols to the default. + Argument COLOR adds color to the text." + (let* ((type (semantic-tag-type tag)) + (defaulttype nil) + (point (semantic-tag-get-attribute tag :pointer)) + (ref (semantic-tag-get-attribute tag :reference)) + ) + (if (semantic-tag-p type) + (let ((typetype (semantic-tag-type type)) + (typename (semantic-tag-name type))) + ;; Create the string that expresses the type + (if (string= typetype "class") + (setq defaulttype typename) + (setq defaulttype (concat typetype " " typename)))) + (setq defaulttype (semantic-format-tag-type-default tag color))) + + ;; Colorize + (when color + (setq defaulttype (semantic--format-colorize-text defaulttype 'type))) + + ;; Add refs, ptrs, etc + (if ref (setq ref "&")) + (if point (setq point (make-string point ?*)) "") + (when type + (concat defaulttype ref point)) + )) + + (define-mode-local-override semantic-find-tags-by-scope-protection + c-mode (scopeprotection parent &optional table) + "Override the usual search for protection. + We can be more effective than the default by scanning through once, + and collecting tags based on the labels we see along the way." + (if (not table) (setq table (semantic-tag-type-members parent))) + (if (null scopeprotection) + table + (let ((ans nil) + (curprot 1) + (targetprot (cond ((eq scopeprotection 'public) + 1) + ((eq scopeprotection 'protected) + 2) + (t 3) + )) + (alist '(("public" . 1) + ("protected" . 2) + ("private" . 3))) + ) + (dolist (tag table) + (cond + ((semantic-tag-of-class-p tag 'label) + (setq curprot (cdr (assoc (semantic-tag-name tag) alist))) + ) + ((>= targetprot curprot) + (setq ans (cons tag ans))) + )) + ans))) + + (define-mode-local-override semantic-tag-protection + c-mode (tag &optional parent) + "Return the protection of TAG in PARENT. + Override function for `semantic-tag-protection'." + (let ((mods (semantic-tag-modifiers tag)) + (prot nil)) + ;; Check the modifiers for protection if we are not a child + ;; of some class type. + (when (or (not parent) (not (eq (semantic-tag-class parent) 'type))) + (while (and (not prot) mods) + (if (stringp (car mods)) + (let ((s (car mods))) + ;; A few silly defaults to get things started. + (cond ((or (string= s "extern") + (string= s "export")) + 'public) + ((string= s "static") + 'private)))) + (setq mods (cdr mods)))) + ;; If we have a typed parent, look for :public style labels. + (when (and parent (eq (semantic-tag-class parent) 'type)) + (let ((pp (semantic-tag-type-members parent))) + (while (and pp (not (semantic-equivalent-tag-p (car pp) tag))) + (when (eq (semantic-tag-class (car pp)) 'label) + (setq prot + (cond ((string= (semantic-tag-name (car pp)) "public") + 'public) + ((string= (semantic-tag-name (car pp)) "private") + 'private) + ((string= (semantic-tag-name (car pp)) "protected") + 'protected))) + ) + (setq pp (cdr pp))))) + (when (and (not prot) (eq (semantic-tag-class parent) 'type)) + (setq prot + (cond ((string= (semantic-tag-type parent) "class") 'private) + ((string= (semantic-tag-type parent) "struct") 'public) + (t 'unknown)))) + (or prot + (if (and parent (semantic-tag-of-class-p parent 'type)) + 'public + nil)))) + + (define-mode-local-override semantic-tag-components c-mode (tag) + "Return components for TAG." + (if (and (eq (semantic-tag-class tag) 'type) + (string= (semantic-tag-type tag) "typedef")) + ;; A typedef can contain a parent who has positional children, + ;; but that parent will not have a position. Do this funny hack + ;; to make sure we can apply overlays properly. + (let ((sc (semantic-tag-get-attribute tag :typedef))) + (when (semantic-tag-p sc) (semantic-tag-components sc))) + (semantic-tag-components-default tag))) + + (defun semantic-c-tag-template (tag) + "Return the template specification for TAG, or nil." + (semantic-tag-get-attribute tag :template)) + + (defun semantic-c-tag-template-specifier (tag) + "Return the template specifier specification for TAG, or nil." + (semantic-tag-get-attribute tag :template-specifier)) + + (defun semantic-c-template-string-body (templatespec) + "Convert TEMPLATESPEC into a string. + This might be a string, or a list of tokens." + (cond ((stringp templatespec) + templatespec) + ((semantic-tag-p templatespec) + (semantic-format-tag-abbreviate templatespec)) + ((listp templatespec) + (mapconcat 'semantic-format-tag-abbreviate templatespec ", ")))) + + (defun semantic-c-template-string (token &optional parent color) + "Return a string representing the TEMPLATE attribute of TOKEN. + This string is prefixed with a space, or is the empty string. + Argument PARENT specifies a parent type. + Argument COLOR specifies that the string should be colorized." + (let ((t2 (semantic-c-tag-template-specifier token)) + (t1 (semantic-c-tag-template token)) + ;; @todo - Need to account for a parent that is a template + (pt1 (if parent (semantic-c-tag-template parent))) + (pt2 (if parent (semantic-c-tag-template-specifier parent))) + ) + (cond (t2 ;; we have a template with specifier + (concat " <" + ;; Fill in the parts here + (semantic-c-template-string-body t2) + ">")) + (t1 ;; we have a template without specifier + " <>") + (t + "")))) + + (define-mode-local-override semantic-format-tag-concise-prototype + c-mode (token &optional parent color) + "Return an abbreviated string describing TOKEN for C and C++. + Optional PARENT and COLOR as specified with + `semantic-format-tag-abbreviate-default'." + ;; If we have special template things, append. + (concat (semantic-format-tag-concise-prototype-default token parent color) + (semantic-c-template-string token parent color))) + + (define-mode-local-override semantic-format-tag-uml-prototype + c-mode (token &optional parent color) + "Return an uml string describing TOKEN for C and C++. + Optional PARENT and COLOR as specified with + `semantic-abbreviate-tag-default'." + ;; If we have special template things, append. + (concat (semantic-format-tag-uml-prototype-default token parent color) + (semantic-c-template-string token parent color))) + + (define-mode-local-override semantic-tag-abstract-p + c-mode (tag &optional parent) + "Return non-nil if TAG is considered abstract. + PARENT is tag's parent. + In C, a method is abstract if it is `virtual', which is already + handled. A class is abstract iff it's destructor is virtual." + (cond + ((eq (semantic-tag-class tag) 'type) + (require 'semantic/find) + (or (semantic-brute-find-tag-by-attribute :pure-virtual-flag + (semantic-tag-components tag) + ) + (let* ((ds (semantic-brute-find-tag-by-attribute + :destructor-flag + (semantic-tag-components tag) + )) + (cs (semantic-brute-find-tag-by-attribute + :constructor-flag + (semantic-tag-components tag) + ))) + (and ds (member "virtual" (semantic-tag-modifiers (car ds))) + cs (eq 'protected (semantic-tag-protection (car cs) tag)) + ) + ))) + ((eq (semantic-tag-class tag) 'function) + (or (semantic-tag-get-attribute tag :pure-virtual-flag) + (member "virtual" (semantic-tag-modifiers tag)))) + (t (semantic-tag-abstract-p-default tag parent)))) + + (defun semantic-c-dereference-typedef (type scope &optional type-declaration) + "If TYPE is a typedef, get TYPE's type by name or tag, and return. + SCOPE is not used, and TYPE-DECLARATION is used only if TYPE is not a typedef." + (if (and (eq (semantic-tag-class type) 'type) + (string= (semantic-tag-type type) "typedef")) + (let ((dt (semantic-tag-get-attribute type :typedef))) + (cond ((and (semantic-tag-p dt) + (not (semantic-analyze-tag-prototype-p dt))) + ;; In this case, DT was declared directly. We need + ;; to clone DT and apply a filename to it. + (let* ((fname (semantic-tag-file-name type)) + (def (semantic-tag-copy dt nil fname))) + (list def def))) + ((stringp dt) (list dt (semantic-tag dt 'type))) + ((consp dt) (list (car dt) dt)))) + + (list type type-declaration))) + + (defun semantic-c--instantiate-template (tag def-list spec-list) + "Replace TAG name according to template specification. + DEF-LIST is the template information. + SPEC-LIST is the template specifier of the datatype instantiated." + (when (and (car def-list) (car spec-list)) + + (when (and (string= (semantic-tag-type (car def-list)) "class") + (string= (semantic-tag-name tag) (semantic-tag-name (car def-list)))) + (semantic-tag-set-name tag (semantic-tag-name (car spec-list)))) + + (semantic-c--instantiate-template tag (cdr def-list) (cdr spec-list)))) + + (defun semantic-c--template-name-1 (spec-list) + "return a string used to compute template class name based on SPEC-LIST + for ref it will return 'Foo,Bar'." + (when (car spec-list) + (let* ((endpart (semantic-c--template-name-1 (cdr spec-list))) + (separator (and endpart ","))) + (concat (semantic-tag-name (car spec-list)) separator endpart)))) + + (defun semantic-c--template-name (type spec-list) + "Return a template class name for TYPE based on SPEC-LIST. + For a type `ref' with a template specifier of (Foo Bar) it will + return 'ref'." + (concat (semantic-tag-name type) + "<" (semantic-c--template-name-1 (cdr spec-list)) ">")) + + (defun semantic-c-dereference-template (type scope &optional type-declaration) + "Dereference any template specifieres in TYPE within SCOPE. + If TYPE is a template, return a TYPE copy with the templates types + instantiated as specified in TYPE-DECLARATION." + (when (semantic-tag-p type-declaration) + (let ((def-list (semantic-tag-get-attribute type :template)) + (spec-list (semantic-tag-get-attribute type-declaration :template-specifier))) + (when (and def-list spec-list) + (setq type (semantic-tag-deep-copy-one-tag + type + (lambda (tag) + (when (semantic-tag-of-class-p tag 'type) + (semantic-c--instantiate-template + tag def-list spec-list)) + tag) + )) + (semantic-tag-set-name type (semantic-c--template-name type spec-list)) + (semantic-tag-put-attribute type :template nil) + (semantic-tag-set-faux type)))) + (list type type-declaration)) + + ;;; Patch here by "Raf" for instantiating templates. + (defun semantic-c-dereference-member-of (type scope &optional type-declaration) + "Dereference through the `->' operator of TYPE. + Uses the return type of the '->' operator if it is contained in TYPE. + SCOPE is the current local scope to perform searches in. + TYPE-DECLARATION is passed through." + (if semantic-c-member-of-autocast + (let ((operator (car (semantic-find-tags-by-name "->" (semantic-analyze-scoped-type-parts type))))) + (if operator + (list (semantic-tag-get-attribute operator :type) (semantic-tag-get-attribute operator :type)) + (list type type-declaration))) + (list type type-declaration))) + + ;; David Engster: The following three functions deal with namespace + ;; aliases and types which are member of a namespace through a using + ;; statement. For examples, see the file semantic/tests/testusing.cpp, + ;; tests 5 and following. + + (defun semantic-c-dereference-namespace (type scope &optional type-declaration) + "Dereference namespace which might hold an 'alias' for TYPE. + Such an alias can be created through 'using' statements in a + namespace declaration. This function checks the namespaces in + SCOPE for such statements." + (let ((scopetypes (oref scope scopetypes)) + typename currentns tmp usingname result namespaces) + (when (and (semantic-tag-p type-declaration) + (or (null type) (semantic-tag-prototype-p type))) + (setq typename (semantic-analyze-split-name (semantic-tag-name type-declaration))) + ;; If we already have that TYPE in SCOPE, we do nothing + (unless (semantic-deep-find-tags-by-name (or (car-safe typename) typename) scopetypes) + (if (stringp typename) + ;; The type isn't fully qualified, so we have to search in all namespaces in SCOPE. + (setq namespaces (semantic-find-tags-by-type "namespace" scopetypes)) + ;; This is a fully qualified name, so we only have to search one namespace. + (setq namespaces (semanticdb-typecache-find (car typename))) + ;; Make sure it's really a namespace. + (if (string= (semantic-tag-type namespaces) "namespace") + (setq namespaces (list namespaces)) + (setq namespaces nil))) + (setq result nil) + ;; Iterate over all the namespaces we have to check. + (while (and namespaces + (null result)) + (setq currentns (car namespaces)) + ;; Check if this is namespace is an alias and dereference it if necessary. + (setq result (semantic-c-dereference-namespace-alias type-declaration currentns)) + (unless result + ;; Otherwise, check if we can reach the type through 'using' statements. + (setq result + (semantic-c-check-type-namespace-using type-declaration currentns))) + (setq namespaces (cdr namespaces))))) + (if result + ;; we have found the original type + (list result result) + (list type type-declaration)))) + + (defun semantic-c-dereference-namespace-alias (type namespace) + "Dereference TYPE in NAMESPACE, given that NAMESPACE is an alias. + Checks if NAMESPACE is an alias and if so, returns a new type + with a fully qualified name in the original namespace. Returns + nil if NAMESPACE is not an alias." + (when (eq (semantic-tag-get-attribute namespace :kind) 'alias) + (let ((typename (semantic-analyze-split-name (semantic-tag-name type))) + ns nstype originaltype newtype) + ;; Make typename unqualified + (if (listp typename) + (setq typename (last typename)) + (setq typename (list typename))) + (when + (and + ;; Get original namespace and make sure TYPE exists there. + (setq ns (semantic-tag-name + (car (semantic-tag-get-attribute namespace :members)))) + (setq nstype (semanticdb-typecache-find ns)) + (setq originaltype (semantic-find-tags-by-name + (car typename) + (semantic-tag-get-attribute nstype :members)))) + ;; Construct new type with name in original namespace. + (setq ns (semantic-analyze-split-name ns)) + (setq newtype + (semantic-tag-clone + (car originaltype) + (semantic-analyze-unsplit-name + (if (listp ns) + (append ns typename) + (append (list ns) typename))))))))) + + ;; This searches a type in a namespace, following through all using + ;; statements. + (defun semantic-c-check-type-namespace-using (type namespace) + "Check if TYPE is accessible in NAMESPACE through a using statement. + Returns the original type from the namespace where it is defined, + or nil if it cannot be found." + (let (usings result usingname usingtype unqualifiedname members shortname tmp) + ;; Get all using statements from NAMESPACE. + (when (and (setq usings (semantic-tag-get-attribute namespace :members)) + (setq usings (semantic-find-tags-by-class 'using usings))) + ;; Get unqualified typename. + (when (listp (setq unqualifiedname (semantic-analyze-split-name + (semantic-tag-name type)))) + (setq unqualifiedname (car (last unqualifiedname)))) + ;; Iterate over all using statements in NAMESPACE. + (while (and usings + (null result)) + (setq usingname (semantic-analyze-split-name + (semantic-tag-name (car usings))) + usingtype (semantic-tag-type (semantic-tag-type (car usings)))) + (cond + ((or (string= usingtype "namespace") + (stringp usingname)) + ;; We are dealing with a 'using [namespace] NAMESPACE;' + ;; Search for TYPE in that namespace + (setq result + (semanticdb-typecache-find usingname)) + (if (and result + (setq members (semantic-tag-get-attribute result :members)) + (setq members (semantic-find-tags-by-name unqualifiedname members))) + ;; TYPE is member of that namespace, so we are finished + (setq result (car members)) + ;; otherwise recursively search in that namespace for an alias + (setq result (semantic-c-check-type-namespace-using type result)) + (when result + (setq result (semantic-tag-type result))))) + ((and (string= usingtype "class") + (listp usingname)) + ;; We are dealing with a 'using TYPE;' + (when (string= unqualifiedname (car (last usingname))) + ;; We have found the correct tag. + (setq result (semantic-tag-type (car usings)))))) + (setq usings (cdr usings)))) + result)) + + + (define-mode-local-override semantic-analyze-dereference-metatype + c-mode (type scope &optional type-declaration) + "Dereference TYPE as described in `semantic-analyze-dereference-metatype'. + Handle typedef, template instantiation, and '->' operator." + (let* ((dereferencer-list '(semantic-c-dereference-typedef + semantic-c-dereference-template + semantic-c-dereference-member-of + semantic-c-dereference-namespace)) + (dereferencer (pop dereferencer-list)) + (type-tuple) + (original-type type)) + (while dereferencer + (setq type-tuple (funcall dereferencer type scope type-declaration) + type (car type-tuple) + type-declaration (cadr type-tuple)) + (if (not (eq type original-type)) + ;; we found a new type so break the dereferencer loop now ! + ;; (we will be recalled with the new type expanded by + ;; semantic-analyze-dereference-metatype-stack). + (setq dereferencer nil) + ;; no new type found try the next dereferencer : + (setq dereferencer (pop dereferencer-list))))) + (list type type-declaration)) + + (define-mode-local-override semantic-analyze-type-constants c-mode (type) + "When TYPE is a tag for an enum, return it's parts. + These are constants which are of type TYPE." + (if (and (eq (semantic-tag-class type) 'type) + (string= (semantic-tag-type type) "enum")) + (semantic-tag-type-members type))) + + (define-mode-local-override semantic-analyze-split-name c-mode (name) + "Split up tag names on colon (:) boundaries." + (let ((ans (split-string name ":"))) + (if (= (length ans) 1) + name + (delete "" ans)))) + + (define-mode-local-override semantic-analyze-unsplit-name c-mode (namelist) + "Assemble the list of names NAMELIST into a namespace name." + (mapconcat 'identity namelist "::")) + + (define-mode-local-override semantic-ctxt-scoped-types c++-mode (&optional point) + "Return a list of tags of CLASS type based on POINT. + DO NOT return the list of tags encompassing point." + (when point (goto-char (point))) + (let ((tagsaroundpoint (semantic-find-tag-by-overlay)) + (tagreturn nil) + (tmp nil)) + ;; In C++, we want to find all the namespaces declared + ;; locally and add them to the list. + (setq tmp (semantic-find-tags-by-class 'type (current-buffer))) + (setq tmp (semantic-find-tags-by-type "namespace" tmp)) + (setq tmp (semantic-find-tags-by-name "unnamed" tmp)) + (setq tagreturn tmp) + ;; We should also find all "using" type statements and + ;; accept those entities in as well. + (setq tmp (semanticdb-find-tags-by-class 'using)) + (let ((idx 0) + (len (semanticdb-find-result-length tmp))) + (while (< idx len) + (setq tagreturn (cons (semantic-tag-type (car (semanticdb-find-result-nth tmp idx))) tagreturn)) + (setq idx (1+ idx))) + ) + ;; Use the encompased types around point to also look for using statements. + ;;(setq tagreturn (cons "bread_name" tagreturn)) + (while (cdr tagsaroundpoint) ; don't search the last one + (setq tmp (semantic-find-tags-by-class 'using (semantic-tag-components (car tagsaroundpoint)))) + (dolist (T tmp) + (setq tagreturn (cons (semantic-tag-type T) tagreturn)) + ) + (setq tagsaroundpoint (cdr tagsaroundpoint)) + ) + ;; If in a function... + (when (and (semantic-tag-of-class-p (car tagsaroundpoint) 'function) + ;; ...search for using statements in the local scope... + (setq tmp (semantic-find-tags-by-class + 'using + (semantic-get-local-variables)))) + ;; ... and add them. + (setq tagreturn + (append tagreturn + (mapcar 'semantic-tag-type tmp)))) + ;; Return the stuff + tagreturn + )) + + (define-mode-local-override semantic-get-local-variables c++-mode () + "Do what `semantic-get-local-variables' does, plus add `this' if needed." + (let* ((origvar (semantic-get-local-variables-default)) + (ct (semantic-current-tag)) + (p (semantic-tag-function-parent ct))) + ;; If we have a function parent, then that implies we can + (if (and p (semantic-tag-of-class-p ct 'function)) + ;; Append a new tag THIS into our space. + (cons (semantic-tag-new-variable "this" p nil) + origvar) + ;; No parent, just return the usual + origvar) + )) + + (define-mode-local-override semantic-idle-summary-current-symbol-info + c-mode () + "Handle the SPP keywords, then use the default mechanism." + (let* ((sym (car (semantic-ctxt-current-thing))) + (spp-sym (semantic-lex-spp-symbol sym))) + (if spp-sym + (let* ((txt (concat "Macro: " sym)) + (sv (symbol-value spp-sym)) + (arg (semantic-lex-spp-macro-with-args sv)) + ) + (when arg + (setq txt (concat txt (format "%S" arg))) + (setq sv (cdr sv))) + + ;; This is optional, and potentially fraught w/ errors. + (condition-case nil + (dolist (lt sv) + (setq txt (concat txt " " (semantic-lex-token-text lt)))) + (error (setq txt (concat txt " #error in summary fcn")))) + + txt) + (semantic-idle-summary-current-symbol-info-default)))) + + (defvar-mode-local c-mode semantic-orphaned-member-metaparent-type "struct" + "When lost memberes are found in the class hierarchy generator, use a struct.") + + (defvar-mode-local c-mode semantic-symbol->name-assoc-list + '((type . "Types") + (variable . "Variables") + (function . "Functions") + (include . "Includes") + ) + "List of tag classes, and strings to describe them.") + + (defvar-mode-local c-mode semantic-symbol->name-assoc-list-for-type-parts + '((type . "Types") + (variable . "Attributes") + (function . "Methods") + (label . "Labels") + ) + "List of tag classes in a datatype decl, and strings to describe them.") + + (defvar-mode-local c-mode imenu-create-index-function 'semantic-create-imenu-index + "Imenu index function for C.") + + (defvar-mode-local c-mode semantic-type-relation-separator-character + '("." "->" "::") + "Separator characters between something of a given type, and a field.") + + (defvar-mode-local c-mode semantic-command-separation-character ";" + "Commen separation character for C") + + (defvar-mode-local c-mode senator-step-at-tag-classes '(function variable) + "Tag classes where senator will stop at the end.") + + ;;;###autoload + (defun semantic-default-c-setup () + "Set up a buffer for semantic parsing of the C language." + (semantic-c-by--install-parser) + (setq semantic-lex-syntax-modifications '((?> ".") + (?< ".") + ) + ) + + (setq semantic-lex-analyzer #'semantic-c-lexer) + (add-hook 'semantic-lex-reset-hooks 'semantic-lex-spp-reset-hook nil t) + ) + + ;;;###autoload + (defun semantic-c-add-preprocessor-symbol (sym replacement) + "Add a preprocessor symbol SYM with a REPLACEMENT value." + (interactive "sSymbol: \nsReplacement: ") + (let ((SA (assoc sym semantic-lex-c-preprocessor-symbol-map))) + (if SA + ;; Replace if there is one. + (setcdr SA replacement) + ;; Otherwise, append + (setq semantic-lex-c-preprocessor-symbol-map + (cons (cons sym replacement) + semantic-lex-c-preprocessor-symbol-map)))) + + (semantic-c-reset-preprocessor-symbol-map) + ) + + ;;; SETUP QUERY + ;; + (defun semantic-c-describe-environment () + "Describe the Semantic features of the current C environment." + (interactive) + (if (not (or (eq major-mode 'c-mode) (eq major-mode 'c++-mode))) + (error "Not useful to query C mode in %s mode" major-mode)) + (let ((gcc (when (boundp 'semantic-gcc-setup-data) + semantic-gcc-setup-data)) + ) + (semantic-fetch-tags) + + (with-output-to-temp-buffer "*Semantic C Environment*" + (when gcc + (princ "Calculated GCC Parameters:") + (dolist (P gcc) + (princ "\n ") + (princ (car P)) + (princ " = ") + (princ (cdr P)) + ) + ) + + (princ "\n\nInclude Path Summary:\n") + (when (and (boundp 'ede-object) ede-object) + (princ "\n This file's project include is handled by:\n") + (princ " ") + (princ (object-print ede-object)) + (princ "\n with the system path:\n") + (dolist (dir (ede-system-include-path ede-object)) + (princ " ") + (princ dir) + (princ "\n")) + ) + + (when semantic-dependency-include-path + (princ "\n This file's generic include path is:\n") + (dolist (dir semantic-dependency-include-path) + (princ " ") + (princ dir) + (princ "\n"))) + + (when semantic-dependency-system-include-path + (princ "\n This file's system include path is:\n") + (dolist (dir semantic-dependency-system-include-path) + (princ " ") + (princ dir) + (princ "\n"))) + + (princ "\n\nMacro Summary:\n") + (when semantic-lex-c-preprocessor-symbol-file + (princ "\n Your CPP table is primed from these files:\n") + (dolist (file semantic-lex-c-preprocessor-symbol-file) + (princ " ") + (princ file) + (princ "\n") + (princ " in table: ") + (princ (object-print (semanticdb-file-table-object file))) + (princ "\n") + )) + + (when semantic-lex-c-preprocessor-symbol-map-builtin + (princ "\n Built-in symbol map:\n") + (dolist (S semantic-lex-c-preprocessor-symbol-map-builtin) + (princ " ") + (princ (car S)) + (princ " = ") + (princ (cdr S)) + (princ "\n") + )) + + (when semantic-lex-c-preprocessor-symbol-map + (princ "\n User symbol map:\n") + (dolist (S semantic-lex-c-preprocessor-symbol-map) + (princ " ") + (princ (car S)) + (princ " = ") + (princ (cdr S)) + (princ "\n") + )) + + (princ "\n\n Use: M-x semantic-lex-spp-describe RET\n") + (princ "\n to see the complete macro table.\n") + + ))) + + (provide 'semantic/bovine/c) + + (semantic-c-reset-preprocessor-symbol-map) + + ;; Local variables: + ;; generated-autoload-file: "../loaddefs.el" + ;; generated-autoload-feature: semantic/loaddefs + ;; generated-autoload-load-name: "semantic/bovine/c" + ;; End: + + ;;; semantic/bovine/c.el ends here diff --cc lisp/cedet/semantic/bovine/make-by.el index 00000000000,d3319836fef..19e35d0682b mode 000000,100644..100644 --- a/lisp/cedet/semantic/bovine/make-by.el +++ b/lisp/cedet/semantic/bovine/make-by.el @@@ -1,0 -1,394 +1,387 @@@ + ;;; semantic/bovine/make-by.el --- Generated parser support file + + ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2008 + ;;; Free Software Foundation, Inc. + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; + ;; This file was generated from the grammar file + ;; semantic/bovine/make.by in the CEDET repository. + + ;;; Code: + ++(require 'semantic/lex) + (eval-when-compile (require 'semantic/bovine)) ++ + + ;;; Prologue + ;; + + ;;; Declarations + ;; + (defconst semantic-make-by--keyword-table + (semantic-lex-make-keyword-table + '(("if" . IF) + ("ifdef" . IFDEF) + ("ifndef" . IFNDEF) + ("ifeq" . IFEQ) + ("ifneq" . IFNEQ) + ("else" . ELSE) + ("endif" . ENDIF) + ("include" . INCLUDE)) + '(("include" summary "Macro: include filename1 filename2 ...") + ("ifneq" summary "Conditional: ifneq (expression) ... else ... endif") + ("ifeq" summary "Conditional: ifeq (expression) ... else ... endif") + ("ifndef" summary "Conditional: ifndef (expression) ... else ... endif") + ("ifdef" summary "Conditional: ifdef (expression) ... else ... endif") + ("endif" summary "Conditional: if (expression) ... else ... endif") + ("else" summary "Conditional: if (expression) ... else ... endif") + ("if" summary "Conditional: if (expression) ... else ... endif"))) + "Table of language keywords.") + + (defconst semantic-make-by--token-table + (semantic-lex-make-type-table + '(("punctuation" + (BACKSLASH . "\\`[\\]\\'") + (DOLLAR . "\\`[$]\\'") + (EQUAL . "\\`[=]\\'") + (PLUS . "\\`[+]\\'") + (COLON . "\\`[:]\\'"))) + 'nil) + "Table of lexical tokens.") + + (defconst semantic-make-by--parse-table + `( + (bovine-toplevel + (Makefile) + ) ;; end bovine-toplevel + + (Makefile + (bol + newline + ,(semantic-lambda + (list nil)) + ) + (bol + variable + ,(semantic-lambda + (nth 1 vals)) + ) + (bol + rule + ,(semantic-lambda + (nth 1 vals)) + ) + (bol + conditional + ,(semantic-lambda + (nth 1 vals)) + ) + (bol + include + ,(semantic-lambda + (nth 1 vals)) + ) + (whitespace + ,(semantic-lambda + (list nil)) + ) + (newline + ,(semantic-lambda + (list nil)) + ) + ) ;; end Makefile + + (variable + (symbol + opt-whitespace + equals + opt-whitespace + element-list + ,(semantic-lambda + (semantic-tag-new-variable + (nth 0 vals) nil + (nth 4 vals))) + ) + ) ;; end variable + + (rule + (targets + opt-whitespace + colons + opt-whitespace + element-list + commands + ,(semantic-lambda + (semantic-tag-new-function + (nth 0 vals) nil + (nth 4 vals))) + ) + ) ;; end rule + + (targets + (target + opt-whitespace + targets + ,(semantic-lambda + (list + (car + (nth 0 vals)) + (car + (nth 2 vals)))) + ) + (target + ,(semantic-lambda + (list + (car + (nth 0 vals)))) + ) + ) ;; end targets + + (target + (sub-target + target + ,(semantic-lambda + (list + (concat + (car + (nth 0 vals)) + (car + (nth 2 vals))))) + ) + (sub-target + ,(semantic-lambda + (list + (car + (nth 0 vals)))) + ) + ) ;; end target + + (sub-target + (symbol) + (string) + (varref) + ) ;; end sub-target + + (conditional + (IF + some-whitespace + symbol + newline + ,(semantic-lambda + (list nil)) + ) + (IFDEF + some-whitespace + symbol + newline + ,(semantic-lambda + (list nil)) + ) + (IFNDEF + some-whitespace + symbol + newline + ,(semantic-lambda + (list nil)) + ) + (IFEQ + some-whitespace + expression + newline + ,(semantic-lambda + (list nil)) + ) + (IFNEQ + some-whitespace + expression + newline + ,(semantic-lambda + (list nil)) + ) + (ELSE + newline + ,(semantic-lambda + (list nil)) + ) + (ENDIF + newline + ,(semantic-lambda + (list nil)) + ) + ) ;; end conditional + + (expression + (semantic-list) + ) ;; end expression + + (include + (INCLUDE + some-whitespace + element-list + ,(semantic-lambda + (semantic-tag-new-include + (nth 2 vals) nil)) + ) + ) ;; end include + + (equals + (punctuation + "\\`[:]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda) + ) + (punctuation + "\\`[+]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda) + ) + (punctuation + "\\`[=]\\'" + ,(semantic-lambda) + ) + ) ;; end equals + + (colons + (punctuation + "\\`[:]\\'" + punctuation + "\\`[:]\\'" + ,(semantic-lambda) + ) + (punctuation + "\\`[:]\\'" + ,(semantic-lambda) + ) + ) ;; end colons + + (element-list + (elements + newline + ,(semantic-lambda + (nth 0 vals)) + ) + ) ;; end element-list + + (elements + (element + some-whitespace + elements + ,(semantic-lambda + (nth 0 vals) + (nth 2 vals)) + ) + (element + ,(semantic-lambda + (nth 0 vals)) + ) + ( ;;EMPTY + ) + ) ;; end elements + + (element + (sub-element + element + ,(semantic-lambda + (list + (concat + (car + (nth 0 vals)) + (car + (nth 1 vals))))) + ) + ( ;;EMPTY + ) + ) ;; end element + + (sub-element + (symbol) + (string) + (punctuation) + (semantic-list + ,(semantic-lambda + (list + (buffer-substring-no-properties + (identity start) + (identity end)))) + ) + ) ;; end sub-element + + (varref + (punctuation + "\\`[$]\\'" + semantic-list + ,(semantic-lambda + (list + (buffer-substring-no-properties + (identity start) + (identity end)))) + ) + ) ;; end varref + + (commands + (bol + shell-command + newline + commands + ,(semantic-lambda + (list + (nth 0 vals)) + (nth 1 vals)) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end commands + + (opt-whitespace + (some-whitespace + ,(semantic-lambda + (list nil)) + ) + ( ;;EMPTY + ) + ) ;; end opt-whitespace + + (some-whitespace + (whitespace + some-whitespace + ,(semantic-lambda + (list nil)) + ) + (whitespace + ,(semantic-lambda + (list nil)) + ) + ) ;; end some-whitespace + ) + "Parser table.") + + (defun semantic-make-by--install-parser () + "Setup the Semantic Parser." + (setq semantic--parse-table semantic-make-by--parse-table + semantic-debug-parser-source "make.by" + semantic-debug-parser-class 'semantic-bovine-debug-parser + semantic-flex-keywords-obarray semantic-make-by--keyword-table + )) + - -;;; Analyzers -;; -(require 'semantic/lex) - - -;;; Epilogue -;; - + (provide 'semantic/bovine/make-by) + + ;;; semantic/bovine/make-by.el ends here diff --cc lisp/cedet/semantic/bovine/make.el index 00000000000,ac7d084a384..9f3edcfbe9b mode 000000,100644..100644 --- a/lisp/cedet/semantic/bovine/make.el +++ b/lisp/cedet/semantic/bovine/make.el @@@ -1,0 -1,241 +1,242 @@@ + ;;; semantic/bovine/make.el --- Makefile parsing rules. + + ;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2008 + ;;; Free Software Foundation, Inc. + + ;; Author: Eric M. Ludlam + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; + ;; Use the Semantic Bovinator to parse Makefiles. + ;; Concocted as an experiment for nonstandard languages. + + (require 'make-mode) + + (require 'semantic) + (require 'semantic/bovine/make-by) + (require 'semantic/analyze) -(require 'semantic/format) ++(require 'semantic/dep) + -(eval-when-compile - (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 --cc lisp/cedet/semantic/bovine/scm-by.el index 00000000000,936b229f8b6..82a8ae6ffa3 mode 000000,100644..100644 --- a/lisp/cedet/semantic/bovine/scm-by.el +++ b/lisp/cedet/semantic/bovine/scm-by.el @@@ -1,0 -1,198 +1,191 @@@ + ;;; semantic-scm-by.el --- Generated parser support file + + ;; Copyright (C) 2001, 2003, 2009 Free Software Foundation, Inc. + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; + ;; This file was generated from the grammar file + ;; semantic/bovine/scm.by in the CEDET repository. + + ;;; Code: + ++(require 'semantic/lex) ++ + (eval-when-compile (require 'semantic/bovine)) + + ;;; Prologue + ;; + + ;;; Declarations + ;; + (defconst semantic-scm-by--keyword-table + (semantic-lex-make-keyword-table + '(("define" . DEFINE) + ("define-module" . DEFINE-MODULE) + ("load" . LOAD)) + '(("load" summary "Function: (load \"filename\")") + ("define-module" summary "Function: (define-module (name arg1 ...)) ") + ("define" summary "Function: (define symbol expression)"))) + "Table of language keywords.") + + (defconst semantic-scm-by--token-table + (semantic-lex-make-type-table + '(("close-paren" + (CLOSEPAREN . ")")) + ("open-paren" + (OPENPAREN . "("))) + 'nil) + "Table of lexical tokens.") + + (defconst semantic-scm-by--parse-table + `( + (bovine-toplevel + (scheme) + ) ;; end bovine-toplevel + + (scheme + (semantic-list + ,(lambda (vals start end) + (semantic-bovinate-from-nonterminal + (car + (nth 0 vals)) + (cdr + (nth 0 vals)) + 'scheme-list)) + ) + ) ;; end scheme + + (scheme-list + (open-paren + "(" + scheme-in-list + close-paren + ")" + ,(semantic-lambda + (nth 1 vals)) + ) + ) ;; end scheme-list + + (scheme-in-list + (DEFINE + symbol + expression + ,(semantic-lambda + (semantic-tag-new-variable + (nth 1 vals) nil + (nth 2 vals))) + ) + (DEFINE + name-args + opt-doc + sequence + ,(semantic-lambda + (semantic-tag-new-function + (car + (nth 1 vals)) nil + (cdr + (nth 1 vals)))) + ) + (DEFINE-MODULE + name-args + ,(semantic-lambda + (semantic-tag-new-package + (nth + (length + (nth 1 vals)) + (nth 1 vals)) nil)) + ) + (LOAD + string + ,(semantic-lambda + (semantic-tag-new-include + (file-name-nondirectory + (read + (nth 1 vals))) + (read + (nth 1 vals)))) + ) + (symbol + ,(semantic-lambda + (semantic-tag-new-code + (nth 0 vals) nil)) + ) + ) ;; end scheme-in-list + + (name-args + (semantic-list + ,(lambda (vals start end) + (semantic-bovinate-from-nonterminal + (car + (nth 0 vals)) + (cdr + (nth 0 vals)) + 'name-arg-expand)) + ) + ) ;; end name-args + + (name-arg-expand + (open-paren + name-arg-expand + ,(semantic-lambda + (nth 1 vals)) + ) + (symbol + name-arg-expand + ,(semantic-lambda + (cons + (nth 0 vals) + (nth 1 vals))) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end name-arg-expand + + (opt-doc + (string) + ( ;;EMPTY + ) + ) ;; end opt-doc + + (sequence + (expression + sequence) + (expression) + ) ;; end sequence + + (expression + (symbol) + (semantic-list) + (string) + (number) + ) ;; end expression + ) + "Parser table.") + + (defun semantic-scm-by--install-parser () + "Setup the Semantic Parser." + (setq semantic--parse-table semantic-scm-by--parse-table + semantic-debug-parser-source "scheme.by" + semantic-debug-parser-class 'semantic-bovine-debug-parser + semantic-flex-keywords-obarray semantic-scm-by--keyword-table + )) + - -;;; Analyzers -;; -(require 'semantic/lex) - - -;;; Epilogue -;; - + (provide 'semantic/bovine/scm-by) + + ;;; semantic/bovine/scm-by.el ends here diff --cc lisp/cedet/semantic/bovine/scm.el index 00000000000,091486cc382..82a7dde039b mode 000000,100644..100644 --- a/lisp/cedet/semantic/bovine/scm.el +++ b/lisp/cedet/semantic/bovine/scm.el @@@ -1,0 -1,121 +1,119 @@@ + ;;; semantic/bovine/scm.el --- Semantic details for Scheme (guile) + + ;;; Copyright (C) 2001, 2002, 2003, 2004, 2008, 2009 + ;;; Free Software Foundation, Inc. + + ;; Author: Eric M. Ludlam + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; + ;; Use the Semantic Bovinator for Scheme (guile) + + (require 'semantic) + (require 'semantic/bovine/scm-by) + (require 'semantic/format) - -(eval-when-compile - (require 'semantic/dep)) ++(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 --cc lisp/cedet/semantic/complete.el index 00000000000,c591c1588e7..cbf3d9da9ae mode 000000,100644..100644 --- a/lisp/cedet/semantic/complete.el +++ b/lisp/cedet/semantic/complete.el @@@ -1,0 -1,2138 +1,2101 @@@ + ;;; semantic/complete.el --- Routines for performing tag completion + + ;;; Copyright (C) 2003, 2004, 2005, 2007, 2008, 2009 + ;;; Free Software Foundation, Inc. + + ;; Author: Eric M. Ludlam + ;; Keywords: syntax + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; + ;; Completion of tags by name using tables of semantic generated tags. + ;; + ;; While it would be a simple matter of flattening all tag known + ;; tables to perform completion across them using `all-completions', + ;; or `try-completion', that process would be slow. In particular, + ;; when a system database is included in the mix, the potential for a + ;; ludicrous number of options becomes apparent. + ;; + ;; As such, dynamically searching across tables using a prefix, + ;; regular expression, or other feature is needed to help find symbols + ;; quickly without resorting to "show me every possible option now". + ;; + ;; In addition, some symbol names will appear in multiple locations. + ;; If it is important to distiguish, then a way to provide a choice + ;; over these locations is important as well. + ;; + ;; Beyond brute force offers for completion of plain strings, + ;; using the smarts of semantic-analyze to provide reduced lists of + ;; symbols, or fancy tabbing to zoom into files to show multiple hits + ;; of the same name can be provided. + ;; + ;;; How it works: + ;; + ;; There are several parts of any completion engine. They are: + ;; + ;; A. Collection of possible hits + ;; B. Typing or selecting an option + ;; C. Displaying possible unique completions + ;; D. Using the result + ;; + ;; Here, we will treat each section separately (excluding D) + ;; They can then be strung together in user-visible commands to + ;; fullfill specific needs. + ;; + ;; COLLECTORS: + ;; + ;; A collector is an object which represents the means by which tags + ;; to complete on are collected. It's first job is to find all the + ;; tags which are to be completed against. It can also rename + ;; some tags if needed so long as `semantic-tag-clone' is used. + ;; + ;; Some collectors will gather all tags to complete against first + ;; (for in buffer queries, or other small list situations). It may + ;; choose to do a broad search on each completion request. Built in + ;; functionality automatically focuses the cache in as the user types. + ;; + ;; A collector choosing to create and rename tags could choose a + ;; plain name format, a postfix name such as method:class, or a + ;; prefix name such as class.method. + ;; + ;; DISPLAYORS + ;; + ;; A displayor is in charge if showing the user interesting things + ;; about available completions, and can optionally provide a focus. + ;; The simplest display just lists all available names in a separate + ;; window. It may even choose to show short names when there are + ;; many to choose from, or long names when there are fewer. + ;; + ;; A complex displayor could opt to help the user 'focus' on some + ;; range. For example, if 4 tags all have the same name, subsequent + ;; calls to the displayor may opt to show each tag one at a time in + ;; the buffer. When the user likes one, selection would cause the + ;; 'focus' item to be selected. + ;; + ;; CACHE FORMAT + ;; + ;; The format of the tag lists used to perform the completions are in + ;; semanticdb "find" format, like this: + ;; + ;; ( ( DBTABLE1 TAG1 TAG2 ...) + ;; ( DBTABLE2 TAG1 TAG2 ...) + ;; ... ) + ;; + ;; INLINE vs MINIBUFFER + ;; + ;; Two major ways completion is used in Emacs is either through a + ;; minibuffer query, or via completion in a normal editing buffer, + ;; encompassing some small range of characters. + ;; + ;; Structure for both types of completion are provided here. + ;; `semantic-complete-read-tag-engine' will use the minibuffer. + ;; `semantic-complete-inline-tag-engine' will complete text in + ;; a buffer. + -(require 'eieio) -(require 'eieio-opt) + (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)) + -(eval-when-compile - (condition-case nil - ;; Tooltip not available in older emacsen. - (require 'tooltip) - (error nil)) - ) - + ;;; Code: + -;;; Compatibility -;; -(if (fboundp 'minibuffer-contents) - (eval-and-compile (defalias 'semantic-minibuffer-contents 'minibuffer-contents)) - (eval-and-compile (defalias 'semantic-minibuffer-contents 'buffer-string))) -(if (fboundp 'delete-minibuffer-contents) - (eval-and-compile (defalias 'semantic-delete-minibuffer-contents 'delete-minibuffer-contents)) - (eval-and-compile (defalias 'semantic-delete-minibuffer-contents 'erase-buffer))) - + (defvar semantic-complete-inline-overlay nil + "The overlay currently active while completing inline.") + + (defun semantic-completion-inline-active-p () + "Non-nil if inline completion is active." + (when (and semantic-complete-inline-overlay + (not (semantic-overlay-live-p semantic-complete-inline-overlay))) + (semantic-overlay-delete semantic-complete-inline-overlay) + (setq semantic-complete-inline-overlay nil)) + semantic-complete-inline-overlay) + + ;;; ------------------------------------------------------------ + ;;; MINIBUFFER or INLINE utils + ;; + (defun semantic-completion-text () + "Return the text that is currently in the completion buffer. + For a minibuffer prompt, this is the minibuffer text. + For inline completion, this is the text wrapped in the inline completion + overlay." + (if semantic-complete-inline-overlay + (semantic-complete-inline-text) - (semantic-minibuffer-contents))) ++ (minibuffer-contents))) + + (defun semantic-completion-delete-text () + "Delete the text that is actively being completed. + Presumably if you call this you will insert something new there." + (if semantic-complete-inline-overlay + (semantic-complete-inline-delete-text) - (semantic-delete-minibuffer-contents))) ++ (delete-minibuffer-contents))) + + (defun semantic-completion-message (fmt &rest args) + "Display the string FMT formatted with ARGS at the end of the minibuffer." + (if semantic-complete-inline-overlay + (apply 'message fmt args) + (message (concat (buffer-string) (apply 'format fmt args))))) + + ;;; ------------------------------------------------------------ + ;;; MINIBUFFER: Option Selection harnesses + ;; + (defvar semantic-completion-collector-engine nil + "The tag collector for the current completion operation. + Value should be an object of a subclass of + `semantic-completion-engine-abstract'.") + + (defvar semantic-completion-display-engine nil + "The tag display engine for the current completion operation. + Value should be a ... what?") + + (defvar semantic-complete-key-map + (let ((km (make-sparse-keymap))) + (define-key km " " 'semantic-complete-complete-space) + (define-key km "\t" 'semantic-complete-complete-tab) + (define-key km "\C-m" 'semantic-complete-done) + (define-key km "\C-g" 'abort-recursive-edit) + (define-key km "\M-n" 'next-history-element) + (define-key km "\M-p" 'previous-history-element) + (define-key km "\C-n" 'next-history-element) + (define-key km "\C-p" 'previous-history-element) + ;; Add history navigation + km) + "Keymap used while completing across a list of tags.") + + (defvar semantic-completion-default-history nil + "Default history variable for any unhistoried prompt. + Keeps STRINGS only in the history.") + + + (defun semantic-complete-read-tag-engine (collector displayor prompt + default-tag initial-input + history) + "Read a semantic tag, and return a tag for the selection. + Argument COLLECTOR is an object which can be used to to calculate + a list of possible hits. See `semantic-completion-collector-engine' + for details on COLLECTOR. + Argumeng DISPLAYOR is an object used to display a list of possible + completions for a given prefix. See`semantic-completion-display-engine' + for details on DISPLAYOR. + PROMPT is a string to prompt with. + DEFAULT-TAG is a semantic tag or string to use as the default value. + If INITIAL-INPUT is non-nil, insert it in the minibuffer initially. + HISTORY is a symbol representing a variable to story the history in." + (let* ((semantic-completion-collector-engine collector) + (semantic-completion-display-engine displayor) + (semantic-complete-active-default nil) + (semantic-complete-current-matched-tag nil) + (default-as-tag (semantic-complete-default-to-tag default-tag)) + (default-as-string (when (semantic-tag-p default-as-tag) + (semantic-tag-name default-as-tag))) + ) + + (when default-as-string + ;; Add this to the prompt. + ;; + ;; I really want to add a lookup of the symbol in those + ;; tags available to the collector and only add it if it + ;; is available as a possibility, but I'm too lazy right + ;; now. + ;; + + ;; @todo - move from () to into the editable area + (if (string-match ":" prompt) + (setq prompt (concat + (substring prompt 0 (match-beginning 0)) + " (" default-as-string ")" + (substring prompt (match-beginning 0)))) + (setq prompt (concat prompt " (" default-as-string "): ")))) + ;; + ;; Perform the Completion + ;; + (unwind-protect + (read-from-minibuffer prompt + initial-input + semantic-complete-key-map + nil + (or history + 'semantic-completion-default-history) + default-tag) + (semantic-collector-cleanup semantic-completion-collector-engine) + (semantic-displayor-cleanup semantic-completion-display-engine) + ) + ;; + ;; Extract the tag from the completion machinery. + ;; + semantic-complete-current-matched-tag + )) + + + ;;; Util for basic completion prompts + ;; + + (defvar semantic-complete-active-default nil + "The current default tag calculated for this prompt.") + + (defun semantic-complete-default-to-tag (default) + "Convert a calculated or passed in DEFAULT into a tag." + (if (semantic-tag-p default) + ;; Just return what was passed in. + (setq semantic-complete-active-default default) + ;; If none was passed in, guess. + (if (null default) + (setq default (semantic-ctxt-current-thing))) + (if (null default) + ;; Do nothing + nil + ;; Turn default into something useful. + (let ((str + (cond + ;; Semantic-ctxt-current-symbol will return a list of + ;; strings. Technically, we should use the analyzer to + ;; fully extract what we need, but for now, just grab the + ;; first string + ((and (listp default) (stringp (car default))) + (car default)) + ((stringp default) + default) + ((symbolp default) + (symbol-name default)) + (t + (signal 'wrong-type-argument + (list default 'semantic-tag-p))))) + (tag nil)) + ;; Now that we have that symbol string, look it up using the active + ;; collector. If we get a match, use it. + (save-excursion + (semantic-collector-calculate-completions + semantic-completion-collector-engine + str nil)) + ;; Do we have the perfect match??? + (let ((ml (semantic-collector-current-exact-match + semantic-completion-collector-engine))) + (when ml + ;; We don't care about uniqueness. Just guess for convenience + (setq tag (semanticdb-find-result-nth-in-buffer ml 0)))) + ;; save it + (setq semantic-complete-active-default tag) + ;; Return it.. .whatever it may be + tag)))) + + + ;;; Prompt Return Value + ;; + ;; Getting a return value out of this completion prompt is a bit + ;; challenging. The read command returns the string typed in. + ;; We need to convert this into a valid tag. We can exit the minibuffer + ;; for different reasons. If we purposely exit, we must make sure + ;; the focused tag is calculated... preferably once. + (defvar semantic-complete-current-matched-tag nil + "Variable used to pass the tags being matched to the prompt.") + + ;; semantic-displayor-focus-abstract-child-p is part of the + ;; semantic-displayor-focus-abstract class, defined later in this + ;; file. + (declare-function semantic-displayor-focus-abstract-child-p "semantic/complete") + + (defun semantic-complete-current-match () + "Calculate a match from the current completion environment. + Save this in our completion variable. Make sure that variable + is cleared if any other keypress is made. + Return value can be: + tag - a single tag that has been matched. + string - a message to show in the minibuffer." + ;; Query the environment for an active completion. + (let ((collector semantic-completion-collector-engine) + (displayor semantic-completion-display-engine) + (contents (semantic-completion-text)) + matchlist + answer) + (if (string= contents "") + ;; The user wants the defaults! + (setq answer semantic-complete-active-default) + ;; This forces a full calculation of completion on CR. + (save-excursion + (semantic-collector-calculate-completions collector contents nil)) + (semantic-complete-try-completion) + (cond + ;; Input match displayor focus entry + ((setq answer (semantic-displayor-current-focus displayor)) + ;; We have answer, continue + ) + ;; One match from the collector + ((setq matchlist (semantic-collector-current-exact-match collector)) + (if (= (semanticdb-find-result-length matchlist) 1) + (setq answer (semanticdb-find-result-nth-in-buffer matchlist 0)) + (if (semantic-displayor-focus-abstract-child-p displayor) + ;; For focusing displayors, we can claim this is + ;; not unique. Multiple focuses can choose the correct + ;; one. + (setq answer "Not Unique") + ;; If we don't have a focusing displayor, we need to do something + ;; graceful. First, see if all the matches have the same name. + (let ((allsame t) + (firstname (semantic-tag-name + (car + (semanticdb-find-result-nth matchlist 0))) + ) + (cnt 1) + (max (semanticdb-find-result-length matchlist))) + (while (and allsame (< cnt max)) + (if (not (string= + firstname + (semantic-tag-name + (car + (semanticdb-find-result-nth matchlist cnt))))) + (setq allsame nil)) + (setq cnt (1+ cnt)) + ) + ;; Now we know if they are all the same. If they are, just + ;; accept the first, otherwise complain. + (if allsame + (setq answer (semanticdb-find-result-nth-in-buffer + matchlist 0)) + (setq answer "Not Unique")) + )))) + ;; No match + (t + (setq answer "No Match"))) + ) + ;; Set it into our completion target. + (when (semantic-tag-p answer) + (setq semantic-complete-current-matched-tag answer) + ;; Make sure it is up to date by clearing it if the user dares + ;; to touch the keyboard. + (add-hook 'pre-command-hook + (lambda () (setq semantic-complete-current-matched-tag nil))) + ) + ;; Return it + answer + )) + + + ;;; Keybindings + ;; + ;; Keys are bound to to perform completion using our mechanisms. + ;; Do that work here. + (defun semantic-complete-done () + "Accept the current input." + (interactive) + (let ((ans (semantic-complete-current-match))) + (if (stringp ans) + (semantic-completion-message (concat " [" ans "]")) + (exit-minibuffer))) + ) + + (defun semantic-complete-complete-space () + "Complete the partial input in the minibuffer." + (interactive) + (semantic-complete-do-completion t)) + + (defun semantic-complete-complete-tab () + "Complete the partial input in the minibuffer as far as possible." + (interactive) + (semantic-complete-do-completion)) + + ;;; Completion Functions + ;; + ;; Thees routines are functional entry points to performing completion. + ;; + (defun semantic-complete-hack-word-boundaries (original new) + "Return a string to use for completion. + ORIGINAL is the text in the minibuffer. + NEW is the new text to insert into the minibuffer. + Within the difference bounds of ORIGINAL and NEW, shorten NEW + to the nearest word boundary, and return that." + (save-match-data + (let* ((diff (substring new (length original))) + (end (string-match "\\>" diff)) + (start (string-match "\\<" diff))) + (cond + ((and start (> start 0)) + ;; If start is greater than 0, include only the new + ;; white-space stuff + (concat original (substring diff 0 start))) + (end + (concat original (substring diff 0 end))) + (t new))))) + + (defun semantic-complete-try-completion (&optional partial) + "Try a completion for the current minibuffer. + If PARTIAL, do partial completion stopping at spaces." + (let ((comp (semantic-collector-try-completion + semantic-completion-collector-engine + (semantic-completion-text)))) + (cond + ((null comp) + (semantic-completion-message " [No Match]") + (ding) + ) + ((stringp comp) + (if (string= (semantic-completion-text) comp) + (when partial + ;; Minibuffer isn't changing AND the text is not unique. + ;; Test for partial completion over a word separator character. + ;; If there is one available, use that so that SPC can + ;; act like a SPC insert key. + (let ((newcomp (semantic-collector-current-whitespace-completion + semantic-completion-collector-engine))) + (when newcomp + (semantic-completion-delete-text) + (insert newcomp)) + )) + (when partial + (let ((orig (semantic-completion-text))) + ;; For partial completion, we stop and step over + ;; word boundaries. Use this nifty function to do + ;; that calculation for us. + (setq comp + (semantic-complete-hack-word-boundaries orig comp)))) + ;; Do the replacement. + (semantic-completion-delete-text) + (insert comp)) + ) + ((and (listp comp) (semantic-tag-p (car comp))) + (unless (string= (semantic-completion-text) + (semantic-tag-name (car comp))) + ;; A fully unique completion was available. + (semantic-completion-delete-text) + (insert (semantic-tag-name (car comp)))) + ;; The match is complete + (if (= (length comp) 1) + (semantic-completion-message " [Complete]") + (semantic-completion-message " [Complete, but not unique]")) + ) + (t nil)))) + + (defun semantic-complete-do-completion (&optional partial inline) + "Do a completion for the current minibuffer. + If PARTIAL, do partial completion stopping at spaces. + if INLINE, then completion is happening inline in a buffer." + (let* ((collector semantic-completion-collector-engine) + (displayor semantic-completion-display-engine) + (contents (semantic-completion-text)) + (ans nil)) + + (save-excursion + (semantic-collector-calculate-completions collector contents partial)) + (let* ((na (semantic-complete-next-action partial))) + (cond + ;; We're all done, but only from a very specific + ;; area of completion. + ((eq na 'done) + (semantic-completion-message " [Complete]") + (setq ans 'done)) + ;; Perform completion + ((or (eq na 'complete) + (eq na 'complete-whitespace)) + (semantic-complete-try-completion partial) + (setq ans 'complete)) + ;; We need to display the completions. + ;; Set the completions into the display engine + ((or (eq na 'display) (eq na 'displayend)) + (semantic-displayor-set-completions + displayor + (or + (and (not (eq na 'displayend)) + (semantic-collector-current-exact-match collector)) + (semantic-collector-all-completions collector contents)) + contents) + ;; Ask the displayor to display them. + (semantic-displayor-show-request displayor)) + ((eq na 'scroll) + (semantic-displayor-scroll-request displayor) + ) + ((eq na 'focus) + (semantic-displayor-focus-next displayor) + (semantic-displayor-focus-request displayor) + ) + ((eq na 'empty) + (semantic-completion-message " [No Match]")) + (t nil))) + ans)) + + + ;;; ------------------------------------------------------------ + ;;; INLINE: tag completion harness + ;; + ;; Unlike the minibuffer, there is no mode nor other traditional + ;; means of reading user commands in completion mode. Instead + ;; we use a pre-command-hook to inset in our commands, and to + ;; push ourselves out of this mode on alternate keypresses. + (defvar semantic-complete-inline-map + (let ((km (make-sparse-keymap))) + (define-key km "\C-i" 'semantic-complete-inline-TAB) + (define-key km "\M-p" 'semantic-complete-inline-up) + (define-key km "\M-n" 'semantic-complete-inline-down) + (define-key km "\C-m" 'semantic-complete-inline-done) + (define-key km "\C-\M-c" 'semantic-complete-inline-exit) + (define-key km "\C-g" 'semantic-complete-inline-quit) + (define-key km "?" + (lambda () (interactive) + (describe-variable 'semantic-complete-inline-map))) + km) + "Keymap used while performing Semantic inline completion. + \\{semantic-complete-inline-map}") + + (defface semantic-complete-inline-face + '((((class color) (background dark)) + (:underline "yellow")) + (((class color) (background light)) + (:underline "brown"))) + "*Face used to show the region being completed inline. + The face is used in `semantic-complete-inline-tag-engine'." + :group 'semantic-faces) + + (defun semantic-complete-inline-text () + "Return the text that is being completed inline. + Similar to `minibuffer-contents' when completing in the minibuffer." + (let ((s (semantic-overlay-start semantic-complete-inline-overlay)) + (e (semantic-overlay-end semantic-complete-inline-overlay))) + (if (= s e) + "" + (buffer-substring-no-properties s e )))) + + (defun semantic-complete-inline-delete-text () + "Delete the text currently being completed in the current buffer." + (delete-region + (semantic-overlay-start semantic-complete-inline-overlay) + (semantic-overlay-end semantic-complete-inline-overlay))) + + (defun semantic-complete-inline-done () + "This completion thing is DONE, OR, insert a newline." + (interactive) + (let* ((displayor semantic-completion-display-engine) + (tag (semantic-displayor-current-focus displayor))) + (if tag + (let ((txt (semantic-completion-text))) + (insert (substring (semantic-tag-name tag) + (length txt))) + (semantic-complete-inline-exit)) + + ;; Get whatever binding RET usually has. + (let ((fcn + (condition-case nil + (lookup-key (current-active-maps) (this-command-keys)) + (error + ;; I don't know why, but for some reason the above + ;; throws an error sometimes. + (lookup-key (current-global-map) (this-command-keys)) + )))) + (when fcn + (funcall fcn))) + ))) + + (defun semantic-complete-inline-quit () + "Quit an inline edit." + (interactive) + (semantic-complete-inline-exit) + (keyboard-quit)) + + (defun semantic-complete-inline-exit () + "Exit inline completion mode." + (interactive) + ;; Remove this hook FIRST! + (remove-hook 'pre-command-hook 'semantic-complete-pre-command-hook) + + (condition-case nil + (progn + (when semantic-completion-collector-engine + (semantic-collector-cleanup semantic-completion-collector-engine)) + (when semantic-completion-display-engine + (semantic-displayor-cleanup semantic-completion-display-engine)) + + (when semantic-complete-inline-overlay + (let ((wc (semantic-overlay-get semantic-complete-inline-overlay + 'window-config-start)) + (buf (semantic-overlay-buffer semantic-complete-inline-overlay)) + ) + (semantic-overlay-delete semantic-complete-inline-overlay) + (setq semantic-complete-inline-overlay nil) + ;; DONT restore the window configuration if we just + ;; switched windows! + (when (eq buf (current-buffer)) + (set-window-configuration wc)) + )) + + (setq semantic-completion-collector-engine nil + semantic-completion-display-engine nil)) + (error nil)) + + ;; Remove this hook LAST!!! + ;; This will force us back through this function if there was + ;; some sort of error above. + (remove-hook 'post-command-hook 'semantic-complete-post-command-hook) + + ;;(message "Exiting inline completion.") + ) + + (defun semantic-complete-pre-command-hook () + "Used to redefine what commands are being run while completing. + When installed as a `pre-command-hook' the special keymap + `semantic-complete-inline-map' is queried to replace commands normally run. + Commands which edit what is in the region of interest operate normally. + Commands which would take us out of the region of interest, or our + quit hook, will exit this completion mode." + (let ((fcn (lookup-key semantic-complete-inline-map + (this-command-keys) nil))) + (cond ((commandp fcn) + (setq this-command fcn)) + (t nil))) + ) + + (defun semantic-complete-post-command-hook () + "Used to determine if we need to exit inline completion mode. + If completion mode is active, check to see if we are within + the bounds of `semantic-complete-inline-overlay', or within + a reasonable distance." + (condition-case nil + ;; Exit if something bad happened. + (if (not semantic-complete-inline-overlay) + (progn + ;;(message "Inline Hook installed, but overlay deleted.") + (semantic-complete-inline-exit)) + ;; Exit if commands caused us to exit the area of interest + (let ((s (semantic-overlay-start semantic-complete-inline-overlay)) + (e (semantic-overlay-end semantic-complete-inline-overlay)) + (b (semantic-overlay-buffer semantic-complete-inline-overlay)) + (txt nil) + ) + (cond + ;; EXIT when we are no longer in a good place. + ((or (not (eq b (current-buffer))) + (< (point) s) + (> (point) e)) + ;;(message "Exit: %S %S %S" s e (point)) + (semantic-complete-inline-exit) + ) + ;; Exit if the user typed in a character that is not part + ;; of the symbol being completed. + ((and (setq txt (semantic-completion-text)) + (not (string= txt "")) + (and (/= (point) s) + (save-excursion + (forward-char -1) + (not (looking-at "\\(\\w\\|\\s_\\)"))))) + ;;(message "Non symbol character.") + (semantic-complete-inline-exit)) + ((lookup-key semantic-complete-inline-map + (this-command-keys) nil) + ;; If the last command was one of our completion commands, + ;; then do nothing. + nil + ) + (t + ;; Else, show completions now + (semantic-complete-inline-force-display) + + )))) + ;; If something goes terribly wrong, clean up after ourselves. + (error (semantic-complete-inline-exit)))) + + (defun semantic-complete-inline-force-display () + "Force the display of whatever the current completions are. + DO NOT CALL THIS IF THE INLINE COMPLETION ENGINE IS NOT ACTIVE." + (condition-case e + (save-excursion + (let ((collector semantic-completion-collector-engine) + (displayor semantic-completion-display-engine) + (contents (semantic-completion-text))) + (when collector + (semantic-collector-calculate-completions + collector contents nil) + (semantic-displayor-set-completions + displayor + (semantic-collector-all-completions collector contents) + contents) + ;; Ask the displayor to display them. + (semantic-displayor-show-request displayor)) + )) + (error (message "Bug Showing Completions: %S" e)))) + + (defun semantic-complete-inline-tag-engine + (collector displayor buffer start end) + "Perform completion based on semantic tags in a buffer. + Argument COLLECTOR is an object which can be used to to calculate + a list of possible hits. See `semantic-completion-collector-engine' + for details on COLLECTOR. + Argumeng DISPLAYOR is an object used to display a list of possible + completions for a given prefix. See`semantic-completion-display-engine' + for details on DISPLAYOR. + BUFFER is the buffer in which completion will take place. + START is a location for the start of the full symbol. + If the symbol being completed is \"foo.ba\", then START + is on the \"f\" character. + END is at the end of the current symbol being completed." + ;; Set us up for doing completion + (setq semantic-completion-collector-engine collector + semantic-completion-display-engine displayor) + ;; Create an overlay + (setq semantic-complete-inline-overlay + (semantic-make-overlay start end buffer nil t)) + (semantic-overlay-put semantic-complete-inline-overlay + 'face + 'semantic-complete-inline-face) + (semantic-overlay-put semantic-complete-inline-overlay + 'window-config-start + (current-window-configuration)) + ;; Install our command hooks + (add-hook 'pre-command-hook 'semantic-complete-pre-command-hook) + (add-hook 'post-command-hook 'semantic-complete-post-command-hook) + ;; Go! + (semantic-complete-inline-force-display) + ) + + ;;; Inline Completion Keymap Functions + ;; + (defun semantic-complete-inline-TAB () + "Perform inline completion." + (interactive) + (let ((cmpl (semantic-complete-do-completion nil t))) + (cond + ((eq cmpl 'complete) + (semantic-complete-inline-force-display)) + ((eq cmpl 'done) + (semantic-complete-inline-done)) + )) + ) + + (defun semantic-complete-inline-down() + "Focus forwards through the displayor." + (interactive) + (let ((displayor semantic-completion-display-engine)) + (semantic-displayor-focus-next displayor) + (semantic-displayor-focus-request displayor) + )) + + (defun semantic-complete-inline-up () + "Focus backwards through the displayor." + (interactive) + (let ((displayor semantic-completion-display-engine)) + (semantic-displayor-focus-previous displayor) + (semantic-displayor-focus-request displayor) + )) + + + ;;; ------------------------------------------------------------ + ;;; Interactions between collection and displaying + ;; + ;; Functional routines used to help collectors communicate with + ;; the current displayor, or for the previous section. + + (defun semantic-complete-next-action (partial) + "Determine what the next completion action should be. + PARTIAL is non-nil if we are doing partial completion. + First, the collector can determine if we should perform a completion or not. + If there is nothing to complete, then the displayor determines if we are + to show a completion list, scroll, or perhaps do a focus (if it is capable.) + Expected return values are: + done -> We have a singular match + empty -> There are no matches to the current text + complete -> Perform a completion action + complete-whitespace -> Complete next whitespace type character. + display -> Show the list of completions + scroll -> The completions have been shown, and the user keeps hitting + the complete button. If possible, scroll the completions + focus -> The displayor knows how to shift focus among possible completions. + Let it do that. + displayend -> Whatever options the displayor had for repeating options, there + are none left. Try something new." + (let ((ans1 (semantic-collector-next-action + semantic-completion-collector-engine + partial)) + (ans2 (semantic-displayor-next-action + semantic-completion-display-engine)) + ) + (cond + ;; No collector answer, use displayor answer. + ((not ans1) + ans2) + ;; Displayor selection of 'scroll, 'display, or 'focus trumps + ;; 'done + ((and (eq ans1 'done) ans2) + ans2) + ;; Use ans1 when we have it. + (t + ans1)))) + + + + ;;; ------------------------------------------------------------ + ;;; Collection Engines + ;; + ;; Collection engines can scan tags from the current environment and + ;; provide lists of possible completions. + ;; + ;; General features of the abstract collector: + ;; * Cache completion lists between uses + ;; * Cache itself per buffer. Handle reparse hooks + ;; + ;; Key Interface Functions to implement: + ;; * semantic-collector-next-action + ;; * semantic-collector-calculate-completions + ;; * semantic-collector-try-completion + ;; * semantic-collector-all-completions + + (defvar semantic-collector-per-buffer-list nil + "List of collectors active in this buffer.") + (make-variable-buffer-local 'semantic-collector-per-buffer-list) + + (defvar semantic-collector-list nil + "List of global collectors active this session.") + + (defclass semantic-collector-abstract () + ((buffer :initarg :buffer + :type buffer + :documentation "Originating buffer for this collector. + Some collectors use a given buffer as a starting place while looking up + tags.") + (cache :initform nil + :type (or null semanticdb-find-result-with-nil) + :documentation "Cache of tags. + These tags are re-used during a completion session. + Sometimes these tags are cached between completion sessions.") + (last-all-completions :initarg nil + :type semanticdb-find-result-with-nil + :documentation "Last result of `all-completions'. + This result can be used for refined completions as `last-prefix' gets + closer to a specific result.") + (last-prefix :type string + :protection :protected + :documentation "The last queried prefix. + This prefix can be used to cache intermediate completion offers. + making the action of homing in on a token faster.") + (last-completion :type (or null string) + :documentation "The last calculated completion. + This completion is calculated and saved for future use.") + (last-whitespace-completion :type (or null string) + :documentation "The last whitespace completion. + For partial completion, SPC will disabiguate over whitespace type + characters. This is the last calculated version.") + (current-exact-match :type list + :protection :protected + :documentation "The list of matched tags. + When tokens are matched, they are added to this list.") + ) + "Root class for completion engines. + The baseclass provides basic functionality for interacting with + a completion displayor object, and tracking the current progress + of a completion." + :abstract t) + + (defmethod semantic-collector-cleanup ((obj semantic-collector-abstract)) + "Clean up any mess this collector may have." + nil) + + (defmethod semantic-collector-next-action + ((obj semantic-collector-abstract) partial) + "What should we do next? OBJ can predict a next good action. + PARTIAL indicates if we are doing a partial completion." + (if (and (slot-boundp obj 'last-completion) + (string= (semantic-completion-text) (oref obj last-completion))) + (let* ((cem (semantic-collector-current-exact-match obj)) + (cemlen (semanticdb-find-result-length cem)) + (cac (semantic-collector-all-completions + obj (semantic-completion-text))) + (caclen (semanticdb-find-result-length cac))) + (cond ((and cem (= cemlen 1) + cac (> caclen 1) + (eq last-command this-command)) + ;; Defer to the displayor... + nil) + ((and cem (= cemlen 1)) + 'done) + ((and (not cem) (not cac)) + 'empty) + ((and partial (semantic-collector-try-completion-whitespace + obj (semantic-completion-text))) + 'complete-whitespace))) + 'complete)) + + (defmethod semantic-collector-last-prefix= ((obj semantic-collector-abstract) + last-prefix) + "Return non-nil if OBJ's prefix matches PREFIX." + (and (slot-boundp obj 'last-prefix) + (string= (oref obj last-prefix) last-prefix))) + + (defmethod semantic-collector-get-cache ((obj semantic-collector-abstract)) + "Get the raw cache of tags for completion. + Calculate the cache if there isn't one." + (or (oref obj cache) + (semantic-collector-calculate-cache obj))) + + (defmethod semantic-collector-calculate-completions-raw + ((obj semantic-collector-abstract) prefix completionlist) + "Calculate the completions for prefix from completionlist. + Output must be in semanticdb Find result format." + ;; Must output in semanticdb format + (let ((table (save-excursion + (set-buffer (oref obj buffer)) + semanticdb-current-table)) + (result (semantic-find-tags-for-completion + prefix + ;; To do this kind of search with a pre-built completion + ;; list, we need to strip it first. + (semanticdb-strip-find-results completionlist))) + ) + (if result + (list (cons table result))))) + + (defmethod semantic-collector-calculate-completions + ((obj semantic-collector-abstract) prefix partial) + "Calculate completions for prefix as setup for other queries." + (let* ((case-fold-search semantic-case-fold) + (same-prefix-p (semantic-collector-last-prefix= obj prefix)) + (completionlist + (if (or same-prefix-p + (and (slot-boundp obj 'last-prefix) + (eq (compare-strings (oref obj last-prefix) 0 nil + prefix 0 (length prefix)) + t))) + ;; New prefix is subset of old prefix + (oref obj last-all-completions) + (semantic-collector-get-cache obj))) + ;; Get the result + (answer (if same-prefix-p + completionlist + (semantic-collector-calculate-completions-raw + obj prefix completionlist)) + ) + (completion nil) + (complete-not-uniq nil) + ) + ;;(semanticdb-find-result-test answer) + (when (not same-prefix-p) + ;; Save results if it is interesting and beneficial + (oset obj last-prefix prefix) + (oset obj last-all-completions answer)) + ;; Now calculate the completion. + (setq completion (try-completion + prefix + (semanticdb-strip-find-results answer))) + (oset obj last-whitespace-completion nil) + (oset obj current-exact-match nil) + ;; Only do this if a completion was found. Letting a nil in + ;; could cause a full semanticdb search by accident. + (when completion + (oset obj last-completion + (cond + ;; Unique match in AC. Last completion is a match. + ;; Also set the current-exact-match. + ((eq completion t) + (oset obj current-exact-match answer) + prefix) + ;; It may be complete (a symbol) but still not unique. + ;; We can capture a match + ((setq complete-not-uniq + (semanticdb-find-tags-by-name + prefix + answer)) + (oset obj current-exact-match + complete-not-uniq) + prefix + ) + ;; Non unique match, return the string that handles + ;; completion + (t (or completion prefix)) + ))) + )) + + (defmethod semantic-collector-try-completion-whitespace + ((obj semantic-collector-abstract) prefix) + "For OBJ, do whatepsace completion based on PREFIX. + This implies that if there are two completions, one matching + the test \"preifx\\>\", and one not, the one matching the full + word version of PREFIX will be chosen, and that text returned. + This function requires that `semantic-collector-calculate-completions' + has been run first." + (let* ((ac (semantic-collector-all-completions obj prefix)) + (matchme (concat "^" prefix "\\>")) + (compare (semanticdb-find-tags-by-name-regexp matchme ac)) + (numtag (semanticdb-find-result-length compare)) + ) + (if compare + (let* ((idx 0) + (cutlen (1+ (length prefix))) + (twws (semanticdb-find-result-nth compare idx))) + ;; Is our tag with whitespace a match that has whitespace + ;; after it, or just an already complete symbol? + (while (and (< idx numtag) + (< (length (semantic-tag-name (car twws))) cutlen)) + (setq idx (1+ idx) + twws (semanticdb-find-result-nth compare idx))) + (when (and twws (car-safe twws)) + ;; If COMPARE has succeeded, then we should take the very + ;; first match, and extend prefix by one character. + (oset obj last-whitespace-completion + (substring (semantic-tag-name (car twws)) + 0 cutlen)))) + ))) + + + (defmethod semantic-collector-current-exact-match ((obj semantic-collector-abstract)) + "Return the active valid MATCH from the semantic collector. + For now, just return the first element from our list of available + matches. For semanticdb based results, make sure the file is loaded + into a buffer." + (when (slot-boundp obj 'current-exact-match) + (oref obj current-exact-match))) + + (defmethod semantic-collector-current-whitespace-completion ((obj semantic-collector-abstract)) + "Return the active whitespace completion value." + (when (slot-boundp obj 'last-whitespace-completion) + (oref obj last-whitespace-completion))) + + (defmethod semantic-collector-get-match ((obj semantic-collector-abstract)) + "Return the active valid MATCH from the semantic collector. + For now, just return the first element from our list of available + matches. For semanticdb based results, make sure the file is loaded + into a buffer." + (when (slot-boundp obj 'current-exact-match) + (semanticdb-find-result-nth-in-buffer (oref obj current-exact-match) 0))) + + (defmethod semantic-collector-all-completions + ((obj semantic-collector-abstract) prefix) + "For OBJ, retrieve all completions matching PREFIX. + The returned list consists of all the tags currently + matching PREFIX." + (when (slot-boundp obj 'last-all-completions) + (oref obj last-all-completions))) + + (defmethod semantic-collector-try-completion + ((obj semantic-collector-abstract) prefix) + "For OBJ, attempt to match PREFIX. + See `try-completion' for details on how this works. + Return nil for no match. + Return a string for a partial match. + For a unique match of PREFIX, return the list of all tags + with that name." + (if (slot-boundp obj 'last-completion) + (oref obj last-completion))) + + (defmethod semantic-collector-calculate-cache + ((obj semantic-collector-abstract)) + "Calculate the completion cache for OBJ." + nil + ) + + (defmethod semantic-collector-flush ((this semantic-collector-abstract)) + "Flush THIS collector object, clearing any caches and prefix." + (oset this cache nil) + (slot-makeunbound this 'last-prefix) + (slot-makeunbound this 'last-completion) + (slot-makeunbound this 'last-all-completions) + (slot-makeunbound this 'current-exact-match) + ) + + ;;; PER BUFFER + ;; + (defclass semantic-collector-buffer-abstract (semantic-collector-abstract) + () + "Root class for per-buffer completion engines. + These collectors track themselves on a per-buffer basis." + :abstract t) + + (defmethod constructor :STATIC ((this semantic-collector-buffer-abstract) + newname &rest fields) + "Reuse previously created objects of this type in buffer." + (let ((old nil) + (bl semantic-collector-per-buffer-list)) + (while (and bl (null old)) + (if (eq (object-class (car bl)) this) + (setq old (car bl)))) + (unless old + (let ((new (call-next-method))) + (add-to-list 'semantic-collector-per-buffer-list new) + (setq old new))) + (slot-makeunbound old 'last-completion) + (slot-makeunbound old 'last-prefix) + (slot-makeunbound old 'current-exact-match) + old)) + + ;; Buffer specific collectors should flush themselves + (defun semantic-collector-buffer-flush (newcache) + "Flush all buffer collector objects. + NEWCACHE is the new tag table, but we ignore it." + (condition-case nil + (let ((l semantic-collector-per-buffer-list)) + (while l + (if (car l) (semantic-collector-flush (car l))) + (setq l (cdr l)))) + (error nil))) + + (add-hook 'semantic-after-toplevel-cache-change-hook + 'semantic-collector-buffer-flush) + + ;;; DEEP BUFFER SPECIFIC COMPLETION + ;; + (defclass semantic-collector-buffer-deep + (semantic-collector-buffer-abstract) + () + "Completion engine for tags in the current buffer. + When searching for a tag, uses semantic deep searche functions. + Basics search only in the current buffer.") + + (defmethod semantic-collector-calculate-cache + ((obj semantic-collector-buffer-deep)) + "Calculate the completion cache for OBJ. + Uses `semantic-flatten-tags-table'" + (oset obj cache + ;; Must create it in SEMANTICDB find format. + ;; ( ( DBTABLE TAG TAG ... ) ... ) + (list + (cons semanticdb-current-table + (semantic-flatten-tags-table (oref obj buffer)))))) + + ;;; PROJECT SPECIFIC COMPLETION + ;; + (defclass semantic-collector-project-abstract (semantic-collector-abstract) + ((path :initarg :path + :initform nil + :documentation "List of database tables to search. + At creation time, it can be anything accepted by + `semanticdb-find-translate-path' as a PATH argument.") + ) + "Root class for project wide completion engines. + Uses semanticdb for searching all tags in the current project." + :abstract t) + + ;;; Project Search + (defclass semantic-collector-project (semantic-collector-project-abstract) + () + "Completion engine for tags in a project.") + + + (defmethod semantic-collector-calculate-completions-raw + ((obj semantic-collector-project) prefix completionlist) + "Calculate the completions for prefix from completionlist." + (semanticdb-find-tags-for-completion prefix (oref obj path))) + + ;;; Brutish Project search + (defclass semantic-collector-project-brutish (semantic-collector-project-abstract) + () + "Completion engine for tags in a project.") + + (declare-function semanticdb-brute-deep-find-tags-for-completion + "semantic/db-find") + + (defmethod semantic-collector-calculate-completions-raw + ((obj semantic-collector-project-brutish) prefix completionlist) + "Calculate the completions for prefix from completionlist." + (require 'semantic/db-find) + (semanticdb-brute-deep-find-tags-for-completion prefix (oref obj path))) + + (defclass semantic-collector-analyze-completions (semantic-collector-abstract) + ((context :initarg :context + :type semantic-analyze-context + :documentation "An analysis context. + Specifies some context location from whence completion lists will be drawn." + ) + (first-pass-completions :type list + :documentation "List of valid completion tags. + This list of tags is generated when completion starts. All searches + derive from this list.") + ) + "Completion engine that uses the context analyzer to provide options. + The only options available for completion are those which can be logically + inserted into the current context.") + + (defmethod semantic-collector-calculate-completions-raw + ((obj semantic-collector-analyze-completions) prefix completionlist) + "calculate the completions for prefix from completionlist." + ;; if there are no completions yet, calculate them. + (if (not (slot-boundp obj 'first-pass-completions)) + (oset obj first-pass-completions + (semantic-analyze-possible-completions (oref obj context)))) + ;; search our cached completion list. make it look like a semanticdb + ;; results type. + (list (cons (save-excursion + (set-buffer (oref (oref obj context) buffer)) + semanticdb-current-table) + (semantic-find-tags-for-completion + prefix + (oref obj first-pass-completions))))) + + + ;;; ------------------------------------------------------------ + ;;; Tag List Display Engines + ;; + ;; A typical displayor accepts a pre-determined list of completions + ;; generated by a collector. This format is in semanticdb search + ;; form. This vaguely standard form is a bit challenging to navigate + ;; because the tags do not contain buffer info, but the file assocated + ;; with the tags preceed the tag in the list. + ;; + ;; Basic displayors don't care, and can strip the results. + ;; Advanced highlighting displayors need to know when they need + ;; to load a file so that the tag in question can be highlighted. + ;; + ;; Key interface methods to a displayor are: + ;; * semantic-displayor-next-action + ;; * semantic-displayor-set-completions + ;; * semantic-displayor-current-focus + ;; * semantic-displayor-show-request + ;; * semantic-displayor-scroll-request + ;; * semantic-displayor-focus-request + + (defclass semantic-displayor-abstract () + ((table :type (or null semanticdb-find-result-with-nil) + :initform nil + :protection :protected + :documentation "List of tags this displayor is showing.") + (last-prefix :type string + :protection :protected + :documentation "Prefix associated with slot `table'") + ) + "Abstract displayor baseclass. + Manages the display of some number of tags. + Provides the basics for a displayor, including interacting with + a collector, and tracking tables of completion to display." + :abstract t) + + (defmethod semantic-displayor-cleanup ((obj semantic-displayor-abstract)) + "Clean up any mess this displayor may have." + nil) + + (defmethod semantic-displayor-next-action ((obj semantic-displayor-abstract)) + "The next action to take on the minibuffer related to display." + (if (and (slot-boundp obj 'last-prefix) + (string= (oref obj last-prefix) (semantic-completion-text)) + (eq last-command this-command)) + 'scroll + 'display)) + + (defmethod semantic-displayor-set-completions ((obj semantic-displayor-abstract) + table prefix) + "Set the list of tags to be completed over to TABLE." + (oset obj table table) + (oset obj last-prefix prefix)) + + (defmethod semantic-displayor-show-request ((obj semantic-displayor-abstract)) + "A request to show the current tags table." + (ding)) + + (defmethod semantic-displayor-focus-request ((obj semantic-displayor-abstract)) + "A request to for the displayor to focus on some tag option." + (ding)) + + (defmethod semantic-displayor-scroll-request ((obj semantic-displayor-abstract)) + "A request to for the displayor to scroll the completion list (if needed)." + (scroll-other-window)) + + (defmethod semantic-displayor-focus-previous ((obj semantic-displayor-abstract)) + "Set the current focus to the previous item." + nil) + + (defmethod semantic-displayor-focus-next ((obj semantic-displayor-abstract)) + "Set the current focus to the next item." + nil) + + (defmethod semantic-displayor-current-focus ((obj semantic-displayor-abstract)) + "Return a single tag currently in focus. + This object type doesn't do focus, so will never have a focus object." + nil) + + ;; Traditional displayor + (defcustom semantic-completion-displayor-format-tag-function + #'semantic-format-tag-name + "*A Tag format function to use when showing completions." + :group 'semantic + :type semantic-format-tag-custom-list) + + (defclass semantic-displayor-traditional (semantic-displayor-abstract) + () + "Display options in *Completions* buffer. + Traditional display mechanism for a list of possible completions. + Completions are showin in a new buffer and listed with the ability + to click on the items to aid in completion.") + + (defmethod semantic-displayor-show-request ((obj semantic-displayor-traditional)) + "A request to show the current tags table." + + ;; NOTE TO SELF. Find the character to type next, and emphesize it. + + (with-output-to-temp-buffer "*Completions*" + (display-completion-list + (mapcar semantic-completion-displayor-format-tag-function + (semanticdb-strip-find-results (oref obj table)))) + ) + ) + + ;;; Abstract baseclass for any displayor which supports focus + (defclass semantic-displayor-focus-abstract (semantic-displayor-abstract) + ((focus :type number + :protection :protected + :documentation "A tag index from `table' which has focus. + Multiple calls to the display function can choose to focus on a + given tag, by highlighting its location.") + (find-file-focus + :allocation :class + :initform nil + :documentation + "Non-nil if focusing requires a tag's buffer be in memory.") + ) + "Abstract displayor supporting `focus'. + A displayor which has the ability to focus in on one tag. + Focusing is a way of differentiationg between multiple tags + which have the same name." + :abstract t) + + (defmethod semantic-displayor-next-action ((obj semantic-displayor-focus-abstract)) + "The next action to take on the minibuffer related to display." + (if (and (slot-boundp obj 'last-prefix) + (string= (oref obj last-prefix) (semantic-completion-text)) + (eq last-command this-command)) + (if (and + (slot-boundp obj 'focus) + (slot-boundp obj 'table) + (<= (semanticdb-find-result-length (oref obj table)) + (1+ (oref obj focus)))) + ;; We are at the end of the focus road. + 'displayend + ;; Focus on some item. + 'focus) + 'display)) + + (defmethod semantic-displayor-set-completions ((obj semantic-displayor-focus-abstract) + table prefix) + "Set the list of tags to be completed over to TABLE." + (call-next-method) + (slot-makeunbound obj 'focus)) + + (defmethod semantic-displayor-focus-previous ((obj semantic-displayor-focus-abstract)) + "Set the current focus to the previous item. + Not meaningful return value." + (when (and (slot-boundp obj 'table) (oref obj table)) + (with-slots (table) obj + (if (or (not (slot-boundp obj 'focus)) + (<= (oref obj focus) 0)) + (oset obj focus (1- (semanticdb-find-result-length table))) + (oset obj focus (1- (oref obj focus))) + ) + ))) + + (defmethod semantic-displayor-focus-next ((obj semantic-displayor-focus-abstract)) + "Set the current focus to the next item. + Not meaningful return value." + (when (and (slot-boundp obj 'table) (oref obj table)) + (with-slots (table) obj + (if (not (slot-boundp obj 'focus)) + (oset obj focus 0) + (oset obj focus (1+ (oref obj focus))) + ) + (if (<= (semanticdb-find-result-length table) (oref obj focus)) + (oset obj focus 0)) + ))) + + (defmethod semantic-displayor-focus-tag ((obj semantic-displayor-focus-abstract)) + "Return the next tag OBJ should focus on." + (when (and (slot-boundp obj 'table) (oref obj table)) + (with-slots (table) obj + (semanticdb-find-result-nth table (oref obj focus))))) + + (defmethod semantic-displayor-current-focus ((obj semantic-displayor-focus-abstract)) + "Return the tag currently in focus, or call parent method." + (if (and (slot-boundp obj 'focus) + (slot-boundp obj 'table) + ;; Only return the current focus IFF the minibuffer reflects + ;; the list this focus was derived from. + (slot-boundp obj 'last-prefix) + (string= (semantic-completion-text) (oref obj last-prefix)) + ) + ;; We need to focus + (if (oref obj find-file-focus) + (semanticdb-find-result-nth-in-buffer (oref obj table) (oref obj focus)) + ;; result-nth returns a cons with car being the tag, and cdr the + ;; database. + (car (semanticdb-find-result-nth (oref obj table) (oref obj focus)))) + ;; Do whatever + (call-next-method))) + + ;;; Simple displayor which performs traditional display completion, + ;; and also focuses with highlighting. + (defclass semantic-displayor-traditional-with-focus-highlight + (semantic-displayor-focus-abstract semantic-displayor-traditional) + ((find-file-focus :initform t)) + "Display completions in *Completions* buffer, with focus highlight. + A traditional displayor which can focus on a tag by showing it. + Same as `semantic-displayor-traditional', but with selection between + multiple tags with the same name done by 'focusing' on the source + location of the different tags to differentiate them.") + + (defmethod semantic-displayor-focus-request + ((obj semantic-displayor-traditional-with-focus-highlight)) + "Focus in on possible tag completions. + Focus is performed by cycling through the tags and highlighting + one in the source buffer." + (let* ((tablelength (semanticdb-find-result-length (oref obj table))) + (focus (semantic-displayor-focus-tag obj)) + ;; Raw tag info. + (rtag (car focus)) + (rtable (cdr focus)) + ;; Normalize + (nt (semanticdb-normalize-one-tag rtable rtag)) + (tag (cdr nt)) + (table (car nt)) + ) + ;; If we fail to normalize, resete. + (when (not tag) (setq table rtable tag rtag)) + ;; Do the focus. + (let ((buf (or (semantic-tag-buffer tag) + (and table (semanticdb-get-buffer table))))) + ;; If no buffer is provided, then we can make up a summary buffer. + (when (not buf) + (save-excursion + (set-buffer (get-buffer-create "*Completion Focus*")) + (erase-buffer) + (insert "Focus on tag: \n") + (insert (semantic-format-tag-summarize tag nil t) "\n\n") + (when table + (insert "From table: \n") + (insert (object-name table) "\n\n")) + (when buf + (insert "In buffer: \n\n") + (insert (format "%S" buf))) + (setq buf (current-buffer)))) + ;; Show the tag in the buffer. + (if (get-buffer-window buf) + (select-window (get-buffer-window buf)) + (switch-to-buffer-other-window buf t) + (select-window (get-buffer-window buf))) + ;; Now do some positioning + (unwind-protect + (if (semantic-tag-with-position-p tag) + ;; Full tag positional information available + (progn + (goto-char (semantic-tag-start tag)) + ;; This avoids a dangerous problem if we just loaded a tag + ;; from a file, but the original position was not updated + ;; in the TAG variable we are currently using. + (semantic-momentary-highlight-tag (semantic-current-tag)) + )) + (select-window (minibuffer-window))) + ;; Calculate text difference between contents and the focus item. + (let* ((mbc (semantic-completion-text)) + (ftn (semantic-tag-name tag)) + (diff (substring ftn (length mbc)))) + (semantic-completion-message + (format "%s [%d of %d matches]" diff (1+ (oref obj focus)) tablelength))) + ))) + + + ;;; Tooltip completion lister + ;; + ;; Written and contributed by Masatake YAMATO + ;; + ;; Modified by Eric Ludlam for + ;; * Safe compatibility for tooltip free systems. + ;; * Don't use 'avoid package for tooltip positioning. + + (defclass semantic-displayor-tooltip (semantic-displayor-traditional) + ((max-tags :type integer + :initarg :max-tags + :initform 5 + :custom integer + :documentation + "Max number of tags displayed on tooltip at once. + If `force-show' is 1, this value is ignored with typing tab or space twice continuously. + if `force-show' is 0, this value is always ignored.") + (force-show :type integer + :initarg :force-show + :initform 1 + :custom (choice (const + :tag "Show when double typing" + 1) + (const + :tag "Show always" + 0) + (const + :tag "Show if the number of tags is less than `max-tags'." + -1)) + :documentation + "Control the behavior of the number of tags is greater than `max-tags'. + -1 means tags are never shown. + 0 means the tags are always shown. + 1 means tags are shown if space or tab is typed twice continuously.") + (typing-count :type integer + :initform 0 + :documentation + "Counter holding how many times the user types space or tab continuously before showing tags.") + (shown :type boolean + :initform nil + :documentation + "Flag representing whether tags is shown once or not.") + ) + "Display completions options in a tooltip. + Display mechanism using tooltip for a list of possible completions.") + + (defmethod initialize-instance :AFTER ((obj semantic-displayor-tooltip) &rest args) + "Make sure we have tooltips required." + (condition-case nil + (require 'tooltip) + (error nil)) + ) + + (defmethod semantic-displayor-show-request ((obj semantic-displayor-tooltip)) + "A request to show the current tags table." + (if (or (not (featurep 'tooltip)) (not tooltip-mode)) + ;; If we cannot use tooltips, then go to the normal mode with + ;; a traditional completion buffer. + (call-next-method) + (let* ((tablelong (semanticdb-strip-find-results (oref obj table))) + (table (semantic-unique-tag-table-by-name tablelong)) + (l (mapcar semantic-completion-displayor-format-tag-function table)) + (ll (length l)) + (typing-count (oref obj typing-count)) + (force-show (oref obj force-show)) + (matchtxt (semantic-completion-text)) + msg) + (if (or (oref obj shown) + (< ll (oref obj max-tags)) + (and (<= 0 force-show) + (< (1- force-show) typing-count))) + (progn + (oset obj typing-count 0) + (oset obj shown t) + (if (eq 1 ll) + ;; We Have only one possible match. There could be two cases. + ;; 1) input text != single match. + ;; --> Show it! + ;; 2) input text == single match. + ;; --> Complain about it, but still show the match. + (if (string= matchtxt (semantic-tag-name (car table))) + (setq msg (concat "[COMPLETE]\n" (car l))) + (setq msg (car l))) + ;; Create the long message. + (setq msg (mapconcat 'identity l "\n")) + ;; If there is nothing, say so! + (if (eq 0 (length msg)) + (setq msg "[NO MATCH]"))) + (semantic-displayor-tooltip-show msg)) + ;; The typing count determines if the user REALLY REALLY + ;; wanted to show that much stuff. Only increment + ;; if the current command is a completion command. + (if (and (stringp (this-command-keys)) + (string= (this-command-keys) "\C-i")) + (oset obj typing-count (1+ typing-count))) + ;; At this point, we know we have too many items. + ;; Lets be brave, and truncate l + (setcdr (nthcdr (oref obj max-tags) l) nil) + (setq msg (mapconcat 'identity l "\n")) + (cond + ((= force-show -1) + (semantic-displayor-tooltip-show (concat msg "\n..."))) + ((= force-show 1) + (semantic-displayor-tooltip-show (concat msg "\n(TAB for more)"))) + ))))) + + ;;; Compatibility + ;; + (eval-and-compile + (if (fboundp 'window-inside-edges) + ;; Emacs devel. + (defalias 'semantic-displayor-window-edges + 'window-inside-edges) + ;; Emacs 21 + (defalias 'semantic-displayor-window-edges + 'window-edges) + )) + + (defun semantic-displayor-point-position () + "Return the location of POINT as positioned on the selected frame. + Return a cons cell (X . Y)" + (let* ((frame (selected-frame)) + (left (frame-parameter frame 'left)) + (top (frame-parameter frame 'top)) + (point-pix-pos (posn-x-y (posn-at-point))) + (edges (window-inside-pixel-edges (selected-window)))) + (cons (+ (car point-pix-pos) (car edges) left) + (+ (cdr point-pix-pos) (cadr edges) top)))) + + + (defun semantic-displayor-tooltip-show (text) + "Display a tooltip with TEXT near cursor." + (let ((point-pix-pos (semantic-displayor-point-position)) + (tooltip-frame-parameters + (append tooltip-frame-parameters nil))) + (push + (cons 'left (+ (car point-pix-pos) (frame-char-width))) + tooltip-frame-parameters) + (push + (cons 'top (+ (cdr point-pix-pos) (frame-char-height))) + tooltip-frame-parameters) + (tooltip-show text))) + + (defmethod semantic-displayor-scroll-request ((obj semantic-displayor-tooltip)) + "A request to for the displayor to scroll the completion list (if needed)." + ;; Do scrolling in the tooltip. + (oset obj max-tags 30) + (semantic-displayor-show-request obj) + ) + + ;; End code contributed by Masatake YAMATO + + + ;;; Ghost Text displayor + ;; + (defclass semantic-displayor-ghost (semantic-displayor-focus-abstract) + + ((ghostoverlay :type overlay + :documentation + "The overlay the ghost text is displayed in.") + (first-show :initform t + :documentation + "Non nil if we have not seen our first show request.") + ) + "Cycle completions inline with ghost text. + Completion displayor using ghost chars after point for focus options. + Whichever completion is currently in focus will be displayed as ghost + text using overlay options.") + + (defmethod semantic-displayor-next-action ((obj semantic-displayor-ghost)) + "The next action to take on the inline completion related to display." + (let ((ans (call-next-method)) + (table (when (slot-boundp obj 'table) + (oref obj table)))) + (if (and (eq ans 'displayend) + table + (= (semanticdb-find-result-length table) 1) + ) + nil + ans))) + + (defmethod semantic-displayor-cleanup ((obj semantic-displayor-ghost)) + "Clean up any mess this displayor may have." + (when (slot-boundp obj 'ghostoverlay) + (semantic-overlay-delete (oref obj ghostoverlay))) + ) + + (defmethod semantic-displayor-set-completions ((obj semantic-displayor-ghost) + table prefix) + "Set the list of tags to be completed over to TABLE." + (call-next-method) + + (semantic-displayor-cleanup obj) + ) + + + (defmethod semantic-displayor-show-request ((obj semantic-displayor-ghost)) + "A request to show the current tags table." + ; (if (oref obj first-show) + ; (progn + ; (oset obj first-show nil) + (semantic-displayor-focus-next obj) + (semantic-displayor-focus-request obj) + ; ) + ;; Only do the traditional thing if the first show request + ;; has been seen. Use the first one to start doing the ghost + ;; text display. + ; (call-next-method) + ; ) + ) + + (defmethod semantic-displayor-focus-request + ((obj semantic-displayor-ghost)) + "Focus in on possible tag completions. + Focus is performed by cycling through the tags and showing a possible + completion text in ghost text." + (let* ((tablelength (semanticdb-find-result-length (oref obj table))) + (focus (semantic-displayor-focus-tag obj)) + (tag (car focus)) + ) + (if (not tag) + (semantic-completion-message "No tags to focus on.") + ;; Display the focus completion as ghost text after the current + ;; inline text. + (when (or (not (slot-boundp obj 'ghostoverlay)) + (not (semantic-overlay-live-p (oref obj ghostoverlay)))) + (oset obj ghostoverlay + (semantic-make-overlay (point) (1+ (point)) (current-buffer) t))) + + (let* ((lp (semantic-completion-text)) + (os (substring (semantic-tag-name tag) (length lp))) + (ol (oref obj ghostoverlay)) + ) + + (put-text-property 0 (length os) 'face 'region os) + + (semantic-overlay-put + ol 'display (concat os (buffer-substring (point) (1+ (point))))) + ) + ;; Calculate text difference between contents and the focus item. + (let* ((mbc (semantic-completion-text)) + (ftn (concat (semantic-tag-name tag))) + ) + (put-text-property (length mbc) (length ftn) 'face + 'bold ftn) + (semantic-completion-message + (format "%s [%d of %d matches]" ftn (1+ (oref obj focus)) tablelength))) + ))) + + + ;;; ------------------------------------------------------------ + ;;; Specific queries + ;; + (defvar semantic-complete-inline-custom-type + (append '(radio) + (mapcar + (lambda (class) + (let* ((C (intern (car class))) + (doc (documentation-property C 'variable-documentation)) + (doc1 (car (split-string doc "\n"))) + ) + (list 'const + :tag doc1 + C))) + (eieio-build-class-alist semantic-displayor-abstract t)) + ) + "Possible options for inlince completion displayors. + Use this to enable custom editing.") + + (defcustom semantic-complete-inline-analyzer-displayor-class + 'semantic-displayor-traditional + "*Class for displayor to use with inline completion." + :group 'semantic + :type semantic-complete-inline-custom-type + ) + + (defun semantic-complete-read-tag-buffer-deep (prompt &optional + default-tag + initial-input + history) + "Ask for a tag by name from the current buffer. + Available tags are from the current buffer, at any level. + Completion options are presented in a traditional way, with highlighting + to resolve same-name collisions. + PROMPT is a string to prompt with. + DEFAULT-TAG is a semantic tag or string to use as the default value. + If INITIAL-INPUT is non-nil, insert it in the minibuffer initially. + HISTORY is a symbol representing a variable to store the history in." + (semantic-complete-read-tag-engine + (semantic-collector-buffer-deep prompt :buffer (current-buffer)) + (semantic-displayor-traditional-with-focus-highlight "simple") + ;;(semantic-displayor-tooltip "simple") + prompt + default-tag + initial-input + history) + ) + + (defun semantic-complete-read-tag-project (prompt &optional + default-tag + initial-input + history) + "Ask for a tag by name from the current project. + Available tags are from the current project, at the top level. + Completion options are presented in a traditional way, with highlighting + to resolve same-name collisions. + PROMPT is a string to prompt with. + DEFAULT-TAG is a semantic tag or string to use as the default value. + If INITIAL-INPUT is non-nil, insert it in the minibuffer initially. + HISTORY is a symbol representing a variable to store the history in." + (semantic-complete-read-tag-engine + (semantic-collector-project-brutish prompt + :buffer (current-buffer) + :path (current-buffer) + ) + (semantic-displayor-traditional-with-focus-highlight "simple") + prompt + default-tag + initial-input + history) + ) + + (defun semantic-complete-inline-tag-project () + "Complete a symbol name by name from within the current project. + This is similar to `semantic-complete-read-tag-project', except + that the completion interaction is in the buffer where the context + was calculated from. + Customize `semantic-complete-inline-analyzer-displayor-class' + to control how completion options are displayed. + See `semantic-complete-inline-tag-engine' for details on how + completion works." + (let* ((collector (semantic-collector-project-brutish + "inline" + :buffer (current-buffer) + :path (current-buffer))) + (sbounds (semantic-ctxt-current-symbol-and-bounds)) + (syms (car sbounds)) + (start (car (nth 2 sbounds))) + (end (cdr (nth 2 sbounds))) + (rsym (reverse syms)) + (thissym (nth 1 sbounds)) + (nextsym (car-safe (cdr rsym))) + (complst nil)) + (when (and thissym (or (not (string= thissym "")) + nextsym)) + ;; Do a quick calcuation of completions. + (semantic-collector-calculate-completions + collector thissym nil) + ;; Get the master list + (setq complst (semanticdb-strip-find-results + (semantic-collector-all-completions collector thissym))) + ;; Shorten by name + (setq complst (semantic-unique-tag-table-by-name complst)) + (if (or (and (= (length complst) 1) + ;; Check to see if it is the same as what is there. + ;; if so, we can offer to complete. + (let ((compname (semantic-tag-name (car complst)))) + (not (string= compname thissym)))) + (> (length complst) 1)) + ;; There are several options. Do the completion. + (semantic-complete-inline-tag-engine + collector + (funcall semantic-complete-inline-analyzer-displayor-class + "inline displayor") + ;;(semantic-displayor-tooltip "simple") + (current-buffer) + start end)) + ))) + + (defun semantic-complete-read-tag-analyzer (prompt &optional + context + history) + "Ask for a tag by name based on the current context. + The function `semantic-analyze-current-context' is used to + calculate the context. `semantic-analyze-possible-completions' is used + to generate the list of possible completions. + PROMPT is the first part of the prompt. Additional prompt + is added based on the contexts full prefix. + CONTEXT is the semantic analyzer context to start with. + HISTORY is a symbol representing a variable to stor the history in. + usually a default-tag and initial-input are available for completion + prompts. these are calculated from the CONTEXT variable passed in." + (if (not context) (setq context (semantic-analyze-current-context (point)))) + (let* ((syms (semantic-ctxt-current-symbol (point))) + (inp (car (reverse syms)))) + (setq syms (nreverse (cdr (nreverse syms)))) + (semantic-complete-read-tag-engine + (semantic-collector-analyze-completions + prompt + :buffer (oref context buffer) + :context context) + (semantic-displayor-traditional-with-focus-highlight "simple") + (save-excursion + (set-buffer (oref context buffer)) + (goto-char (cdr (oref context bounds))) + (concat prompt (mapconcat 'identity syms ".") + (if syms "." "") + )) + nil + inp + history))) + + (defun semantic-complete-inline-analyzer (context) + "Complete a symbol name by name based on the current context. + This is similar to `semantic-complete-read-tag-analyze', except + that the completion interaction is in the buffer where the context + was calculated from. + CONTEXT is the semantic analyzer context to start with. + Customize `semantic-complete-inline-analyzer-displayor-class' + to control how completion options are displayed. + + See `semantic-complete-inline-tag-engine' for details on how + completion works." + (if (not context) (setq context (semantic-analyze-current-context (point)))) + (if (not context) (error "Nothing to complete on here")) + (let* ((collector (semantic-collector-analyze-completions + "inline" + :buffer (oref context buffer) + :context context)) + (syms (semantic-ctxt-current-symbol (point))) + (rsym (reverse syms)) + (thissym (car rsym)) + (nextsym (car-safe (cdr rsym))) + (complst nil)) + (when (and thissym (or (not (string= thissym "")) + nextsym)) + ;; Do a quick calcuation of completions. + (semantic-collector-calculate-completions + collector thissym nil) + ;; Get the master list + (setq complst (semanticdb-strip-find-results + (semantic-collector-all-completions collector thissym))) + ;; Shorten by name + (setq complst (semantic-unique-tag-table-by-name complst)) + (if (or (and (= (length complst) 1) + ;; Check to see if it is the same as what is there. + ;; if so, we can offer to complete. + (let ((compname (semantic-tag-name (car complst)))) + (not (string= compname thissym)))) + (> (length complst) 1)) + ;; There are several options. Do the completion. + (semantic-complete-inline-tag-engine + collector + (funcall semantic-complete-inline-analyzer-displayor-class + "inline displayor") + ;;(semantic-displayor-tooltip "simple") + (oref context buffer) + (car (oref context bounds)) + (cdr (oref context bounds)) + )) + ))) + + (defcustom semantic-complete-inline-analyzer-idle-displayor-class + 'semantic-displayor-ghost + "*Class for displayor to use with inline completion at idle time." + :group 'semantic + :type semantic-complete-inline-custom-type + ) + + (defun semantic-complete-inline-analyzer-idle (context) + "Complete a symbol name by name based on the current context for idle time. + CONTEXT is the semantic analyzer context to start with. + This function is used from `semantic-idle-completions-mode'. + + This is the same as `semantic-complete-inline-analyzer', except that + it uses `semantic-complete-inline-analyzer-idle-displayor-class' + to control how completions are displayed. + + See `semantic-complete-inline-tag-engine' for details on how + completion works." + (let ((semantic-complete-inline-analyzer-displayor-class + semantic-complete-inline-analyzer-idle-displayor-class)) + (semantic-complete-inline-analyzer context) + )) + + + ;;;###autoload + (defun semantic-complete-jump-local () + "Jump to a semantic symbol." + (interactive) + (let ((tag (semantic-complete-read-tag-buffer-deep "Symbol: "))) + (when (semantic-tag-p tag) + (push-mark) + (goto-char (semantic-tag-start tag)) + (semantic-momentary-highlight-tag tag) + (message "%S: %s " + (semantic-tag-class tag) + (semantic-tag-name tag))))) + + ;;;###autoload + (defun semantic-complete-jump () + "Jump to a semantic symbol." + (interactive) + (let* ((tag (semantic-complete-read-tag-project "Symbol: "))) + (when (semantic-tag-p tag) + (push-mark) + (semantic-go-to-tag tag) + (switch-to-buffer (current-buffer)) + (semantic-momentary-highlight-tag tag) + (message "%S: %s " + (semantic-tag-class tag) + (semantic-tag-name tag))))) + + ;;;###autoload + (defun semantic-complete-analyze-and-replace () + "Perform prompt completion to do in buffer completion. + `semantic-analyze-possible-completions' is used to determine the + possible values. + The minibuffer is used to perform the completion. + The result is inserted as a replacement of the text that was there." + (interactive) + (let* ((c (semantic-analyze-current-context (point))) + (tag (save-excursion (semantic-complete-read-tag-analyzer "" c)))) + ;; Take tag, and replace context bound with its name. + (goto-char (car (oref c bounds))) + (delete-region (point) (cdr (oref c bounds))) + (insert (semantic-tag-name tag)) + (message "%S" (semantic-format-tag-summarize tag)))) + + ;;;###autoload + (defun semantic-complete-analyze-inline () + "Perform prompt completion to do in buffer completion. + `semantic-analyze-possible-completions' is used to determine the + possible values. + The function returns immediately, leaving the buffer in a mode that + will perform the completion. + Configure `semantic-complete-inline-analyzer-displayor-class' to change + how completion options are displayed." + (interactive) + ;; Only do this if we are not already completing something. + (if (not (semantic-completion-inline-active-p)) + (semantic-complete-inline-analyzer + (semantic-analyze-current-context (point)))) + ;; Report a message if things didn't startup. + (if (and (interactive-p) + (not (semantic-completion-inline-active-p))) + (message "Inline completion not needed.") + ;; Since this is most likely bound to something, and not used + ;; at idle time, throw in a TAB for good measure. + (semantic-complete-inline-TAB) + )) + + ;;;###autoload + (defun semantic-complete-analyze-inline-idle () + "Perform prompt completion to do in buffer completion. + `semantic-analyze-possible-completions' is used to determine the + possible values. + The function returns immediately, leaving the buffer in a mode that + will perform the completion. + Configure `semantic-complete-inline-analyzer-idle-displayor-class' + to change how completion options are displayed." + (interactive) + ;; Only do this if we are not already completing something. + (if (not (semantic-completion-inline-active-p)) + (semantic-complete-inline-analyzer-idle + (semantic-analyze-current-context (point)))) + ;; Report a message if things didn't startup. + (if (and (interactive-p) + (not (semantic-completion-inline-active-p))) + (message "Inline completion not needed.")) + ) + + ;;;###autoload + (defun semantic-complete-self-insert (arg) + "Like `self-insert-command', but does completion afterwards. + ARG is passed to `self-insert-command'. If ARG is nil, + use `semantic-complete-analyze-inline' to complete." + (interactive "p") + ;; If we are already in a completion scenario, exit now, and then start over. + (semantic-complete-inline-exit) + + ;; Insert the key + (self-insert-command arg) + + ;; Prepare for doing completion, but exit quickly if there is keyboard + ;; input. + (when (and (not (semantic-exit-on-input 'csi + (semantic-fetch-tags) + (semantic-throw-on-input 'csi) + nil)) + (= arg 1) + (not (semantic-exit-on-input 'csi + (semantic-analyze-current-context) + (semantic-throw-on-input 'csi) + nil))) + (condition-case nil + (semantic-complete-analyze-inline) + ;; Ignore errors. Seems likely that we'll get some once in a while. + (error nil)) + )) + -;; @TODO - I can't find where this fcn is used. Delete? - -;;;;###autoload -;(defun semantic-complete-inline-project () -; "Perform inline completion for any symbol in the current project. -;`semantic-analyze-possible-completions' is used to determine the -;possible values. -;The function returns immediately, leaving the buffer in a mode that -;will perform the completion." -; (interactive) -; ;; Only do this if we are not already completing something. -; (if (not (semantic-completion-inline-active-p)) -; (semantic-complete-inline-tag-project)) -; ;; Report a message if things didn't startup. -; (if (and (interactive-p) -; (not (semantic-completion-inline-active-p))) -; (message "Inline completion not needed.")) -; ) - -;; End + (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 --cc lisp/cedet/semantic/db-ebrowse.el index 00000000000,6101f3a8b66..8c6237f542c mode 000000,100644..100644 --- a/lisp/cedet/semantic/db-ebrowse.el +++ b/lisp/cedet/semantic/db-ebrowse.el @@@ -1,0 -1,671 +1,666 @@@ + ;;; semantic/db-ebrowse.el --- Semanticdb backend using ebrowse. + + ;;; Copyright (C) 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. + + ;; Authors: Eric M. Ludlam , Joakim Verona + ;; Keywords: tags + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; + ;; This program was started by Eric Ludlam, and Joakim Verona finished + ;; the implementation by adding searches and fixing bugs. + ;; + ;; Read in custom-created ebrowse BROWSE files into a semanticdb back + ;; end. + ;; + ;; Add these databases to the 'system' search. + ;; Possibly use ebrowse for local parsing too. + ;; + ;; When real details are needed out of the tag system from ebrowse, + ;; we will need to delve into the originating source and parse those + ;; files the usual way. + ;; + ;; COMMANDS: + ;; `semanticdb-create-ebrowse-database' - Call EBROWSE to create a + ;; system database for some directory. In general, use this for + ;; system libraries, such as /usr/include, or include directories + ;; large software projects. + ;; Customize `semanticdb-ebrowse-file-match' to make sure the correct + ;; file extensions are matched. + ;; + ;; `semanticdb-load-ebrowse-caches' - Load all the EBROWSE caches from + ;; your semanticdb system database directory. Once they are + ;; loaded, they become searchable as omnipotent databases for + ;; all C++ files. This is called automatically by semantic-load. + ;; Call it a second time to refresh the Emacs DB with the file. + ;; + ++(require 'ebrowse) ++(require 'semantic) ++(require 'semantic/db-file) ++ + (eval-when-compile + ;; For generic function searching. + (require 'eieio) + (require 'eieio-opt) - ) -(require 'semantic/db-file) -(require 'semantic/find) ++ (require 'semantic/find)) + + (declare-function semantic-add-system-include "semantic/dep") + -(eval-and-compile - ;; Hopefully, this will allow semanticdb-ebrowse to compile under - ;; XEmacs, it just won't run if a user attempts to use it. - (condition-case nil - (require 'ebrowse) - (error nil))) - + ;;; Code: + (defvar semanticdb-ebrowse-default-file-name "BROWSE" + "The EBROWSE file name used for system caches.") + + (defcustom semanticdb-ebrowse-file-match "\\.\\(hh?\\|HH?\\|hpp\\)" + "Regular expression matching file names for ebrowse to parse. + This expression should exclude C++ headers that have no extension. + By default, include only headers since the semantic use of EBrowse + is only for searching via semanticdb, and thus only headers would + be searched." + :group 'semanticdb + :type 'string) + + ;;; SEMANTIC Database related Code + ;;; Classes: + (defclass semanticdb-table-ebrowse (semanticdb-table) + ((major-mode :initform c++-mode) + (ebrowse-tree :initform nil + :initarg :ebrowse-tree + :documentation + "The raw ebrowse tree for this file." + ) + (global-extract :initform nil + :initarg :global-extract + :documentation + "Table of ebrowse tags specific to this file. + This table is compisited from the ebrowse *Globals* section.") + ) + "A table for returning search results from ebrowse.") + + (defclass semanticdb-project-database-ebrowse + (semanticdb-project-database) + ((new-table-class :initform semanticdb-table-ebrowse + :type class + :documentation + "New tables created for this database are of this class.") + (system-include-p :initform nil + :initarg :system-include + :documentation + "Flag indicating this database represents a system include directory.") + (ebrowse-struct :initform nil + :initarg :ebrowse-struct + ) + ) + "Semantic Database deriving tags using the EBROWSE tool. + EBROWSE is a C/C++ parser for use with `ebrowse' Emacs program.") + + + (defun semanticdb-ebrowse-C-file-p (file) + "Is FILE a C or C++ file?" + (or (string-match semanticdb-ebrowse-file-match file) + (and (string-match "/\\w+$" file) + (not (file-directory-p file)) + (let ((tmp (get-buffer-create "*semanticdb-ebrowse-tmp*"))) + (save-excursion + (set-buffer tmp) + (condition-case nil + (insert-file-contents file nil 0 100 t) + (error (insert-file-contents file nil nil nil t))) + (goto-char (point-min)) + (looking-at "\\s-*/\\(\\*\\|/\\)") + )) + ))) + + (defun semanticdb-create-ebrowse-database (dir) + "Create an EBROSE database for directory DIR. + The database file is stored in ~/.semanticdb, or whichever directory + is specified by `semanticdb-default-save-directory'." + (interactive "DDirectory: ") + (setq dir (file-name-as-directory dir)) ;; for / on end + (let* ((savein (semanticdb-ebrowse-file-for-directory dir)) + (filebuff (get-buffer-create "*SEMANTICDB EBROWSE TMP*")) + (files (directory-files (expand-file-name dir) t)) + (mma auto-mode-alist) + (regexp nil) + ) + ;; Create the input to the ebrowse command + (save-excursion + (set-buffer filebuff) + (buffer-disable-undo filebuff) + (setq default-directory (expand-file-name dir)) + + ;;; @TODO - convert to use semanticdb-collect-matching-filenames + ;; to get the file names. + + + (mapc (lambda (f) + (when (semanticdb-ebrowse-C-file-p f) + (insert f) + (insert "\n"))) + files) + ;; Cleanup the ebrowse output buffer. + (save-excursion + (set-buffer (get-buffer-create "*EBROWSE OUTPUT*")) + (erase-buffer)) + ;; Call the EBROWSE command. + (message "Creating ebrowse file: %s ..." savein) + (call-process-region (point-min) (point-max) + "ebrowse" nil "*EBROWSE OUTPUT*" nil + (concat "--output-file=" savein) + "--very-verbose") + ) + ;; Create a short LOADER program for loading in this database. + (let* ((lfn (concat savein "-load.el")) + (lf (find-file-noselect lfn))) + (save-excursion + (set-buffer lf) + (erase-buffer) + (insert "(semanticdb-ebrowse-load-helper \"" + (expand-file-name dir) + "\")\n") + (save-buffer) + (kill-buffer (current-buffer))) + (message "Creating ebrowse file: %s ... done" savein) + ;; Reload that database + (load lfn nil t) + ))) + + (defun semanticdb-load-ebrowse-caches () + "Load all semanticdb controlled EBROWSE caches." + (interactive) + (let ((f (directory-files semanticdb-default-save-directory + t (concat semanticdb-ebrowse-default-file-name "-load.el$") t))) + (while f + (load (car f) nil t) + (setq f (cdr f))) + )) + + (defun semanticdb-ebrowse-load-helper (directory) + "Create the semanticdb database via ebrowse for directory. + If DIRECTORY is found to be defunct, it won't load the DB, and will + warn instead." + (if (file-directory-p directory) + (semanticdb-create-database semanticdb-project-database-ebrowse + directory) + (let* ((BF (semanticdb-ebrowse-file-for-directory directory)) + (BFL (concat BF "-load.el")) + (BFLB (concat BF "-load.el~"))) + (save-window-excursion + (with-output-to-temp-buffer "*FILES TO DELETE*" + (princ "The following BROWSE files are obsolete.\n\n") + (princ BF) + (princ "\n") + (princ BFL) + (princ "\n") + (when (file-exists-p BFLB) + (princ BFLB) + (princ "\n")) + ) + (when (y-or-n-p (format + "Warning: Obsolete BROWSE file for: %s\nDelete? " + directory)) + (delete-file BF) + (delete-file BFL) + (when (file-exists-p BFLB) + (delete-file BFLB)) + ))))) + + ;JAVE this just instantiates a default empty ebrowse struct? + ; how would new instances wind up here? + ; the ebrowse class isnt singleton, unlike the emacs lisp one + (defvar-mode-local c++-mode semanticdb-project-system-databases + () + "Search Ebrowse for symbols.") + + (defmethod semanticdb-needs-refresh-p ((table semanticdb-table-ebrowse)) + "EBROWSE database do not need to be refreshed. + + JAVE: stub for needs-refresh, because, how do we know if BROWSE files + are out of date? + + EML: Our database should probably remember the timestamp/checksum of + the most recently read EBROWSE file, and use that." + nil + ) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + + ;;; EBROWSE code + ;; + ;; These routines deal with part of the ebrowse interface. + (defun semanticdb-ebrowse-file-for-directory (dir) + "Return the file name for DIR where the ebrowse BROWSE file is. + This file should reside in `semanticdb-default-save-directory'." + (let* ((semanticdb-default-save-directory + semanticdb-default-save-directory) + (B (semanticdb-file-name-directory + 'semanticdb-project-database-file + (concat (expand-file-name dir) + semanticdb-ebrowse-default-file-name))) + ) + B)) + + (defun semanticdb-ebrowse-get-ebrowse-structure (dir) + "Return the ebrowse structure for directory DIR. + This assumes semantic manages the BROWSE files, so they are assumed to live + where semantic cache files live, depending on your settings. + + For instance: /home//.semanticdb/!usr!include!BROWSE" + (let* ((B (semanticdb-ebrowse-file-for-directory dir)) + (buf (get-buffer-create "*semanticdb ebrowse*"))) + (message "semanticdb-ebrowse %s" B) + (when (file-exists-p B) + (set-buffer buf) + (buffer-disable-undo buf) + (erase-buffer) + (insert-file-contents B) + (let ((ans nil) + (efcn (symbol-function 'ebrowse-show-progress))) + (fset 'ebrowse-show-progress #'(lambda (&rest junk) nil)) + (unwind-protect ;; Protect against errors w/ ebrowse + (setq ans (list B (ebrowse-read))) + ;; These items must always happen + (erase-buffer) + (fset 'ebrowse-show-fcn efcn) + ) + ans)))) + + ;;; Methods for creating a database or tables + ;; + (defmethod semanticdb-create-database :STATIC ((dbeC semanticdb-project-database-ebrowse) + directory) + "Create a new semantic database for DIRECTORY based on ebrowse. + If there is no database for DIRECTORY available, then + {not implemented yet} create one. Return nil if that is not possible." + ;; MAKE SURE THAT THE FILE LOADED DOESN'T ALREADY EXIST. + (require 'semantic/dep) + (let ((dbs semanticdb-database-list) + (found nil)) + (while (and (not found) dbs) + (when (semanticdb-project-database-ebrowse-p (car dbs)) + (when (string= (oref (car dbs) reference-directory) directory) + (setq found (car dbs)))) + (setq dbs (cdr dbs))) + ;;STATIC means DBE cant be used as object, only as a class + (let* ((ebrowse-data (semanticdb-ebrowse-get-ebrowse-structure directory)) + (dat (car (cdr ebrowse-data))) + (ebd (car dat)) + (db nil) + (default-directory directory) + ) + (if found + (setq db found) + (setq db (make-instance + dbeC + directory + :ebrowse-struct ebd + )) + (oset db reference-directory directory)) + + ;; Once we recycle or make a new DB, refresh the + ;; contents from the BROWSE file. + (oset db tables nil) + ;; only possible after object creation, tables inited to nil. + (semanticdb-ebrowse-strip-trees db dat) + + ;; Once our database is loaded, if we are a system DB, we + ;; add ourselves to the include list for C++. + (semantic-add-system-include directory 'c++-mode) + (semantic-add-system-include directory 'c-mode) + + db))) + + (defmethod semanticdb-ebrowse-strip-trees ((dbe semanticdb-project-database-ebrowse) + data) + "For the ebrowse database DBE, strip all tables from DATA." + ;JAVE what it actually seems to do is split the original tree in "tables" associated with files + ; im not sure it actually works: + ; the filename slot sometimes gets to be nil, + ; apparently for classes which definition cant be found, yet needs to be included in the tree + ; like library baseclasses + ; a file can define several classes + (let ((T (car (cdr data))));1st comes a header, then the tree + (while T + + (let* ((tree (car T)) + (class (ebrowse-ts-class tree)); root class of tree + ;; Something funny going on with this file thing... + (filename (or (ebrowse-cs-source-file class) + (ebrowse-cs-file class))) + ) + (cond + ((ebrowse-globals-tree-p tree) + ;; We have the globals tree.. save this special. + (semanticdb-ebrowse-add-globals-to-table dbe tree) + ) + (t + ;; ebrowse will collect all the info from multiple files + ;; into one tree. Semantic wants all the bits to be tied + ;; into different files. We need to do a full dissociation + ;; into semantic parsable tables. + (semanticdb-ebrowse-add-tree-to-table dbe tree) + )) + (setq T (cdr T)))) + )) + + ;;; Filename based methods + ;; + (defun semanticdb-ebrowse-add-globals-to-table (dbe tree) + "For database DBE, add the ebrowse TREE into the table." + (if (or (not (ebrowse-ts-p tree)) + (not (ebrowse-globals-tree-p tree))) + (signal 'wrong-type-argument (list 'ebrowse-ts-p tree))) + + (let* ((class (ebrowse-ts-class tree)) + (fname (or (ebrowse-cs-source-file class) + (ebrowse-cs-file class) + ;; Not def'd here, assume our current + ;; file + (concat default-directory "/unknown-proxy.hh"))) + (vars (ebrowse-ts-member-functions tree)) + (fns (ebrowse-ts-member-variables tree)) + (toks nil) + ) + (while vars + (let ((nt (semantic-tag (ebrowse-ms-name (car vars)) + 'variable)) + (defpoint (ebrowse-bs-point class))) + (when defpoint + (semantic--tag-set-overlay nt + (vector defpoint defpoint))) + (setq toks (cons nt toks))) + (setq vars (cdr vars))) + (while fns + (let ((nt (semantic-tag (ebrowse-ms-name (car fns)) + 'function)) + (defpoint (ebrowse-bs-point class))) + (when defpoint + (semantic--tag-set-overlay nt + (vector defpoint defpoint))) + (setq toks (cons nt toks))) + (setq fns (cdr fns))) + + )) + + (defun semanticdb-ebrowse-add-tree-to-table (dbe tree &optional fname baseclasses) + "For database DBE, add the ebrowse TREE into the table for FNAME. + Optional argument BASECLASSES specifyies a baseclass to the tree being provided." + (if (not (ebrowse-ts-p tree)) + (signal 'wrong-type-argument (list 'ebrowse-ts-p tree))) + + ;; Strategy overview: + ;; 1) Calculate the filename for this tree. + ;; 2) Find a matching namespace in TAB, or create a new one. + ;; 3) Fabricate a tag proxy for CLASS + ;; 4) Add it to the namespace + ;; 5) Add subclasses + + ;; 1 - Find the filename + (if (not fname) + (setq fname (or (ebrowse-cs-source-file (ebrowse-ts-class tree)) + (ebrowse-cs-file (ebrowse-ts-class tree)) + ;; Not def'd here, assume our current + ;; file + (concat default-directory "/unknown-proxy.hh")))) + + (let* ((tab (or (semanticdb-file-table dbe fname) + (semanticdb-create-table dbe fname))) + (class (ebrowse-ts-class tree)) + (scope (ebrowse-cs-scope class)) + (ns (when scope (split-string scope ":" t))) + (nst nil) + (cls nil) + ) + + ;; 2 - Get the namespace tag + (when ns + (let ((taglst (if (slot-boundp tab 'tags) (oref tab tags) nil))) + (setq nst (semantic-find-first-tag-by-name (car ns) taglst)) + (when (not nst) + (setq nst (semantic-tag (car ns) 'type :type "namespace")) + (oset tab tags (cons nst taglst)) + ))) + + ;; 3 - Create a proxy tg. + (setq cls (semantic-tag (ebrowse-cs-name class) + 'type + :type "class" + :superclasses baseclasses + :faux t + :filename fname + )) + (let ((defpoint (ebrowse-bs-point class))) + (when defpoint + (semantic--tag-set-overlay cls + (vector defpoint defpoint)))) + + ;; 4 - add to namespace + (if nst + (semantic-tag-put-attribute + nst :members (cons cls (semantic-tag-get-attribute nst :members))) + (oset tab tags (cons cls (when (slot-boundp tab 'tags) + (oref tab tags))))) + + ;; 5 - Subclasses + (let* ((subclass (ebrowse-ts-subclasses tree)) + (pname (ebrowse-cs-name class))) + (when (ebrowse-cs-scope class) + (setq pname (concat (mapconcat (lambda (a) a) (cdr ns) "::") "::" pname))) + + (while subclass + (let* ((scc (ebrowse-ts-class (car subclass))) + (fname (or (ebrowse-cs-source-file scc) + (ebrowse-cs-file scc) + ;; Not def'd here, assume our current + ;; file + fname + ))) + (when fname + (semanticdb-ebrowse-add-tree-to-table + dbe (car subclass) fname pname))) + (setq subclass (cdr subclass)))) + )) + + ;;; + ;; Overload for converting the simple faux tag into something better. + ;; + (defmethod semanticdb-normalize-tags ((obj semanticdb-table-ebrowse) tags) + "Convert in Ebrowse database OBJ a list of TAGS into a complete tag. + The default tag provided by searches exclude many features of a + semantic parsed tag. Look up the file for OBJ, and match TAGS + against a semantic parsed tag that has all the info needed, and + return that." + (let ((tagret nil) + ) + ;; SemanticDB will automatically create a regular database + ;; on top of the file just loaded by ebrowse during the set + ;; buffer. Fetch that table, and use it's tag list to look + ;; up the tag we just got, and thus turn it into a full semantic + ;; tag. + (while tags + (let ((tag (car tags))) + (save-excursion + (semanticdb-set-buffer obj) + (let ((ans nil)) + ;; Gee, it would be nice to do this, but ebrowse LIES. Oi. + (when (semantic-tag-with-position-p tag) + (goto-char (semantic-tag-start tag)) + (let ((foundtag (semantic-current-tag))) + ;; Make sure the discovered tag is the same as what we started with. + (when (string= (semantic-tag-name tag) + (semantic-tag-name foundtag)) + ;; We have a winner! + (setq ans foundtag)))) + ;; Sometimes ebrowse lies. Do a generic search + ;; to find it within this file. + (when (not ans) + ;; We might find multiple hits for this tag, and we have no way + ;; of knowing which one the user wanted. Return the first one. + (setq ans (semantic-deep-find-tags-by-name + (semantic-tag-name tag) + (semantic-fetch-tags)))) + (if (semantic-tag-p ans) + (setq tagret (cons ans tagret)) + (setq tagret (append ans tagret))) + )) + (setq tags (cdr tags)))) + tagret)) + + (defmethod semanticdb-normalize-one-tag ((obj semanticdb-table-ebrowse) tag) + "Convert in Ebrowse database OBJ one TAG into a complete tag. + The default tag provided by searches exclude many features of a + semantic parsed tag. Look up the file for OBJ, and match TAG + against a semantic parsed tag that has all the info needed, and + return that." + (let ((tagret nil) + (objret nil)) + ;; SemanticDB will automatically create a regular database + ;; on top of the file just loaded by ebrowse during the set + ;; buffer. Fetch that table, and use it's tag list to look + ;; up the tag we just got, and thus turn it into a full semantic + ;; tag. + (save-excursion + (semanticdb-set-buffer obj) + (setq objret semanticdb-current-table) + (when (not objret) + ;; What to do?? + (debug)) + (let ((ans nil)) + ;; Gee, it would be nice to do this, but ebrowse LIES. Oi. + (when (semantic-tag-with-position-p tag) + (goto-char (semantic-tag-start tag)) + (let ((foundtag (semantic-current-tag))) + ;; Make sure the discovered tag is the same as what we started with. + (when (string= (semantic-tag-name tag) + (semantic-tag-name foundtag)) + ;; We have a winner! + (setq ans foundtag)))) + ;; Sometimes ebrowse lies. Do a generic search + ;; to find it within this file. + (when (not ans) + ;; We might find multiple hits for this tag, and we have no way + ;; of knowing which one the user wanted. Return the first one. + (setq ans (semantic-deep-find-tags-by-name + (semantic-tag-name tag) + (semantic-fetch-tags)))) + (if (semantic-tag-p ans) + (setq tagret ans) + (setq tagret (car ans))) + )) + (cons objret tagret))) + + ;;; Search Overrides + ;; + ;; NOTE WHEN IMPLEMENTING: Be sure to add doc-string updates explaining + ;; how your new search routines are implemented. + ;; + (defmethod semanticdb-find-tags-by-name-method + ((table semanticdb-table-ebrowse) name &optional tags) + "Find all tags named NAME in TABLE. + Return a list of tags." + ;;(message "semanticdb-find-tags-by-name-method name -- %s" name) + (if tags + ;; If TAGS are passed in, then we don't need to do work here. + (call-next-method) + ;; If we ever need to do something special, add here. + ;; Since ebrowse tags are converted into semantic tags, we can + ;; get away with this sort of thing. + (call-next-method) + ) + ) + + (defmethod semanticdb-find-tags-by-name-regexp-method + ((table semanticdb-table-ebrowse) regex &optional tags) + "Find all tags with name matching REGEX in TABLE. + Optional argument TAGS is a list of tags to search. + Return a list of tags." + (if tags (call-next-method) + ;; YOUR IMPLEMENTATION HERE + (call-next-method) + )) + + (defmethod semanticdb-find-tags-for-completion-method + ((table semanticdb-table-ebrowse) prefix &optional tags) + "In TABLE, find all occurances of tags matching PREFIX. + Optional argument TAGS is a list of tags to search. + Returns a table of all matching tags." + (if tags (call-next-method) + ;; YOUR IMPLEMENTATION HERE + (call-next-method) + )) + + (defmethod semanticdb-find-tags-by-class-method + ((table semanticdb-table-ebrowse) class &optional tags) + "In TABLE, find all occurances of tags of CLASS. + Optional argument TAGS is a list of tags to search. + Returns a table of all matching tags." + (if tags (call-next-method) + (call-next-method))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;;; Deep Searches + ;; + ;; If your language does not have a `deep' concept, these can be left + ;; alone, otherwise replace with implementations similar to those + ;; above. + ;; + + (defmethod semanticdb-deep-find-tags-by-name-method + ((table semanticdb-table-ebrowse) name &optional tags) + "Find all tags name NAME in TABLE. + Optional argument TAGS is a list of tags t + Like `semanticdb-find-tags-by-name-method' for ebrowse." + ;;(semanticdb-find-tags-by-name-method table name tags) + (call-next-method)) + + (defmethod semanticdb-deep-find-tags-by-name-regexp-method + ((table semanticdb-table-ebrowse) regex &optional tags) + "Find all tags with name matching REGEX in TABLE. + Optional argument TAGS is a list of tags to search. + Like `semanticdb-find-tags-by-name-method' for ebrowse." + ;;(semanticdb-find-tags-by-name-regexp-method table regex tags) + (call-next-method)) + + (defmethod semanticdb-deep-find-tags-for-completion-method + ((table semanticdb-table-ebrowse) prefix &optional tags) + "In TABLE, find all occurances of tags matching PREFIX. + Optional argument TAGS is a list of tags to search. + Like `semanticdb-find-tags-for-completion-method' for ebrowse." + ;;(semanticdb-find-tags-for-completion-method table prefix tags) + (call-next-method)) + + ;;; Advanced Searches + ;; + (defmethod semanticdb-find-tags-external-children-of-type-method + ((table semanticdb-table-ebrowse) type &optional tags) + "Find all nonterminals which are child elements of TYPE + Optional argument TAGS is a list of tags to search. + Return a list of tags." + (if tags (call-next-method) + ;; Ebrowse collects all this type of stuff together for us. + ;; but we can't use it.... yet. + nil + )) + + (provide 'semantic/db-ebrowse) + + ;;; semantic/db-ebrowse.el ends here diff --cc lisp/cedet/semantic/db-find.el index 00000000000,817d716ab74..e7ce7fcbdef mode 000000,100644..100644 --- a/lisp/cedet/semantic/db-find.el +++ b/lisp/cedet/semantic/db-find.el @@@ -1,0 -1,1383 +1,1373 @@@ + ;;; semantic/db-find.el --- Searching through semantic databases. + + ;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, + ;;; 2008, 2009 Free Software Foundation, Inc. + + ;; Author: Eric M. Ludlam + ;; Keywords: tags + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; + ;; Databases of various forms can all be searched. + ;; There are a few types of searches that can be done: + ;; + ;; Basic Name Search: + ;; These searches scan a database table collection for tags based + ;; on name. + ;; + ;; Basic Attribute Search: + ;; These searches allow searching on specific attributes of tags, + ;; such as name, type, or other attribute. + ;; + ;; Advanced Search: + ;; These are searches that were needed to accomplish some + ;; specialized tasks as discovered in utilities. Advanced searches + ;; include matching methods defined outside some parent class. + ;; + ;; The reason for advanced searches are so that external + ;; repositories such as the Emacs obarray, or java .class files can + ;; quickly answer these needed questions without dumping the entire + ;; symbol list into Emacs for additional refinement searches via + ;; regular semanticdb search. + ;; + ;; How databases are decided upon is another important aspect of a + ;; database search. When it comes to searching for a name, there are + ;; these types of searches: + ;; + ;; Basic Search: + ;; Basic search means that tags looking for a given name start + ;; with a specific search path. Names are sought on that path + ;; until it is empty or items on the path can no longer be found. + ;; Use `semanticdb-dump-all-table-summary' to test this list. + ;; Use `semanticdb-find-throttle-custom-list' to refine this list. + ;; + ;; Deep Search: + ;; A deep search will search more than just the global namespace. + ;; It will recurse into tags that contain more tags, and search + ;; those too. + ;; + ;; Brute Search: + ;; Brute search means that all tables in all databases in a given + ;; project are searched. Brute searches are the search style as + ;; written for semantic version 1.x. + ;; + ;; How does the search path work? + ;; + ;; A basic search starts with three parameters: + ;; + ;; (FINDME &optional PATH FIND-FILE-MATCH) + ;; + ;; FINDME is key to be searched for dependent on the type of search. + ;; PATH is an indicator of which tables are to be searched. + ;; FIND-FILE-MATCH indicates that any time a match is found, the + ;; file associated with the tag should be read into a file. + ;; + ;; The PATH argument is then the most interesting argument. It can + ;; have these values: + ;; + ;; nil - Take the current buffer, and use it's include list + ;; buffer - Use that buffer's include list. + ;; filename - Use that file's include list. If the file is not + ;; in a buffer, see of there is a semanticdb table for it. If + ;; not, read that file into a buffer. + ;; tag - Get that tag's buffer of file file. See above. + ;; table - Search that table, and it's include list. + ;; + ;; Search Results: + ;; + ;; Semanticdb returns the results in a specific format. There are a + ;; series of routines for using those results, and results can be + ;; passed in as a search-path for refinement searches with + ;; semanticdb. Apropos for semanticdb.*find-result for more. + ;; + ;; Application: + ;; + ;; Here are applications where different searches are needed which + ;; exist as of semantic 1.4.x + ;; + ;; eldoc - popup help + ;; => Requires basic search using default path. (Header files ok) + ;; tag jump - jump to a named tag + ;; => Requires a brute search useing whole project. (Source files only) + ;; completion - Completing symbol names in a smart way + ;; => Basic search (headers ok) + ;; type analysis - finding type definitions for variables & fcns + ;; => Basic search (headers ok) + ;; Class browser - organize types into some structure + ;; => Brute search, or custom navigation. + + ;; TODO: + ;; During a search, load any unloaded DB files based on paths in the + ;; current project. + + (require 'semantic/db) + (require 'semantic/db-ref) + (eval-when-compile - (require 'eieio) + (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 "*") + ))) - -;;; FIND results and edebug -;; -(eval-after-load "cedet-edebug" - '(progn - (cedet-edebug-add-print-override - '(semanticdb-find-results-p object) - '(semanticdb-find-result-prin1-to-string object) ) - )) - - + + ;;; API Functions + ;; + ;; Once you have a search result, use these routines to operate + ;; on the search results at a higher level + + ;;;###autoload + (defun semanticdb-strip-find-results (results &optional find-file-match) + "Strip a semanticdb search RESULTS to exclude objects. + This makes it appear more like the results of a `semantic-find-' call. + Optional FIND-FILE-MATCH loads all files associated with RESULTS + into buffers. This has the side effect of enabling `semantic-tag-buffer' to + return a value. + If FIND-FILE-MATCH is 'name, then only the filename is stored + in each tag instead of loading each file into a buffer. + If the input RESULTS are not going to be used again, and if + FIND-FILE-MATCH is nil, you can use `semanticdb-fast-strip-find-results' + instead." + (if find-file-match + ;; Load all files associated with RESULTS. + (let ((tmp results) + (output nil)) + (while tmp + (let ((tab (car (car tmp))) + (tags (cdr (car tmp)))) + (dolist (T tags) + ;; Normilzation gives specialty database tables a chance + ;; to convert into a more stable tag format. + (let* ((norm (semanticdb-normalize-one-tag tab T)) + (ntab (car norm)) + (ntag (cdr norm)) + (nametable ntab)) + + ;; If it didn't normalize, use what we had. + (if (not norm) + (setq nametable tab) + (setq output (append output (list ntag)))) + + ;; Find-file-match allows a tool to make sure the tag is + ;; 'live', somewhere in a buffer. + (cond ((eq find-file-match 'name) + (let ((f (semanticdb-full-filename nametable))) + (semantic--tag-put-property ntag :filename f))) + ((and find-file-match ntab) + (semanticdb-get-buffer ntab)) + ) + )) + ) + (setq tmp (cdr tmp))) + output) + ;; @todo - I could use nconc, but I don't know what the caller may do with + ;; RESULTS after this is called. Right now semantic-complete will + ;; recycling the input after calling this routine. + (apply #'append (mapcar #'cdr results)))) + + (defun semanticdb-fast-strip-find-results (results) + "Destructively strip a semanticdb search RESULTS to exclude objects. + This makes it appear more like the results of a `semantic-find-' call. + This is like `semanticdb-strip-find-results', except the input list RESULTS + will be changed." + (apply #'nconc (mapcar #'cdr results))) + + (defun semanticdb-find-results-p (resultp) + "Non-nil if RESULTP is in the form of a semanticdb search result. + This query only really tests the first entry in the list that is RESULTP, + but should be good enough for debugging assertions." + (and (listp resultp) + (listp (car resultp)) + (semanticdb-abstract-table-child-p (car (car resultp))) + (or (semantic-tag-p (car (cdr (car resultp)))) + (null (car (cdr (car resultp))))))) + + (defun semanticdb-find-result-prin1-to-string (result) + "Presuming RESULT satisfies `semanticdb-find-results-p', provide a short PRIN1 output." + (if (< (length result) 2) + (concat "#)")) + result + " ") + ">") + ;; Longer results should have an abreviated form. + (format "#" + (semanticdb-find-result-length result) + (length result)))) + + (defun semanticdb-find-result-with-nil-p (resultp) + "Non-nil of RESULTP is in the form of a semanticdb search result. + nil is a valid value where a TABLE usually is, but only if the TAG + results include overlays. + This query only really tests the first entry in the list that is RESULTP, + but should be good enough for debugging assertions." + (and (listp resultp) + (listp (car resultp)) + (let ((tag-to-test (car-safe (cdr (car resultp))))) + (or (and (semanticdb-abstract-table-child-p (car (car resultp))) + (or (semantic-tag-p tag-to-test) + (null tag-to-test))) + (and (null (car (car resultp))) + (or (semantic-tag-with-position-p tag-to-test) + (null tag-to-test)))) + ))) + + ;;;###autoload + (defun semanticdb-find-result-length (result) + "Number of tags found in RESULT." + (let ((count 0)) + (mapc (lambda (onetable) + (setq count (+ count (1- (length onetable))))) + result) + count)) + + ;;;###autoload + (defun semanticdb-find-result-nth (result n) + "In RESULT, return the Nth search result. + This is a 0 based search result, with the first match being element 0. + + The returned value is a cons cell: (TAG . TABLE) where TAG + is the tag at the Nth position. TABLE is the semanticdb table where + the TAG was found. Sometimes TABLE can be nil." + (let ((ans nil) + (anstable nil)) + ;; Loop over each single table hit. + (while (and (not ans) result) + ;; For each table result, get local length, and modify + ;; N to be that much less. + (let ((ll (length (cdr (car result))))) ;; local length + (if (> ll n) + ;; We have a local match. + (setq ans (nth n (cdr (car result))) + anstable (car (car result))) + ;; More to go. Decrement N. + (setq n (- n ll)))) + ;; Keep moving. + (setq result (cdr result))) + (cons ans anstable))) + + (defun semanticdb-find-result-test (result) + "Test RESULT by accessing all the tags in the list." + (if (not (semanticdb-find-results-p result)) + (error "Does not pass `semanticdb-find-results-p.\n")) + (let ((len (semanticdb-find-result-length result)) + (i 0)) + (while (< i len) + (let ((tag (semanticdb-find-result-nth result i))) + (if (not (semantic-tag-p (car tag))) + (error "%d entry is not a tag" i))) + (setq i (1+ i))))) + + ;;;###autoload + (defun semanticdb-find-result-nth-in-buffer (result n) + "In RESULT, return the Nth search result. + Like `semanticdb-find-result-nth', except that only the TAG + is returned, and the buffer it is found it will be made current. + If the result tag has no position information, the originating buffer + is still made current." + (let* ((ret (semanticdb-find-result-nth result n)) + (ans (car ret)) + (anstable (cdr ret))) + ;; If we have a hit, double-check the find-file + ;; entry. If the file must be loaded, then gat that table's + ;; source file into a buffer. + + (if anstable + (let ((norm (semanticdb-normalize-one-tag anstable ans))) + (when norm + ;; The normalized tags can now be found based on that + ;; tags table. + (semanticdb-set-buffer (car norm)) + ;; Now reset ans + (setq ans (cdr norm)) + )) + ) + ;; Return the tag. + ans)) + + (defun semanticdb-find-result-mapc (fcn result) + "Apply FCN to each element of find RESULT for side-effects only. + FCN takes two arguments. The first is a TAG, and the + second is a DB from wence TAG originated. + Returns result." + (mapc (lambda (sublst) + (mapc (lambda (tag) + (funcall fcn tag (car sublst))) + (cdr sublst))) + result) + result) + + ;;; Search Logging + ;; + ;; Basic logging to see what the search routines are doing. + (defvar semanticdb-find-log-flag nil + "Non-nil means log the process of searches.") + + (defvar semanticdb-find-log-buffer-name "*SemanticDB Find Log*" + "The name of the logging buffer.") + + (defun semanticdb-find-toggle-logging () + "Toggle sematnicdb logging." + (interactive) + (setq semanticdb-find-log-flag (null semanticdb-find-log-flag)) + (message "Semanticdb find logging is %sabled" + (if semanticdb-find-log-flag "en" "dis"))) + + (defun semanticdb-reset-log () + "Reset the log buffer." + (interactive) + (when semanticdb-find-log-flag + (save-excursion + (set-buffer (get-buffer-create semanticdb-find-log-buffer-name)) + (erase-buffer) + ))) + + (defun semanticdb-find-log-move-to-end () + "Move to the end of the semantic log." + (let ((cb (current-buffer)) + (cw (selected-window))) + (unwind-protect + (progn + (set-buffer semanticdb-find-log-buffer-name) + (if (get-buffer-window (current-buffer) 'visible) + (select-window (get-buffer-window (current-buffer) 'visible))) + (goto-char (point-max))) + (if cw (select-window cw)) + (set-buffer cb)))) + + (defun semanticdb-find-log-new-search (forwhat) + "Start a new search FORWHAT." + (when semanticdb-find-log-flag + (save-excursion + (set-buffer (get-buffer-create semanticdb-find-log-buffer-name)) + (insert (format "New Search: %S\n" forwhat)) + ) + (semanticdb-find-log-move-to-end))) + + (defun semanticdb-find-log-activity (table result) + "Log that TABLE has been searched and RESULT was found." + (when semanticdb-find-log-flag + (save-excursion + (set-buffer semanticdb-find-log-buffer-name) + (insert "Table: " (object-print table) + " Result: " (int-to-string (length result)) " tags" + "\n") + ) + (semanticdb-find-log-move-to-end))) + + ;;; Semanticdb find API functions + ;; These are the routines actually used to perform searches. + ;; + (defun semanticdb-find-tags-collector (function &optional path find-file-match + brutish) + "Collect all tags returned by FUNCTION over PATH. + The FUNCTION must take two arguments. The first is TABLE, + which is a semanticdb table containing tags. The second argument + to FUNCTION is TAGS. TAGS may be a list of tags. If TAGS is non-nil, then + FUNCTION should search the TAG list, not through TABLE. + + See `semanticdb-find-translate-path' for details on PATH. + FIND-FILE-MATCH indicates that any time a match is found, the file + associated with that tag should be loaded into a buffer. + + Note: You should leave FIND-FILE-MATCH as nil. It is far more + efficient to take the results from any search and use + `semanticdb-strip-find-results' instead. This argument is here + for backward compatibility. + + If optional argument BRUTISH is non-nil, then ignore include statements, + and search all tables in this project tree." + (let (found match) + (save-excursion + ;; If path is a buffer, set ourselves up in that buffer + ;; so that the override methods work correctly. + (when (bufferp path) (set-buffer path)) + (if (semanticdb-find-results-p path) + ;; When we get find results, loop over that. + (dolist (tableandtags path) + (semantic-throw-on-input 'semantic-find-translate-path) + ;; If FIND-FILE-MATCH is non-nil, skip tables of class + ;; `semanticdb-search-results-table', since those are system + ;; databases and not associated with a file. + (unless (and find-file-match + (obj-of-class-p + (car tableandtags) semanticdb-search-results-table)) + (when (setq match (funcall function + (car tableandtags) (cdr tableandtags))) + (when find-file-match + (save-excursion (semanticdb-set-buffer (car tableandtags)))) + (push (cons (car tableandtags) match) found))) + ) + ;; Only log searches across data bases. + (semanticdb-find-log-new-search nil) + ;; If we get something else, scan the list of tables resulting + ;; from translating it into a list of objects. + (dolist (table (semanticdb-find-translate-path path brutish)) + (semantic-throw-on-input 'semantic-find-translate-path) + ;; If FIND-FILE-MATCH is non-nil, skip tables of class + ;; `semanticdb-search-results-table', since those are system + ;; databases and not associated with a file. + (unless (and find-file-match + (obj-of-class-p table semanticdb-search-results-table)) + (when (and table (setq match (funcall function table nil))) + (semanticdb-find-log-activity table match) + (when find-file-match + (save-excursion (semanticdb-set-buffer table))) + (push (cons table match) found)))))) + ;; At this point, FOUND has had items pushed onto it. + ;; This means items are being returned in REVERSE order + ;; of the tables searched, so if you just get th CAR, then + ;; too-bad, you may have some system-tag that has no + ;; buffer associated with it. + + ;; It must be reversed. + (nreverse found))) + + ;;;###autoload + (defun semanticdb-find-tags-by-name (name &optional path find-file-match) + "Search for all tags matching NAME on PATH. + See `semanticdb-find-translate-path' for details on PATH. + FIND-FILE-MATCH indicates that any time a match is found, the file + associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-find-tags-by-name-method table name tags)) + path find-file-match)) + + ;;;###autoload + (defun semanticdb-find-tags-by-name-regexp (regexp &optional path find-file-match) + "Search for all tags matching REGEXP on PATH. + See `semanticdb-find-translate-path' for details on PATH. + FIND-FILE-MATCH indicates that any time a match is found, the file + associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-find-tags-by-name-regexp-method table regexp tags)) + path find-file-match)) + + ;;;###autoload + (defun semanticdb-find-tags-for-completion (prefix &optional path find-file-match) + "Search for all tags matching PREFIX on PATH. + See `semanticdb-find-translate-path' for details on PATH. + FIND-FILE-MATCH indicates that any time a match is found, the file + associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-find-tags-for-completion-method table prefix tags)) + path find-file-match)) + + ;;;###autoload + (defun semanticdb-find-tags-by-class (class &optional path find-file-match) + "Search for all tags of CLASS on PATH. + See `semanticdb-find-translate-path' for details on PATH. + FIND-FILE-MATCH indicates that any time a match is found, the file + associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-find-tags-by-class-method table class tags)) + path find-file-match)) + + ;;; Deep Searches + (defun semanticdb-deep-find-tags-by-name (name &optional path find-file-match) + "Search for all tags matching NAME on PATH. + Search also in all components of top level tags founds. + See `semanticdb-find-translate-path' for details on PATH. + FIND-FILE-MATCH indicates that any time a match is found, the file + associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-deep-find-tags-by-name-method table name tags)) + path find-file-match)) + + (defun semanticdb-deep-find-tags-by-name-regexp (regexp &optional path find-file-match) + "Search for all tags matching REGEXP on PATH. + Search also in all components of top level tags founds. + See `semanticdb-find-translate-path' for details on PATH. + FIND-FILE-MATCH indicates that any time a match is found, the file + associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-deep-find-tags-by-name-regexp-method table regexp tags)) + path find-file-match)) + + (defun semanticdb-deep-find-tags-for-completion (prefix &optional path find-file-match) + "Search for all tags matching PREFIX on PATH. + Search also in all components of top level tags founds. + See `semanticdb-find-translate-path' for details on PATH. + FIND-FILE-MATCH indicates that any time a match is found, the file + associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-deep-find-tags-for-completion-method table prefix tags)) + path find-file-match)) + + ;;; Brutish Search Routines + ;; + (defun semanticdb-brute-deep-find-tags-by-name (name &optional path find-file-match) + "Search for all tags matching NAME on PATH. + See `semanticdb-find-translate-path' for details on PATH. + The argument BRUTISH will be set so that searching includes all tables + in the current project. + FIND-FILE-MATCH indicates that any time a matchi is found, the file + associated wit that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-deep-find-tags-by-name-method table name tags)) + path find-file-match t)) + + (defun semanticdb-brute-deep-find-tags-for-completion (prefix &optional path find-file-match) + "Search for all tags matching PREFIX on PATH. + See `semanticdb-find-translate-path' for details on PATH. + The argument BRUTISH will be set so that searching includes all tables + in the current project. + FIND-FILE-MATCH indicates that any time a matchi is found, the file + associated wit that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-deep-find-tags-for-completion-method table prefix tags)) + path find-file-match t)) + + (defun semanticdb-brute-find-tags-by-class (class &optional path find-file-match) + "Search for all tags of CLASS on PATH. + See `semanticdb-find-translate-path' for details on PATH. + The argument BRUTISH will be set so that searching includes all tables + in the current project. + FIND-FILE-MATCH indicates that any time a match is found, the file + associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-find-tags-by-class-method table class tags)) + path find-file-match t)) + + ;;; Specialty Search Routines + (defun semanticdb-find-tags-external-children-of-type + (type &optional path find-file-match) + "Search for all tags defined outside of TYPE w/ TYPE as a parent. + See `semanticdb-find-translate-path' for details on PATH. + FIND-FILE-MATCH indicates that any time a match is found, the file + associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-find-tags-external-children-of-type-method table type tags)) + path find-file-match)) + + (defun semanticdb-find-tags-subclasses-of-type + (type &optional path find-file-match) + "Search for all tags of class type defined that subclass TYPE. + See `semanticdb-find-translate-path' for details on PATH. + FIND-FILE-MATCH indicates that any time a match is found, the file + associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-find-tags-subclasses-of-type-method table type tags)) + path find-file-match t)) + + ;;; METHODS + ;; + ;; Default methods for semanticdb database and table objects. + ;; Override these with system databases to as new types of back ends. + + ;;; Top level Searches + (defmethod semanticdb-find-tags-by-name-method ((table semanticdb-abstract-table) name &optional tags) + "In TABLE, find all occurances of tags with NAME. + Optional argument TAGS is a list of tags to search. + Returns a table of all matching tags." + (semantic-find-tags-by-name name (or tags (semanticdb-get-tags table)))) + + (defmethod semanticdb-find-tags-by-name-regexp-method ((table semanticdb-abstract-table) regexp &optional tags) + "In TABLE, find all occurances of tags matching REGEXP. + Optional argument TAGS is a list of tags to search. + Returns a table of all matching tags." + (semantic-find-tags-by-name-regexp regexp (or tags (semanticdb-get-tags table)))) + + (defmethod semanticdb-find-tags-for-completion-method ((table semanticdb-abstract-table) prefix &optional tags) + "In TABLE, find all occurances of tags matching PREFIX. + Optional argument TAGS is a list of tags to search. + Returns a table of all matching tags." + (semantic-find-tags-for-completion prefix (or tags (semanticdb-get-tags table)))) + + (defmethod semanticdb-find-tags-by-class-method ((table semanticdb-abstract-table) class &optional tags) + "In TABLE, find all occurances of tags of CLASS. + Optional argument TAGS is a list of tags to search. + Returns a table of all matching tags." + (semantic-find-tags-by-class class (or tags (semanticdb-get-tags table)))) + + (defmethod semanticdb-find-tags-external-children-of-type-method ((table semanticdb-abstract-table) parent &optional tags) + "In TABLE, find all occurances of tags whose parent is the PARENT type. + Optional argument TAGS is a list of tags to search. + Returns a table of all matching tags." ++ (require 'semantic/find) + (semantic-find-tags-external-children-of-type parent (or tags (semanticdb-get-tags table)))) + + (defmethod semanticdb-find-tags-subclasses-of-type-method ((table semanticdb-abstract-table) parent &optional tags) + "In TABLE, find all occurances of tags whose parent is the PARENT type. + Optional argument TAGS is a list of tags to search. + Returns a table of all matching tags." ++ (require 'semantic/find) + (semantic-find-tags-subclasses-of-type parent (or tags (semanticdb-get-tags table)))) + + ;;; Deep Searches + (defmethod semanticdb-deep-find-tags-by-name-method ((table semanticdb-abstract-table) name &optional tags) + "In TABLE, find all occurances of tags with NAME. + Search in all tags in TABLE, and all components of top level tags in + TABLE. + Optional argument TAGS is a list of tags to search. + Return a table of all matching tags." + (semantic-find-tags-by-name name (semantic-flatten-tags-table (or tags (semanticdb-get-tags table))))) + + (defmethod semanticdb-deep-find-tags-by-name-regexp-method ((table semanticdb-abstract-table) regexp &optional tags) + "In TABLE, find all occurances of tags matching REGEXP. + Search in all tags in TABLE, and all components of top level tags in + TABLE. + Optional argument TAGS is a list of tags to search. + Return a table of all matching tags." + (semantic-find-tags-by-name-regexp regexp (semantic-flatten-tags-table (or tags (semanticdb-get-tags table))))) + + (defmethod semanticdb-deep-find-tags-for-completion-method ((table semanticdb-abstract-table) prefix &optional tags) + "In TABLE, find all occurances of tags matching PREFIX. + Search in all tags in TABLE, and all components of top level tags in + TABLE. + Optional argument TAGS is a list of tags to search. + Return a table of all matching tags." + (semantic-find-tags-for-completion prefix (semantic-flatten-tags-table (or tags (semanticdb-get-tags table))))) + + (provide 'semantic/db-find) + + ;; Local variables: + ;; generated-autoload-file: "loaddefs.el" + ;; generated-autoload-feature: semantic/loaddefs + ;; generated-autoload-load-name: "semantic/db-find" + ;; End: + + ;;; semantic/db-find.el ends here diff --cc lisp/cedet/semantic/db-javascript.el index 00000000000,42203806fd4..e9d3794558d mode 000000,100644..100644 --- a/lisp/cedet/semantic/db-javascript.el +++ b/lisp/cedet/semantic/db-javascript.el @@@ -1,0 -1,311 +1,311 @@@ + ;;; semantic/db-javascript.el --- Semantic database extensions for javascript + + ;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 + ;;; Free Software Foundation, Inc. + + ;; Author: Joakim Verona + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; + ;; Semanticdb database for Javascript. + ;; + ;; This is an omniscient database with a hard-coded list of symbols for + ;; Javascript. See the doc at the end of this file for adding or modifying + ;; the list of tags. + ;; + + (require 'semantic/db) + (require 'semantic/db-find) + + (eval-when-compile + ;; For generic function searching. + (require 'eieio) - (require 'eieio-opt) - ) ++ (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 --cc lisp/cedet/semantic/db-mode.el index 00000000000,ae612217232..c526515f248 mode 000000,100644..100644 --- a/lisp/cedet/semantic/db-mode.el +++ b/lisp/cedet/semantic/db-mode.el @@@ -1,0 -1,229 +1,221 @@@ + ;;; semantic/db-mode.el --- Semanticdb Minor Mode + + ;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + + ;; Author: Eric M. Ludlam + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; + ;; Major mode for managing Semantic Databases automatically. + -(require 'semantic/db) + ;;; Code: + -;; Moved into semantic/db.el: -;; (defvar semanticdb-current-database nil -;; "For a given buffer, this is the currently active database.") -;; (make-variable-buffer-local 'semanticdb-current-database) - -;; (defvar semanticdb-current-table nil -;; "For a given buffer, this is the currently active database table.") -;; (make-variable-buffer-local 'semanticdb-current-table) ++(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 --cc lisp/cedet/semantic/db.el index 00000000000,ece8ea765ef..bc25d31f19e mode 000000,100644..100644 --- a/lisp/cedet/semantic/db.el +++ b/lisp/cedet/semantic/db.el @@@ -1,0 -1,1026 +1,1026 @@@ + ;;; semantic/db.el --- Semantic tag database manager + + ;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, + ;;; 2008, 2009 Free Software Foundation, Inc. + + ;; Author: Eric M. Ludlam + ;; Keywords: tags + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; + ;; Maintain a database of tags for a group of files and enable + ;; queries into the database. + ;; + ;; By default, assume one database per directory. + ;; + -(require 'eieio) ++;;; Code: ++ + (require 'eieio-base) + (require 'semantic) -(eval-when-compile - (require 'semantic/lex-spp)) ++ ++(declare-function semantic-lex-spp-save-table "semantic/lex-spp") + + ;;; Variables: + (defgroup semanticdb nil + "Parser Generator Persistent Database interface." - :group 'semantic - ) -;;; Code: ++ :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 --cc lisp/cedet/semantic/decorate.el index 00000000000,4623332c567..70c082e4e98 mode 000000,100644..100644 --- a/lisp/cedet/semantic/decorate.el +++ b/lisp/cedet/semantic/decorate.el @@@ -1,0 -1,322 +1,299 @@@ + ;;; semantic/decorate.el --- Utilities for decorating/highlighting tokens. + + ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2005, 2006, 2007, 2009 + ;;; Free Software Foundation, Inc. + + ;; Author: Eric M. Ludlam + ;; Keywords: syntax + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; + ;; Text representing a semantic tag is wrapped in an overlay. + ;; This overlay can be used for highlighting, or setting other + ;; editing properties on a tag, such as "read only." + ;; + + (require 'semantic) + (require 'pulse) + + ;;; Code: + + ;;; Highlighting Basics + (defun semantic-highlight-tag (tag &optional face) + "Specify that TAG should be highlighted. + Optional FACE specifies the face to use." + (let ((o (semantic-tag-overlay tag))) + (semantic-overlay-put o 'old-face + (cons (semantic-overlay-get o 'face) + (semantic-overlay-get o 'old-face))) + (semantic-overlay-put o 'face (or face 'semantic-tag-highlight-face)) + )) + + (defun semantic-unhighlight-tag (tag) + "Unhighlight TAG, restoring it's previous face." + (let ((o (semantic-tag-overlay tag))) + (semantic-overlay-put o 'face (car (semantic-overlay-get o 'old-face))) + (semantic-overlay-put o 'old-face (cdr (semantic-overlay-get o 'old-face))) + )) + + ;;; Momentary Highlighting - One line + (defun semantic-momentary-highlight-one-tag-line (tag &optional face) + "Highlight the first line of TAG, unhighlighting before next command. + Optional argument FACE specifies the face to do the highlighting." + (save-excursion + ;; Go to first line in tag + (semantic-go-to-tag tag) + (pulse-momentary-highlight-one-line (point)))) + + ;;; Momentary Highlighting - Whole Tag + (defun semantic-momentary-highlight-tag (tag &optional face) + "Highlight TAG, removing highlighting when the user hits a key. + Optional argument FACE is the face to use for highlighting. + If FACE is not specified, then `highlight' will be used." + (when (semantic-tag-with-position-p tag) + (if (not (semantic-overlay-p (semantic-tag-overlay tag))) + ;; No overlay, but a position. Highlight the first line only. + (semantic-momentary-highlight-one-tag-line tag face) + ;; The tag has an overlay, highlight the whole thing + (pulse-momentary-highlight-overlay (semantic-tag-overlay tag) + face) + ))) + + (defun semantic-set-tag-face (tag face) + "Specify that TAG should use FACE for display." + (semantic-overlay-put (semantic-tag-overlay tag) 'face face)) + + (defun semantic-set-tag-invisible (tag &optional visible) + "Enable the text in TAG to be made invisible. + If VISIBLE is non-nil, make the text visible." + (semantic-overlay-put (semantic-tag-overlay tag) 'invisible + (not visible))) + + (defun semantic-tag-invisible-p (tag) + "Return non-nil if TAG is invisible." + (semantic-overlay-get (semantic-tag-overlay tag) 'invisible)) + + (defun semantic-set-tag-intangible (tag &optional tangible) + "Enable the text in TAG to be made intangible. + If TANGIBLE is non-nil, make the text visible. + This function does not have meaning in XEmacs because it seems that + the extent 'intangible' property does not exist." + (semantic-overlay-put (semantic-tag-overlay tag) 'intangible + (not tangible))) + + (defun semantic-tag-intangible-p (tag) + "Return non-nil if TAG is intangible. + This function does not have meaning in XEmacs because it seems that + the extent 'intangible' property does not exist." + (semantic-overlay-get (semantic-tag-overlay tag) 'intangible)) + + (defun semantic-overlay-signal-read-only + (overlay after start end &optional len) + "Hook used in modification hooks to prevent modification. + Allows deletion of the entire text. + Argument OVERLAY, AFTER, START, END, and LEN are passed in by the system." + ;; Stolen blithly from cpp.el in Emacs 21.1 + (if (and (not after) + (or (< (semantic-overlay-start overlay) start) + (> (semantic-overlay-end overlay) end))) + (error "This text is read only"))) + + (defun semantic-set-tag-read-only (tag &optional writable) + "Enable the text in TAG to be made read-only. + Optional argument WRITABLE should be non-nil to make the text writable + instead of read-only." + (let ((o (semantic-tag-overlay tag)) + (hook (if writable nil '(semantic-overlay-signal-read-only)))) + (if (featurep 'xemacs) + ;; XEmacs extents have a 'read-only' property. + (semantic-overlay-put o 'read-only (not writable)) + (semantic-overlay-put o 'modification-hooks hook) + (semantic-overlay-put o 'insert-in-front-hooks hook) + (semantic-overlay-put o 'insert-behind-hooks hook)))) + + (defun semantic-tag-read-only-p (tag) + "Return non-nil if the current TAG is marked read only." + (let ((o (semantic-tag-overlay tag))) + (if (featurep 'xemacs) + ;; XEmacs extents have a 'read-only' property. + (semantic-overlay-get o 'read-only) + (member 'semantic-overlay-signal-read-only + (semantic-overlay-get o 'modification-hooks))))) + -;;; backwards compatability - -(semantic-alias-obsolete 'semantic-highlight-token - 'semantic-highlight-tag) -(semantic-alias-obsolete 'semantic-unhighlight-token - 'semantic-unhighlight-tag) -(semantic-alias-obsolete 'semantic-momentary-highlight-token - 'semantic-momentary-highlight-tag) -(semantic-alias-obsolete 'semantic-set-token-face - 'semantic-set-tag-face) -(semantic-alias-obsolete 'semantic-set-token-invisible - 'semantic-set-tag-invisible) -(semantic-alias-obsolete 'semantic-token-invisible-p - 'semantic-tag-invisible-p) -(semantic-alias-obsolete 'semantic-set-token-intangible - 'semantic-set-tag-intangible) -(semantic-alias-obsolete 'semantic-token-intangible-p - 'semantic-tag-intangible-p) -(semantic-alias-obsolete 'semantic-set-token-read-only - 'semantic-set-tag-read-only) -(semantic-alias-obsolete 'semantic-token-read-only-p - 'semantic-tag-read-only-p) - + ;;; Secondary overlays + ;; + ;; Some types of decoration require a second overlay to be made. + ;; It could be for images, arrows, or whatever. + ;; We need a way to create such an overlay, and make sure it + ;; gets whacked, but doesn't show up in the master list + ;; of overlays used for searching. + (defun semantic-tag-secondary-overlays (tag) + "Return a list of secondary overlays active on TAG." + (semantic--tag-get-property tag 'secondary-overlays)) + + (defun semantic-tag-create-secondary-overlay (tag &optional link-hook) + "Create a secondary overlay for TAG. + Returns an overlay. The overlay is also saved in TAG. + LINK-HOOK is a function called whenever TAG is to be linked into + a buffer. It should take TAG and OVERLAY as arguments. + The LINK-HOOK should be used to position and set properties on the + generated secondary overlay." + (if (not (semantic-tag-overlay tag)) + ;; do nothing if there is no overlay + nil + (let* ((os (semantic-tag-start tag)) + (oe (semantic-tag-end tag)) + (o (semantic-make-overlay os oe (semantic-tag-buffer tag) t)) + (attr (semantic-tag-secondary-overlays tag)) + ) + (semantic--tag-put-property tag 'secondary-overlays (cons o attr)) + (semantic-overlay-put o 'semantic-secondary t) + (semantic-overlay-put o 'semantic-link-hook link-hook) + (semantic-tag-add-hook tag 'link-hook 'semantic--tag-link-secondary-overlays) + (semantic-tag-add-hook tag 'unlink-hook 'semantic--tag-unlink-secondary-overlays) + (semantic-tag-add-hook tag 'unlink-copy-hook 'semantic--tag-unlink-copy-secondary-overlays) + (run-hook-with-args link-hook tag o) + o))) + + (defun semantic-tag-get-secondary-overlay (tag property) + "Return secondary overlays from TAG with PROPERTY. + PROPERTY is a symbol and all overlays with that symbol are returned.." + (let* ((olsearch (semantic-tag-secondary-overlays tag)) + (o nil)) + (while olsearch + (when (semantic-overlay-get (car olsearch) property) + (setq o (cons (car olsearch) o))) + (setq olsearch (cdr olsearch))) + o)) + + (defun semantic-tag-delete-secondary-overlay (tag overlay-or-property) + "Delete from TAG the secondary overlay OVERLAY-OR-PROPERTY. + If OVERLAY-OR-PROPERTY is an overlay, delete that overlay. + If OVERLAY-OR-PROPERTY is a symbol, find the overlay with that property." + (let* ((o overlay-or-property)) + (if (semantic-overlay-p o) + (setq o (list o)) + (setq o (semantic-tag-get-secondary-overlay tag overlay-or-property))) + (while (semantic-overlay-p (car o)) + ;; We don't really need to worry about the hooks. + ;; They will clean themselves up eventually ?? + (semantic--tag-put-property + tag 'secondary-overlays + (delete (car o) (semantic-tag-secondary-overlays tag))) + (semantic-overlay-delete (car o)) + (setq o (cdr o))))) + + (defun semantic--tag-unlink-copy-secondary-overlays (tag) + "Unlink secondary overlays from TAG which is a copy. + This means we don't destroy the overlays, only remove reference + from them in TAG." + (let ((ol (semantic-tag-secondary-overlays tag))) + (while ol + ;; Else, remove all traces of ourself from the tag + ;; Note to self: Does this prevent multiple types of secondary + ;; overlays per tag? + (semantic-tag-remove-hook tag 'link-hook 'semantic--tag-link-secondary-overlays) + (semantic-tag-remove-hook tag 'unlink-hook 'semantic--tag-unlink-secondary-overlays) + (semantic-tag-remove-hook tag 'unlink-copy-hook 'semantic--tag-unlink-copy-secondary-overlays) + ;; Next! + (setq ol (cdr ol))) + (semantic--tag-put-property tag 'secondary-overlays nil) + )) + + (defun semantic--tag-unlink-secondary-overlays (tag) + "Unlink secondary overlays from TAG." + (let ((ol (semantic-tag-secondary-overlays tag)) + (nl nil)) + (while ol + (if (semantic-overlay-get (car ol) 'semantic-link-hook) + ;; Only put in a proxy if there is a link-hook. If there is no link-hook + ;; the decorating mode must know when tags are unlinked on its own. + (setq nl (cons (semantic-overlay-get (car ol) 'semantic-link-hook) + nl)) + ;; Else, remove all traces of ourself from the tag + ;; Note to self: Does this prevent multiple types of secondary + ;; overlays per tag? + (semantic-tag-remove-hook tag 'link-hook 'semantic--tag-link-secondary-overlays) + (semantic-tag-remove-hook tag 'unlink-hook 'semantic--tag-unlink-secondary-overlays) + (semantic-tag-remove-hook tag 'unlink-copy-hook 'semantic--tag-unlink-copy-secondary-overlays) + ) + (semantic-overlay-delete (car ol)) + (setq ol (cdr ol))) + (semantic--tag-put-property tag 'secondary-overlays (nreverse nl)) + )) + + (defun semantic--tag-link-secondary-overlays (tag) + "Unlink secondary overlays from TAG." + (let ((ol (semantic-tag-secondary-overlays tag))) + ;; Wipe out old values. + (semantic--tag-put-property tag 'secondary-overlays nil) + ;; Run all the link hooks. + (while ol + (semantic-tag-create-secondary-overlay tag (car ol)) + (setq ol (cdr ol))) + )) + + ;;; Secondary Overlay Uses + ;; + ;; States to put on tags that depend on a secondary overlay. + (defun semantic-set-tag-folded (tag &optional folded) + "Fold TAG, such that only the first line of text is shown. + Optional argument FOLDED should be non-nil to fold the tag. + nil implies the tag should be fully shown." + ;; If they are different, do the deed. + (let ((o (semantic-tag-folded-p tag))) + (if (not folded) + ;; We unfold. + (when o + (semantic-tag-delete-secondary-overlay tag 'semantic-folded)) + (unless o + ;; Add the foldn + (setq o (semantic-tag-create-secondary-overlay tag)) + ;; mark as folded + (semantic-overlay-put o 'semantic-folded t) + ;; Move to cover end of tag + (save-excursion + (goto-char (semantic-tag-start tag)) + (end-of-line) + (semantic-overlay-move o (point) (semantic-tag-end tag))) + ;; We need to modify the invisibility spec for this to + ;; work. + (if (or (eq buffer-invisibility-spec t) + (not (assoc 'semantic-fold buffer-invisibility-spec))) + (add-to-invisibility-spec '(semantic-fold . t))) + (semantic-overlay-put o 'invisible 'semantic-fold) + (overlay-put o 'isearch-open-invisible + 'semantic-set-tag-folded-isearch))) + )) + + (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 --cc lisp/cedet/semantic/decorate/mode.el index 00000000000,3ee2664d7bc..66c7c1224f8 mode 000000,100644..100644 --- a/lisp/cedet/semantic/decorate/mode.el +++ b/lisp/cedet/semantic/decorate/mode.el @@@ -1,0 -1,571 +1,567 @@@ + ;;; semantic/decorate/mode.el --- Minor mode for decorating tags + + ;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008 + ;;; Free Software Foundation, Inc. + + ;; Author: Eric M. Ludlam + ;; Keywords: syntax + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; + ;; A minor mode for use in decorating tags. + ;; + ;; There are two types of decorations that can be performed on a tag. + ;; You can either highlight the full tag, or you can add an + ;; independent decoration on some part of the tag body. + ;; + ;; For independent decoration in particular, managing them so that they + ;; do not get corrupted is challenging. This major mode and + ;; corresponding macros will make handling those types of decorations + ;; easier. + ;; + + ;;; Code: + (require 'semantic) + (require 'semantic/decorate) + (require 'semantic/tag-ls) + (require 'semantic/util-modes) -(eval-when-compile (require 'cl)) + + ;;; Styles List + ;; + (defcustom semantic-decoration-styles nil - "*List of active decoration styles. ++ "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))) + -;;;;###autoload + (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'." ++ "Hook run at the end of function `semantic-decoration-mode'." + :group 'semantic + :type 'hook) + + ;;;;###autoload + (defvar semantic-decoration-mode nil + "Non-nil if command `semantic-decoration-mode' is enabled. + Use the command `semantic-decoration-mode' to change this variable.") + (make-variable-buffer-local 'semantic-decoration-mode) + + (defun semantic-decoration-mode-setup () + "Setup the `semantic-decoration-mode' minor mode. + The minor mode can be turned on only if the semantic feature is available + and the current buffer was set up for parsing. Return non-nil if the + minor mode is enabled." + (if semantic-decoration-mode + (if (not (and (featurep 'semantic) (semantic-active-p))) + (progn + ;; Disable minor mode if semantic stuff not available + (setq semantic-decoration-mode nil) + (error "Buffer %s was not set up for parsing" + (buffer-name))) + ;; Add hooks + (semantic-make-local-hook 'semantic-after-partial-cache-change-hook) + (add-hook 'semantic-after-partial-cache-change-hook + 'semantic-decorate-tags-after-partial-reparse nil t) + (semantic-make-local-hook 'semantic-after-toplevel-cache-change-hook) + (add-hook 'semantic-after-toplevel-cache-change-hook + 'semantic-decorate-tags-after-full-reparse nil t) + ;; Add decorations to available tags. The above hooks ensure + ;; that new tags will be decorated when they become available. + (semantic-decorate-add-decorations (semantic-fetch-available-tags)) + ) + ;; Remove decorations from available tags. + (semantic-decorate-clear-decorations (semantic-fetch-available-tags)) + ;; Cleanup any leftover crap too. + (semantic-decorate-flush-decorations) + ;; Remove hooks + (remove-hook 'semantic-after-partial-cache-change-hook + 'semantic-decorate-tags-after-partial-reparse t) + (remove-hook 'semantic-after-toplevel-cache-change-hook + 'semantic-decorate-tags-after-full-reparse t) + ) + semantic-decoration-mode) + -;;;;###autoload + (defun semantic-decoration-mode (&optional arg) + "Minor mode for decorating tags. + Decorations are specified in `semantic-decoration-styles'. + You can define new decoration styles with + `define-semantic-decoration-style'. + With prefix argument ARG, turn on if positive, otherwise off. The + minor mode can be turned on only if semantic feature is available and + the current buffer was set up for parsing. Return non-nil if the + minor mode is enabled." + ;; + ;;\\{semantic-decoration-map}" + (interactive + (list (or current-prefix-arg + (if semantic-decoration-mode 0 1)))) + (setq semantic-decoration-mode + (if arg + (> + (prefix-numeric-value arg) + 0) + (not semantic-decoration-mode))) + (semantic-decoration-mode-setup) + (run-hooks 'semantic-decoration-mode-hook) + (if (interactive-p) + (message "decoration-mode minor mode %sabled" + (if semantic-decoration-mode "en" "dis"))) + (semantic-mode-line-update) + semantic-decoration-mode) + + (semantic-add-minor-mode 'semantic-decoration-mode + "" + nil) + + (defun semantic-decorate-tags-after-full-reparse (tag-list) + "Add decorations after a complete reparse of the current buffer. + TAG-LIST is the list of tags recently parsed. + Flush all existing decorations and call `semantic-decorate-add-decorations' to + add decorations. + Called from `semantic-after-toplevel-cache-change-hook'." + ;; Flush everything + (semantic-decorate-flush-decorations) + ;; Add it back on + (semantic-decorate-add-decorations tag-list)) + + (defun semantic-decorate-tags-after-partial-reparse (tag-list) + "Add decorations when new tags are created in the current buffer. + TAG-LIST is the list of newly created tags. + Call `semantic-decorate-add-decorations' to add decorations. + Called from `semantic-after-partial-cache-change-hook'." + (semantic-decorate-add-decorations tag-list)) + + + ;;; 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)) + )) + -;;;;###autoload + (defun semantic-build-decoration-mode-menu (&rest ignore) + "Create a menu listing all the known decorations for toggling. + IGNORE any input arguments." + (or semantic-decoration-menu-cache + (setq semantic-decoration-menu-cache + (mapcar 'semantic-decoration-build-style-menu + (reverse semantic-decoration-styles)) + ))) + + + ;;; Defining decoration styles + ;; + (defmacro define-semantic-decoration-style (name doc &rest flags) + "Define a new decoration style with NAME. + DOC is a documentation string describing the decoration style NAME. + It is appended to auto-generated doc strings. + An Optional list of FLAGS can also be specified. Flags are: + :enabled - specify the default enabled value for NAME. + + + This defines two new overload functions respectively called `NAME-p' + and `NAME-highlight', for which you must provide a default + implementation in respectively the functions `NAME-p-default' and + `NAME-highlight-default'. Those functions are passed a tag. `NAME-p' + must return non-nil to indicate that the tag should be decorated by + `NAME-highlight'. + + To put primary decorations on a tag `NAME-highlight' must use + functions like `semantic-set-tag-face', `semantic-set-tag-intangible', + etc., found in the semantic-decorate library. + + To add other kind of decorations on a tag, `NAME-highlight' must use + `semantic-decorate-tag', and other functions of the semantic + decoration API found in this library." + (let ((predicate (semantic-decorate-style-predicate name)) + (highlighter (semantic-decorate-style-highlighter name)) + (defaultenable (if (plist-member flags :enabled) + (plist-get flags :enabled) + t)) + ) + `(progn + ;; Clear the menu cache so that new items are added when + ;; needed. + (setq semantic-decoration-menu-cache nil) + ;; Create an override method to specify if a given tag belongs + ;; to this type of decoration + (define-overloadable-function ,predicate (tag) + ,(format "Return non-nil to decorate TAG with `%s' style.\n%s" + name doc)) + ;; Create an override method that will perform the highlight + ;; operation if the -p method returns non-nil. + (define-overloadable-function ,highlighter (tag) + ,(format "Decorate TAG with `%s' style.\n%s" + name doc)) + ;; Add this to the list of primary decoration modes. + (add-to-list 'semantic-decoration-styles + (cons ',(symbol-name name) + ,defaultenable)) + ))) + + ;;; Predefined decoration styles + ;; + + ;;; Tag boundaries highlighting + ;; + (define-semantic-decoration-style semantic-tag-boundary + "Place an overline in front of each long tag. + Does not provide overlines for prototypes.") + + (defface semantic-tag-boundary-face + '((((class color) (background dark)) + (:overline "cyan")) + (((class color) (background light)) + (:overline "blue"))) + "*Face used to show long tags in. + Used by decoration style: `semantic-tag-boundary'." + :group 'semantic-faces) + + (defun semantic-tag-boundary-p-default (tag) + "Return non-nil if TAG is a type, or a non-prototype function." + (let ((c (semantic-tag-class tag))) + (and + (or + ;; All types get a line? + (eq c 'type) + ;; Functions which aren't prototypes get a line. + (and (eq c 'function) + (not (semantic-tag-get-attribute tag :prototype-flag))) + ) + ;; Note: The below restriction confused users. + ;; + ;; Nothing smaller than a few lines + ;;(> (- (semantic-tag-end tag) (semantic-tag-start tag)) 150) + ;; Random truth + t) + )) + + (defun semantic-tag-boundary-highlight-default (tag) + "Highlight the first line of TAG as a boundary." + (when (bufferp (semantic-tag-buffer tag)) + (with-current-buffer (semantic-tag-buffer tag) + (semantic-decorate-tag + tag + (semantic-tag-start tag) + (save-excursion + (goto-char (semantic-tag-start tag)) + (end-of-line) + (forward-char 1) + (point)) + 'semantic-tag-boundary-face)) + )) + + ;;; Private member highlighting + ;; + (define-semantic-decoration-style semantic-decoration-on-private-members + "Highlight class members that are designated as PRIVATE access." + :enabled nil) + + (defface semantic-decoration-on-private-members-face + '((((class color) (background dark)) + (:background "#200000")) + (((class color) (background light)) + (:background "#8fffff"))) + "*Face used to show privately scoped tags in. + Used by the decoration style: `semantic-decoration-on-private-members'." + :group 'semantic-faces) + + (defun semantic-decoration-on-private-members-highlight-default (tag) + "Highlight TAG as designated to have PRIVATE access. + Use a primary decoration." + (semantic-set-tag-face + tag 'semantic-decoration-on-private-members-face)) + + (defun semantic-decoration-on-private-members-p-default (tag) + "Return non-nil if TAG has PRIVATE access." + (and (member (semantic-tag-class tag) '(function variable)) + (eq (semantic-tag-protection tag) 'private))) + + ;;; Protected member highlighting + ;; + (defface semantic-decoration-on-protected-members-face + '((((class color) (background dark)) + (:background "#000020")) + (((class color) (background light)) + (:background "#fffff8"))) + "*Face used to show protected scoped tags in. + Used by the decoration style: `semantic-decoration-on-protected-members'." + :group 'semantic-faces) + + (define-semantic-decoration-style semantic-decoration-on-protected-members + "Highlight class members that are designated as PROTECTED access." + :enabled nil) + + (defun semantic-decoration-on-protected-members-p-default (tag) + "Return non-nil if TAG has PROTECTED access." + (and (member (semantic-tag-class tag) '(function variable)) + (eq (semantic-tag-protection tag) 'protected))) + + (defun semantic-decoration-on-protected-members-highlight-default (tag) + "Highlight TAG as designated to have PROTECTED access. + Use a primary decoration." + (semantic-set-tag-face + tag 'semantic-decoration-on-protected-members-face)) + + (provide 'semantic/decorate/mode) + + ;; Local variables: + ;; generated-autoload-file: "../loaddefs.el" + ;; generated-autoload-feature: semantic/loaddefs + ;; generated-autoload-load-name: "semantic/decorate/mode" + ;; End: + + ;;; semantic/decorate/mode.el ends here diff --cc lisp/cedet/semantic/doc.el index 00000000000,0eaf41c06e9..9feeee294f6 mode 000000,100644..100644 --- a/lisp/cedet/semantic/doc.el +++ b/lisp/cedet/semantic/doc.el @@@ -1,0 -1,135 +1,129 @@@ + ;;; semantic/doc.el --- Routines for documentation strings + + ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2005, 2008, 2009 + ;;; Free Software Foundation, Inc. + + ;; Author: Eric M. Ludlam + ;; Keywords: syntax + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; + ;; It is good practice to write documenation for your functions and + ;; variables. These core routines deal with these documentation + ;; comments or strings. They can exist either as a tag property + ;; (:documentation) or as a comment just before the symbol, or after + ;; the symbol on the same line. + + (require 'semantic/tag) + + ;;; Code: + + ;;;###autoload + (define-overloadable-function semantic-documentation-for-tag (&optional tag nosnarf) + "Find documentation from TAG and return it as a clean string. + TAG might have DOCUMENTATION set in it already. If not, there may be + some documentation in a comment preceding TAG's definition which we + can look for. When appropriate, this can be overridden by a language specific + enhancement. + Optional argument NOSNARF means to only return the lexical analyzer token for it. + If nosnarf if 'lex, then only return the lex token." + (if (not tag) (setq tag (semantic-current-tag))) + (save-excursion + (when (semantic-tag-with-position-p tag) + (set-buffer (semantic-tag-buffer tag))) + (:override + ;; No override. Try something simple to find documentation nearby + (save-excursion + (semantic-go-to-tag tag) + (let ((doctmp (semantic-tag-docstring tag (current-buffer)))) + (or + ;; Is there doc in the tag??? + doctmp + ;; Check just before the definition. + (when (semantic-tag-with-position-p tag) + (semantic-documentation-comment-preceeding-tag tag nosnarf)) + ;; Lets look for comments either after the definition, but before code: + ;; Not sure yet. Fill in something clever later.... + nil)))))) + + (defun semantic-documentation-comment-preceeding-tag (&optional tag nosnarf) + "Find a comment preceeding TAG. + If TAG is nil. use the tag under point. + Searches the space between TAG and the preceeding tag for a comment, + and converts the comment into clean documentation. + Optional argument NOSNARF with a value of 'lex means to return + just the lexical token and not the string." + (if (not tag) (setq tag (semantic-current-tag))) + (save-excursion + ;; Find this tag. + (semantic-go-to-tag tag) + (let* ((starttag (semantic-find-tag-by-overlay-prev + (semantic-tag-start tag))) + (start (if starttag + (semantic-tag-end starttag) + (point-min)))) + (when (re-search-backward comment-start-skip start t) + ;; We found a comment that doesn't belong to the body + ;; of a function. + (semantic-doc-snarf-comment-for-tag nosnarf))) + )) + -(make-obsolete-overload 'semantic-find-documentation - 'semantic-documentation-for-tag) - + (defun semantic-doc-snarf-comment-for-tag (nosnarf) + "Snarf up the comment at POINT for `semantic-documentation-for-tag'. + Attempt to strip out comment syntactic sugar. + Argument NOSNARF means don't modify the found text. + If NOSNARF is 'lex, then return the lex token." + (let* ((semantic-ignore-comments nil) + (semantic-lex-analyzer #'semantic-comment-lexer)) + (if (memq nosnarf '(lex flex)) ;; keep `flex' for compatibility + (car (semantic-lex (point) (1+ (point)))) + (let ((ct (semantic-lex-token-text + (car (semantic-lex (point) (1+ (point))))))) + (if nosnarf + nil + ;; ok, try to clean the text up. + ;; Comment start thingy + (while (string-match (concat "^\\s-*" comment-start-skip) ct) + (setq ct (concat (substring ct 0 (match-beginning 0)) + (substring ct (match-end 0))))) + ;; Arbitrary punctuation at the beginning of each line. + (while (string-match "^\\s-*\\s.+\\s-*" ct) + (setq ct (concat (substring ct 0 (match-beginning 0)) + (substring ct (match-end 0))))) + ;; End of a block comment. + (if (and (boundp 'block-comment-end) + block-comment-end + (string-match block-comment-end ct)) + (setq ct (concat (substring ct 0 (match-beginning 0)) + (substring ct (match-end 0))))) + ;; In case it's a real string, STRIPIT. + (while (string-match "\\s-*\\s\"+\\s-*" ct) + (setq ct (concat (substring ct 0 (match-beginning 0)) + (substring ct (match-end 0)))))) + ;; Now return the text. + ct)))) + -(semantic-alias-obsolete 'semantic-find-documentation - 'semantic-documentation-for-tag) - + (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 --cc lisp/cedet/semantic/find.el index 00000000000,0a7475081be..9886685cb5d mode 000000,100644..100644 --- a/lisp/cedet/semantic/find.el +++ b/lisp/cedet/semantic/find.el @@@ -1,0 -1,816 +1,705 @@@ + ;;; semantic/find.el --- Search routines for Semantic + + ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2008, 2009 + ;;; Free Software Foundation, Inc. + + ;; Author: Eric M. Ludlam + ;; Keywords: syntax + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; + ;; Routines for searching through lists of tags. + ;; There are several groups of tag search routines: + ;; + ;; 1) semantic-brute-find-tag-by-* + ;; These routines use brute force hierarchical search to scan + ;; through lists of tags. They include some parameters + ;; used for compatibility with the semantic 1.x search routines. + ;; + ;; 1.5) semantic-brute-find-first-tag-by-* + ;; Like 1, except seraching stops on the first match for the given + ;; information. + ;; + ;; 2) semantic-find-tag-by-* + ;; These prefered search routines attempt to scan through lists + ;; in an intelligent way based on questions asked. + ;; + ;; 3) semantic-find-*-overlay + ;; These routines use overlays to return tags based on a buffer position. + ;; + ;; 4) ... + ++;;; Code: ++ + (require 'semantic) + (require 'semantic/tag) + -;;; Code: - ++(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))) + -(declare-function semantic-tag-protected-p "semantic/tag-ls") - + (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 -;; -(declare-function semantic-tag-external-member-parent "semantic/sort") + + (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)))) - -;;; Compatibility Aliases -(semantic-alias-obsolete 'semantic-find-nonterminal-by-overlay - 'semantic-find-tag-by-overlay) - -(semantic-alias-obsolete 'semantic-find-nonterminal-by-overlay-in-region - 'semantic-find-tag-by-overlay-in-region) - -(semantic-alias-obsolete 'semantic-find-nonterminal-by-overlay-next - 'semantic-find-tag-by-overlay-next) - -(semantic-alias-obsolete 'semantic-find-nonterminal-by-overlay-prev - 'semantic-find-tag-by-overlay-prev) - -(semantic-alias-obsolete 'semantic-find-nonterminal-parent-by-overlay - 'semantic-find-tag-parent-by-overlay) - -(semantic-alias-obsolete 'semantic-current-nonterminal - 'semantic-current-tag) - -(semantic-alias-obsolete 'semantic-current-nonterminal-parent - 'semantic-current-tag-parent) - -(semantic-alias-obsolete 'semantic-current-nonterminal-of-type - 'semantic-current-tag-of-class) - -(semantic-alias-obsolete 'semantic-find-nonterminal-by-name - 'semantic-brute-find-first-tag-by-name) - -(semantic-alias-obsolete 'semantic-find-nonterminal-by-token - 'semantic-brute-find-tag-by-class) - -(semantic-alias-obsolete 'semantic-find-nonterminal-standard - 'semantic-brute-find-tag-standard) - -(semantic-alias-obsolete 'semantic-find-nonterminal-by-type - 'semantic-brute-find-tag-by-type) - -(semantic-alias-obsolete 'semantic-find-nonterminal-by-type-regexp - 'semantic-brute-find-tag-by-type-regexp) - -(semantic-alias-obsolete 'semantic-find-nonterminal-by-name-regexp - 'semantic-brute-find-tag-by-name-regexp) - -(semantic-alias-obsolete 'semantic-find-nonterminal-by-property - 'semantic-brute-find-tag-by-property) - -(semantic-alias-obsolete 'semantic-find-nonterminal-by-extra-spec - 'semantic-brute-find-tag-by-attribute) - -(semantic-alias-obsolete 'semantic-find-nonterminal-by-extra-spec-value - 'semantic-brute-find-tag-by-attribute-value) - -(semantic-alias-obsolete 'semantic-find-nonterminal-by-function - 'semantic-brute-find-tag-by-function) - -(semantic-alias-obsolete 'semantic-find-nonterminal-by-function-first-match - 'semantic-brute-find-first-tag-by-function) - -(semantic-alias-obsolete 'semantic-find-nonterminal-by-position - 'semantic-brute-find-tag-by-position) - -(semantic-alias-obsolete 'semantic-find-innermost-nonterminal-by-position - 'semantic-brute-find-innermost-tag-by-position) - -;;; TESTING -;; -(defun semantic-find-benchmark () - "Run some simple benchmarks to see how we are doing. -Optional argument ARG is the number of iterations to run." - (interactive) - (require 'benchmark) - (let ((f-name nil) - (b-name nil) - (f-comp) - (b-comp) - (f-regex) - ) - (garbage-collect) - (setq f-name - (benchmark-run-compiled - 1000 (semantic-find-first-tag-by-name "class3" - "test/test.cpp"))) - (garbage-collect) - (setq b-name - (benchmark-run-compiled - 1000 (semantic-brute-find-first-tag-by-name "class3" - "test/test.cpp"))) - (garbage-collect) - (setq f-comp - (benchmark-run-compiled - 1000 (semantic-find-tags-for-completion "method" - "test/test.cpp"))) - (garbage-collect) - (setq b-comp - (benchmark-run-compiled - 1000 (semantic-brute-find-tag-by-name-regexp "^method" - "test/test.cpp"))) - (garbage-collect) - (setq f-regex - (benchmark-run-compiled - 1000 (semantic-find-tags-by-name-regexp "^method" - "test/test.cpp"))) - - (message "Name [new old] [ %.3f %.3f ] Complete [newc/new old] [ %.3f/%.3f %.3f ]" - (car f-name) (car b-name) - (car f-comp) (car f-regex) - (car b-comp)) - )) + + (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 --cc lisp/cedet/semantic/format.el index 00000000000,d4c04a172c4..13945931b3f mode 000000,100644..100644 --- a/lisp/cedet/semantic/format.el +++ b/lisp/cedet/semantic/format.el @@@ -1,0 -1,772 +1,724 @@@ + ;;; semantic/format.el --- Routines for formatting tags + + ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, + ;;; 2008, 2009 Free Software Foundation, Inc. + + ;; Author: Eric M. Ludlam + ;; Keywords: syntax + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; + ;; Once a language file has been parsed into a TAG, it is often useful + ;; then display that tag information in browsers, completion engines, or + ;; help routines. The functions and setup in this file provide ways + ;; to reformat a tag into different standard output types. + ;; + ;; In addition, macros for setting up customizable variables that let + ;; the user choose their default format type are also provided. + ;; + + ;;; Code: + (eval-when-compile (require 'font-lock)) + (require 'semantic) + (require 'semantic/tag-ls) + (require 'ezimage) + + (eval-when-compile (require 'semantic/find)) + + ;;; Tag to text overload functions + ;; + ;; abbreviations, prototypes, and coloring support. + (defvar semantic-format-tag-functions + '(semantic-format-tag-name + semantic-format-tag-canonical-name + semantic-format-tag-abbreviate + semantic-format-tag-summarize + semantic-format-tag-summarize-with-file + semantic-format-tag-short-doc + semantic-format-tag-prototype + semantic-format-tag-concise-prototype + semantic-format-tag-uml-abbreviate + semantic-format-tag-uml-prototype + semantic-format-tag-uml-concise-prototype + semantic-format-tag-prin1 + ) + "List of functions which convert a tag to text. + Each function must take the parameters TAG &optional PARENT COLOR. + TAG is the tag to convert. + PARENT is a parent tag or name which refers to the structure + or class which contains TAG. PARENT is NOT a class which a TAG + would claim as a parent. + COLOR indicates that the generated text should be colored using + `font-lock'.") + -(semantic-varalias-obsolete 'semantic-token->text-functions - 'semantic-format-tag-functions) - + (defvar semantic-format-tag-custom-list + (append '(radio) + (mapcar (lambda (f) (list 'const f)) + semantic-format-tag-functions) + '(function)) + "A List used by customizeable variables to choose a tag to text function. + Use this variable in the :type field of a customizable variable.") + -(semantic-varalias-obsolete 'semantic-token->text-custom-list - 'semantic-format-tag-custom-list) - + (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.") + -(semantic-varalias-obsolete 'semantic-face-alist - 'semantic-format-face-alist) - - + + ;;; 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-face-alist'. See this variable -for details on adding new types." ++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)) + -(make-obsolete 'semantic-colorize-text - 'semantic--format-colorize-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-face-alist'. See this -variable for details on adding new types." ++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)) + -;; Semantic 1.2.x had this misspelling. Keep it for backwards compatibiity. -(semantic-alias-obsolete - 'semantic-summerize-nonterminal 'semantic-format-tag-summarize) - + ;;;###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 - )) - -;;; Compatibility and aliases -;; -(semantic-alias-obsolete 'semantic-prin1-nonterminal - 'semantic-format-tag-prin1) - -(semantic-alias-obsolete 'semantic-name-nonterminal - 'semantic-format-tag-name) - -(semantic-alias-obsolete 'semantic-abbreviate-nonterminal - 'semantic-format-tag-abbreviate) - -(semantic-alias-obsolete 'semantic-summarize-nonterminal - 'semantic-format-tag-summarize) - -(semantic-alias-obsolete 'semantic-prototype-nonterminal - 'semantic-format-tag-prototype) - -(semantic-alias-obsolete 'semantic-concise-prototype-nonterminal - 'semantic-format-tag-concise-prototype) - -(semantic-alias-obsolete 'semantic-uml-abbreviate-nonterminal - 'semantic-format-tag-uml-abbreviate) - -(semantic-alias-obsolete 'semantic-uml-prototype-nonterminal - 'semantic-format-tag-uml-prototype) - -(semantic-alias-obsolete 'semantic-uml-concise-prototype-nonterminal - 'semantic-format-tag-uml-concise-prototype) - ++ 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 --cc lisp/cedet/semantic/fw.el index 00000000000,a2e4d0f26c2..9f9bcaaea23 mode 000000,100644..100644 --- a/lisp/cedet/semantic/fw.el +++ b/lisp/cedet/semantic/fw.el @@@ -1,0 -1,497 +1,387 @@@ -;;; semantic-fw.el --- Framework for Semantic ++;;; semantic/fw.el --- Framework for Semantic + + ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, + ;;; 2007, 2008, 2009 Free Software Foundation, Inc. + + ;; Author: Eric M. Ludlam + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; + ;; Semantic has several core features shared across it's lex/parse/util + ;; stages. This used to clutter semantic.el some. These routines are all + ;; simple things that are not parser specific, but aid in making + ;; semantic flexible and compatible amongst different Emacs platforms. + + ;;; Code: + ;; + (require 'mode-local) + (require 'eieio) + (require 'semantic/loaddefs) + + ;;; Compatibility -;; -(if (featurep 'xemacs) - (progn - (defalias 'semantic-buffer-local-value 'symbol-value-in-buffer) - (defalias 'semantic-overlay-live-p - (lambda (o) - (and (extent-live-p o) - (not (extent-detached-p o)) - (bufferp (extent-buffer o))))) - (defalias 'semantic-make-overlay - (lambda (beg end &optional buffer &rest rest) - "Xemacs `make-extent', supporting the front/rear advance options." - (let ((ol (make-extent beg end buffer))) - (when rest - (set-extent-property ol 'start-open (car rest)) - (setq rest (cdr rest))) - (when rest - (set-extent-property ol 'end-open (car rest))) - ol))) - (defalias 'semantic-overlay-put 'set-extent-property) - (defalias 'semantic-overlay-get 'extent-property) - (defalias 'semantic-overlay-properties 'extent-properties) - (defalias 'semantic-overlay-move 'set-extent-endpoints) - (defalias 'semantic-overlay-delete 'delete-extent) - (defalias 'semantic-overlays-at - (lambda (pos) - (condition-case nil - (extent-list nil pos pos) - (error nil)) - )) - (defalias 'semantic-overlays-in - (lambda (beg end) (extent-list nil beg end))) - (defalias 'semantic-overlay-buffer 'extent-buffer) - (defalias 'semantic-overlay-start 'extent-start-position) - (defalias 'semantic-overlay-end 'extent-end-position) - (defalias 'semantic-overlay-size 'extent-length) - (defalias 'semantic-overlay-next-change 'next-extent-change) - (defalias 'semantic-overlay-previous-change 'previous-extent-change) - (defalias 'semantic-overlay-lists - (lambda () (list (extent-list)))) - (defalias 'semantic-overlay-p 'extentp) - (defalias 'semantic-event-window 'event-window) - (defun semantic-read-event () - (let ((event (next-command-event))) - (if (key-press-event-p event) - (let ((c (event-to-character event))) - (if (char-equal c (quit-char)) - (keyboard-quit) - c))) - event)) - (defun semantic-popup-menu (menu) - "Blockinig version of `popup-menu'" - (popup-menu menu) - ;; Wait... - (while (popup-up-p) (dispatch-event (next-event)))) - ) - ;; Emacs Bindings - (defalias 'semantic-buffer-local-value 'buffer-local-value) - (defalias 'semantic-overlay-live-p 'overlay-buffer) - (defalias 'semantic-make-overlay 'make-overlay) - (defalias 'semantic-overlay-put 'overlay-put) - (defalias 'semantic-overlay-get 'overlay-get) - (defalias 'semantic-overlay-properties 'overlay-properties) - (defalias 'semantic-overlay-move 'move-overlay) - (defalias 'semantic-overlay-delete 'delete-overlay) - (defalias 'semantic-overlays-at 'overlays-at) - (defalias 'semantic-overlays-in 'overlays-in) - (defalias 'semantic-overlay-buffer 'overlay-buffer) - (defalias 'semantic-overlay-start 'overlay-start) - (defalias 'semantic-overlay-end 'overlay-end) - (defalias 'semantic-overlay-size 'overlay-size) - (defalias 'semantic-overlay-next-change 'next-overlay-change) - (defalias 'semantic-overlay-previous-change 'previous-overlay-change) - (defalias 'semantic-overlay-lists 'overlay-lists) - (defalias 'semantic-overlay-p 'overlayp) - (defalias 'semantic-read-event 'read-event) - (defalias 'semantic-popup-menu 'popup-menu) - (defun semantic-event-window (event) - "Extract the window from EVENT." - (car (car (cdr event)))) - ) - -(if (and (not (featurep 'xemacs)) - (>= emacs-major-version 21)) - (defalias 'semantic-make-local-hook 'identity) - (defalias 'semantic-make-local-hook 'make-local-hook) - ) - -(if (featurep 'xemacs) - (defalias 'semantic-mode-line-update 'redraw-modeline) - (defalias 'semantic-mode-line-update 'force-mode-line-update)) - -;; Since Emacs 22 major mode functions should use `run-mode-hooks' to -;; run major mode hooks. -(defalias 'semantic-run-mode-hooks - (if (fboundp 'run-mode-hooks) - 'run-mode-hooks - 'run-hooks)) - -;; Fancy compat useage now handled in cedet-compat -(defalias 'semantic-subst-char-in-string 'subst-char-in-string) + ++(defalias 'semantic-buffer-local-value 'buffer-local-value) ++(defalias 'semantic-overlay-live-p 'overlay-buffer) ++(defalias 'semantic-make-overlay 'make-overlay) ++(defalias 'semantic-overlay-put 'overlay-put) ++(defalias 'semantic-overlay-get 'overlay-get) ++(defalias 'semantic-overlay-properties 'overlay-properties) ++(defalias 'semantic-overlay-move 'move-overlay) ++(defalias 'semantic-overlay-delete 'delete-overlay) ++(defalias 'semantic-overlays-at 'overlays-at) ++(defalias 'semantic-overlays-in 'overlays-in) ++(defalias 'semantic-overlay-buffer 'overlay-buffer) ++(defalias 'semantic-overlay-start 'overlay-start) ++(defalias 'semantic-overlay-end 'overlay-end) ++(defalias 'semantic-overlay-size 'overlay-size) ++(defalias 'semantic-overlay-next-change 'next-overlay-change) ++(defalias 'semantic-overlay-previous-change 'previous-overlay-change) ++(defalias 'semantic-overlay-lists 'overlay-lists) ++(defalias 'semantic-overlay-p 'overlayp) ++(defalias 'semantic-read-event 'read-event) ++(defalias 'semantic-popup-menu 'popup-menu) ++(defalias 'semantic-make-local-hook 'identity) ++(defalias 'semantic-mode-line-update 'force-mode-line-update) ++(defalias 'semantic-run-mode-hooks 'run-mode-hooks) ++(defalias 'semantic-compile-warn 'byte-compile-warn) ++(defalias 'semantic-menu-item 'identity) ++ ++(defun semantic-event-window (event) ++ "Extract the window from EVENT." ++ (car (car (cdr event)))) + + (defun semantic-delete-overlay-maybe (overlay) + "Delete OVERLAY if it is a semantic token overlay." + (if (semantic-overlay-get overlay 'semantic) + (semantic-overlay-delete overlay))) + -(defalias 'semantic-compile-warn - (eval-when-compile - (if (fboundp 'byte-compile-warn) - 'byte-compile-warn - 'message))) - -(if (not (fboundp 'string-to-number)) - (defalias 'string-to-number 'string-to-int)) - -;;; Menu Item compatibility -;; -(defun semantic-menu-item (item) - "Build an XEmacs compatible menu item from vector ITEM. -That is remove the unsupported :help stuff." - (if (featurep 'xemacs) - (let ((n (length item)) - (i 0) - slot l) - (while (< i n) - (setq slot (aref item i)) - (if (and (keywordp slot) - (eq slot :help)) - (setq i (1+ i)) - (setq l (cons slot l))) - (setq i (1+ i))) - (apply #'vector (nreverse l))) - item)) - + ;;; Positional Data Cache + ;; + (defvar semantic-cache-data-overlays nil + "List of all overlays waiting to be flushed.") + + (defun semantic-cache-data-to-buffer (buffer start end value name &optional lifespan) + "In BUFFER over the region START END, remember VALUE. + NAME specifies a special name that can be searched for later to + recover the cached data with `semantic-get-cache-data'. + LIFESPAN indicates how long the data cache will be remembered. + The default LIFESPAN is 'end-of-command. + Possible Lifespans are: + 'end-of-command - Remove the cache at the end of the currently + executing command. + 'exit-cache-zone - Remove when point leaves the overlay at the + end of the currently executing command." + ;; Check if LIFESPAN is valid before to create any overlay + (or lifespan (setq lifespan 'end-of-command)) + (or (memq lifespan '(end-of-command exit-cache-zone)) + (error "semantic-cache-data-to-buffer: Unknown LIFESPAN: %s" + lifespan)) + (let ((o (semantic-make-overlay start end buffer))) + (semantic-overlay-put o 'cache-name name) + (semantic-overlay-put o 'cached-value value) + (semantic-overlay-put o 'lifespan lifespan) + (setq semantic-cache-data-overlays + (cons o semantic-cache-data-overlays)) + ;;(message "Adding to cache: %s" o) + (add-hook 'post-command-hook 'semantic-cache-data-post-command-hook) + )) + + (defun semantic-cache-data-post-command-hook () + "Flush `semantic-cache-data-overlays' based 'lifespan property. + Remove self from `post-command-hook' if it is empty." + (let ((newcache nil) + (oldcache semantic-cache-data-overlays)) + (while oldcache + (let* ((o (car oldcache)) + (life (semantic-overlay-get o 'lifespan)) + ) + (if (or (eq life 'end-of-command) + (and (eq life 'exit-cache-zone) + (not (member o (semantic-overlays-at (point)))))) + (progn + ;;(message "Removing from cache: %s" o) + (semantic-overlay-delete o) + ) + (setq newcache (cons o newcache)))) + (setq oldcache (cdr oldcache))) + (setq semantic-cache-data-overlays (nreverse newcache))) + + ;; Remove ourselves if we have removed all overlays. + (unless semantic-cache-data-overlays + (remove-hook 'post-command-hook + 'semantic-cache-data-post-command-hook))) + + (defun semantic-get-cache-data (name &optional point) + "Get cached data with NAME from optional POINT." + (save-excursion + (if point (goto-char point)) + (let ((o (semantic-overlays-at (point))) + (ans nil)) + (while (and (not ans) o) + (if (equal (semantic-overlay-get (car o) 'cache-name) name) + (setq ans (car o)) + (setq o (cdr o)))) + (when ans + (semantic-overlay-get ans 'cached-value))))) + + ;;; Obsoleting various functions & variables + ;; + (defun semantic-overload-symbol-from-function (name) + "Return the symbol for overload used by NAME, the defined symbol." + (let ((sym-name (symbol-name name))) + (if (string-match "^semantic-" sym-name) + (intern (substring sym-name (match-end 0))) + name))) + + (defun semantic-alias-obsolete (oldfnalias newfn) + "Make OLDFNALIAS an alias for NEWFN. + Mark OLDFNALIAS as obsolete, such that the byte compiler + will throw a warning when it encounters this symbol." + (defalias oldfnalias newfn) + (make-obsolete oldfnalias newfn) + (when (and (function-overload-p newfn) + (not (overload-obsoleted-by newfn)) + ;; Only throw this warning when byte compiling things. + (boundp 'byte-compile-current-file) + byte-compile-current-file + (not (string-match "cedet" byte-compile-current-file)) + ) + (make-obsolete-overload oldfnalias newfn) + (semantic-compile-warn + "%s: `%s' obsoletes overload `%s'" + byte-compile-current-file + newfn + (semantic-overload-symbol-from-function oldfnalias)) + )) + + (defun semantic-varalias-obsolete (oldvaralias newvar) + "Make OLDVARALIAS an alias for variable NEWVAR. + Mark OLDVARALIAS as obsolete, such that the byte compiler + will throw a warning when it encounters this symbol." + (make-obsolete-variable oldvaralias newvar) + (condition-case nil + (defvaralias oldvaralias newvar) + (error + ;; Only throw this warning when byte compiling things. + (when (and (boundp 'byte-compile-current-file) + byte-compile-current-file) + (semantic-compile-warn + "variable `%s' obsoletes, but isn't alias of `%s'" + newvar oldvaralias) + )))) + + ;;; Help debugging + ;; + (defmacro semantic-safe (format &rest body) + "Turn into a FORMAT message any error caught during eval of BODY. + Return the value of last BODY form or nil if an error occurred. + FORMAT can have a %s escape which will be replaced with the actual + error message. + If `debug-on-error' is set, errors are not caught, so that you can + debug them. + Avoid using a large BODY since it is duplicated." + ;;(declare (debug t) (indent 1)) + `(if debug-on-error + ;;(let ((inhibit-quit nil)) ,@body) + ;; Note to self: Doing the above screws up the wisent parser. + (progn ,@body) + (condition-case err + (progn ,@body) + (error + (message ,format (format "%S - %s" (current-buffer) + (error-message-string err))) + nil)))) + (put 'semantic-safe 'lisp-indent-function 1) + + ;;; Misc utilities + ;; + (defsubst semantic-map-buffers (function) + "Run FUNCTION for each Semantic enabled buffer found. + FUNCTION does not have arguments. When FUNCTION is entered + `current-buffer' is a selected Semantic enabled buffer." + (mode-local-map-file-buffers function #'semantic-active-p)) + -(defalias 'semantic-map-mode-buffers - 'mode-local-map-mode-buffers) - -(semantic-alias-obsolete 'semantic-fetch-overload - 'fetch-overload) ++(defalias 'semantic-map-mode-buffers 'mode-local-map-mode-buffers) + + (semantic-alias-obsolete 'define-mode-overload-implementation + 'define-mode-local-override) + -(semantic-alias-obsolete 'semantic-with-mode-bindings - 'with-mode-local) - -(semantic-alias-obsolete 'define-semantic-child-mode - 'define-child-mode) - + (defun semantic-install-function-overrides (overrides &optional transient mode) + "Install the function OVERRIDES in the specified environment. + OVERRIDES must be an alist ((OVERLOAD . FUNCTION) ...) where OVERLOAD + is a symbol identifying an overloadable entry, and FUNCTION is the + function to override it with. + If optional argument TRANSIENT is non-nil, installed overrides can in + turn be overridden by next installation. + If optional argument MODE is non-nil, it must be a major mode symbol. + OVERRIDES will be installed globally for this major mode. If MODE is + nil, OVERRIDES will be installed locally in the current buffer. This + later installation should be done in MODE hook." + (mode-local-bind + ;; Add the semantic- prefix to OVERLOAD short names. + (mapcar + #'(lambda (e) + (let ((name (symbol-name (car e)))) + (if (string-match "^semantic-" name) + e + (cons (intern (format "semantic-%s" name)) (cdr e))))) + overrides) + (list 'constant-flag (not transient) + 'override-flag t) + mode)) + + ;;; 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.") ++;; ;;; 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 ++;;; semantic/fw.el ends here diff --cc lisp/cedet/semantic/grammar.el index 00000000000,5d947551d48..f47275bdcf6 mode 000000,100644..100644 --- a/lisp/cedet/semantic/grammar.el +++ b/lisp/cedet/semantic/grammar.el @@@ -1,0 -1,1912 +1,1897 @@@ + ;;; semantic/grammar.el --- Major mode framework for Semantic grammars + + ;;; Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008, 2009 + ;;; Free Software Foundation, Inc. + + ;; Author: David Ponce + ;; Maintainer: David Ponce + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; + ;; Major mode framework for editing Semantic's input grammar files. + + ;;; History: + ;; + + ;;; Code: + + (require 'semantic) + (require 'semantic/ctxt) + (require 'semantic/format) + (require 'semantic/grammar-wy) + (require 'semantic/idle) + (declare-function semantic-momentary-highlight-tag "semantic/decorate") + (declare-function semantic-analyze-context "semantic/analyze") + (declare-function semantic-analyze-tags-of-class-list + "semantic/analyze/complete") + - -;; (eval-when-compile -;; (require 'semantic/analyze)) - + (eval-when-compile + (require 'eldoc) + (require 'semantic/edit) + (require 'semantic/find)) + -;;(require 'semantic/wisent) -;; (require 'font-lock) -;; (require 'pp) - -;; (eval-when-compile -;; ;; (require 'senator) -;; (require 'semantic/edit) -;; (require 'semantic/find) -;; (require 'semantic/format) -;; (require 'semantic/idle)) - + + ;;;; + ;;;; Set up lexer + ;;;; + + (defconst semantic-grammar-lex-c-char-re "'\\s\\?.'" + "Regexp matching C-like character literals.") + + ;; Most of the analyzers are auto-generated from the grammar, but the + ;; following which need special handling code. + ;; + (define-lex-regex-analyzer semantic-grammar-lex-prologue + "Detect and create a prologue token." + "\\<%{" + ;; Zing to the end of this brace block. + (semantic-lex-push-token + (semantic-lex-token + 'PROLOGUE (point) + (save-excursion + (semantic-lex-unterminated-syntax-protection 'PROLOGUE + (forward-char) + (forward-sexp 1) + (point)))))) + + (defsubst semantic-grammar-epilogue-start () + "Return the start position of the grammar epilogue." + (save-excursion + (goto-char (point-min)) + (if (re-search-forward "^\\s-*\\<%%\\>\\s-*$" nil t 2) + (match-beginning 0) + (1+ (point-max))))) + + (define-lex-regex-analyzer semantic-grammar-lex-epilogue + "Detect and create an epilogue or percent-percent token." + "\\<%%\\>" + (let ((start (match-beginning 0)) + (end (match-end 0)) + (class 'PERCENT_PERCENT)) + (when (>= start (semantic-grammar-epilogue-start)) + (setq class 'EPILOGUE + end (point-max))) + (semantic-lex-push-token + (semantic-lex-token class start end)))) + + (define-lex semantic-grammar-lexer + "Lexical analyzer that handles Semantic grammar buffers. + It ignores whitespaces, newlines and comments." + semantic-lex-ignore-newline + semantic-lex-ignore-whitespace + ;; Must detect prologue/epilogue before other symbols/keywords! + semantic-grammar-lex-prologue + semantic-grammar-lex-epilogue + semantic-grammar-wy---keyword-analyzer + semantic-grammar-wy---regexp-analyzer + semantic-grammar-wy---regexp-analyzer + semantic-grammar-wy---sexp-analyzer + ;; Must detect comments after strings because `comment-start-skip' + ;; regexp match semicolons inside strings! + semantic-lex-ignore-comments + ;; Must detect prefixed list before punctuation because prefix chars + ;; are also punctuations! + semantic-grammar-wy---sexp-analyzer + ;; Must detect punctuations after comments because the semicolon can + ;; be a punctuation or a comment start! + semantic-grammar-wy---string-analyzer + semantic-grammar-wy---block-analyzer + semantic-grammar-wy---sexp-analyzer) + + ;;; Test the lexer + ;; + (defun semantic-grammar-lex-buffer () + "Run `semantic-grammar-lex' on current buffer." + (interactive) + (semantic-lex-init) + (setq semantic-lex-analyzer 'semantic-grammar-lexer) + (let ((token-stream + (semantic-lex (point-min) (point-max)))) + (with-current-buffer (get-buffer-create "*semantic-grammar-lex*") + (erase-buffer) + (pp token-stream (current-buffer)) + (goto-char (point-min)) + (pop-to-buffer (current-buffer))))) + + ;;;; + ;;;; Semantic action expansion + ;;;; + + (defun semantic-grammar-ASSOC (&rest args) + "Return expansion of built-in ASSOC expression. + ARGS are ASSOC's key value list." + (let ((key t)) + `(semantic-tag-make-assoc-list + ,@(mapcar #'(lambda (i) + (prog1 + (if key + (list 'quote i) + i) + (setq key (not key)))) + args)))) + + (defsubst semantic-grammar-quote-p (sym) + "Return non-nil if SYM is bound to the `quote' function." + (condition-case nil + (eq (indirect-function sym) + (indirect-function 'quote)) + (error nil))) + + (defsubst semantic-grammar-backquote-p (sym) + "Return non-nil if SYM is bound to the `backquote' function." + (condition-case nil + (eq (indirect-function sym) + (indirect-function 'backquote)) + (error nil))) + + ;;;; + ;;;; API to access grammar tags + ;;;; + + (define-mode-local-override semantic-tag-components + semantic-grammar-mode (tag) + "Return the children of tag TAG." + (semantic-tag-get-attribute tag :children)) + + (defun semantic-grammar-first-tag-name (class) + "Return the name of the first tag of class CLASS found. + Warn if other tags of class CLASS exist." + (let* ((tags (semantic-find-tags-by-class + class (current-buffer)))) + (if tags + (prog1 + (semantic-tag-name (car tags)) + (if (cdr tags) + (message "*** Ignore all but first declared %s" + class)))))) + + (defun semantic-grammar-tag-symbols (class) + "Return the list of symbols defined in tags of class CLASS. + That is tag names plus names defined in tag attribute `:rest'." + (let* ((tags (semantic-find-tags-by-class + class (current-buffer)))) + (apply 'append + (mapcar + #'(lambda (tag) + (mapcar + 'intern + (cons (semantic-tag-name tag) + (semantic-tag-get-attribute tag :rest)))) + tags)))) + + (defsubst semantic-grammar-item-text (item) + "Return the readable string form of ITEM." + (if (string-match semantic-grammar-lex-c-char-re item) + (concat "?" (substring item 1 -1)) + item)) + + (defsubst semantic-grammar-item-value (item) + "Return symbol or character value of ITEM string." + (if (string-match semantic-grammar-lex-c-char-re item) + (let ((c (read (concat "?" (substring item 1 -1))))) + (if (featurep 'xemacs) + ;; Handle characters as integers in XEmacs like in GNU Emacs. + (char-int c) + c)) + (intern item))) + + (defun semantic-grammar-prologue () + "Return grammar prologue code as a string value." + (let ((tag (semantic-find-first-tag-by-name + "prologue" + (semantic-find-tags-by-class 'code (current-buffer))))) + (if tag + (save-excursion + (concat + (buffer-substring + (progn + (goto-char (semantic-tag-start tag)) + (skip-chars-forward "%{\r\n\t ") + (point)) + (progn + (goto-char (semantic-tag-end tag)) + (skip-chars-backward "\r\n\t %}") + (point))) + "\n")) + ""))) + + (defun semantic-grammar-epilogue () + "Return grammar epilogue code as a string value." + (let ((tag (semantic-find-first-tag-by-name + "epilogue" + (semantic-find-tags-by-class 'code (current-buffer))))) + (if tag + (save-excursion + (concat + (buffer-substring + (progn + (goto-char (semantic-tag-start tag)) + (skip-chars-forward "%\r\n\t ") + (point)) + (progn + (goto-char (semantic-tag-end tag)) + (skip-chars-backward "\r\n\t") + ;; If a grammar footer is found, skip it. + (re-search-backward "^;;;\\s-+\\S-+\\s-+ends here" + (save-excursion + (beginning-of-line) + (point)) + t) + (skip-chars-backward "\r\n\t") + (point))) + "\n")) + ""))) + + (defsubst semantic-grammar-buffer-file (&optional buffer) + "Return name of file sans directory BUFFER is visiting. + No argument or nil as argument means use the current buffer." + (file-name-nondirectory (buffer-file-name buffer))) + + (defun semantic-grammar-package () + "Return the %package value as a string. + If there is no %package statement in the grammar, return a default + package name derived from the grammar file name. For example, the + default package name for the grammar file foo.wy is foo-wy, and for + foo.by it is foo-by." + (or (semantic-grammar-first-tag-name 'package) + (let* ((file (semantic-grammar-buffer-file)) + (ext (file-name-extension file)) + (i (string-match (format "\\([.]\\)%s\\'" ext) file))) + (concat (substring file 0 i) "-" ext)))) + + (defsubst semantic-grammar-languagemode () + "Return the %languagemode value as a list of symbols or nil." + (semantic-grammar-tag-symbols 'languagemode)) + + (defsubst semantic-grammar-start () + "Return the %start value as a list of symbols or nil." + (semantic-grammar-tag-symbols 'start)) + + (defsubst semantic-grammar-scopestart () + "Return the %scopestart value as a symbol or nil." + (intern (or (semantic-grammar-first-tag-name 'scopestart) "nil"))) + + (defsubst semantic-grammar-quotemode () + "Return the %quotemode value as a symbol or nil." + (intern (or (semantic-grammar-first-tag-name 'quotemode) "nil"))) + + (defsubst semantic-grammar-keywords () + "Return the language keywords. + That is an alist of (VALUE . TOKEN) where VALUE is the string value of + the keyword and TOKEN is the terminal symbol identifying the keyword." + (mapcar + #'(lambda (key) + (cons (semantic-tag-get-attribute key :value) + (intern (semantic-tag-name key)))) + (semantic-find-tags-by-class 'keyword (current-buffer)))) + + (defun semantic-grammar-keyword-properties (keywords) + "Return the list of KEYWORDS properties." + (let ((puts (semantic-find-tags-by-class + 'put (current-buffer))) + put keys key plist assoc pkey pval props) + (while puts + (setq put (car puts) + puts (cdr puts) + keys (mapcar + 'intern + (cons (semantic-tag-name put) + (semantic-tag-get-attribute put :rest)))) + (while keys + (setq key (car keys) + keys (cdr keys) + assoc (rassq key keywords)) + (if (null assoc) + nil ;;(message "*** %%put to undefined keyword %s ignored" key) + (setq key (car assoc) + plist (semantic-tag-get-attribute put :value)) + (while plist + (setq pkey (intern (caar plist)) + pval (read (cdar plist)) + props (cons (list key pkey pval) props) + plist (cdr plist)))))) + props)) + + (defun semantic-grammar-tokens () + "Return defined lexical tokens. + That is an alist (TYPE . DEFS) where type is a %token symbol + and DEFS is an alist of (TOKEN . VALUE). TOKEN is the terminal symbol + identifying the token and VALUE is the string value of the token or + nil." + (let (tags alist assoc tag type term names value) + + ;; Check for in %left, %right & %nonassoc declarations + (setq tags (semantic-find-tags-by-class + 'assoc (current-buffer))) + (while tags + (setq tag (car tags) + tags (cdr tags)) + (when (setq type (semantic-tag-type tag)) + (setq names (semantic-tag-get-attribute tag :value) + assoc (assoc type alist)) + (or assoc (setq assoc (list type) + alist (cons assoc alist))) + (while names + (setq term (car names) + names (cdr names)) + (or (string-match semantic-grammar-lex-c-char-re term) + (setcdr assoc (cons (list (intern term)) + (cdr assoc))))))) + + ;; Then process %token declarations so they can override any + ;; previous specifications + (setq tags (semantic-find-tags-by-class + 'token (current-buffer))) + (while tags + (setq tag (car tags) + tags (cdr tags)) + (setq names (cons (semantic-tag-name tag) + (semantic-tag-get-attribute tag :rest)) + type (or (semantic-tag-type tag) "") + value (semantic-tag-get-attribute tag :value) + assoc (assoc type alist)) + (or assoc (setq assoc (list type) + alist (cons assoc alist))) + (while names + (setq term (intern (car names)) + names (cdr names)) + (setcdr assoc (cons (cons term value) (cdr assoc))))) + alist)) + + (defun semantic-grammar-token-%type-properties (&optional props) + "Return properties set by %type statements. + This declare a new type if necessary. + If optional argument PROPS is non-nil, it is an existing list of + properties where to add new properties." + (let (type) + (dolist (tag (semantic-find-tags-by-class 'type (current-buffer))) + (setq type (semantic-tag-name tag)) + ;; Indicate to auto-generate the analyzer for this type + (push (list type :declared t) props) + (dolist (e (semantic-tag-get-attribute tag :value)) + (push (list type (intern (car e)) (read (or (cdr e) "nil"))) + props))) + props)) + + (defun semantic-grammar-token-%put-properties (tokens) + "For types found in TOKENS, return properties set by %put statements." + (let (found props) + (dolist (put (semantic-find-tags-by-class 'put (current-buffer))) + (dolist (type (cons (semantic-tag-name put) + (semantic-tag-get-attribute put :rest))) + (setq found (assoc type tokens)) + (if (null found) + nil ;; %put ignored, no token defined + (setq type (car found)) + (dolist (e (semantic-tag-get-attribute put :value)) + (push (list type (intern (car e)) (read (or (cdr e) "nil"))) + props))))) + props)) + + (defsubst semantic-grammar-token-properties (tokens) + "Return properties of declared types. + Types are explicitly declared by %type statements. Types found in + TOKENS are those declared implicitly by %token statements. + Properties can be set by %put and %type statements. + Properties set by %type statements take precedence over those set by + %put statements." + (let ((props (semantic-grammar-token-%put-properties tokens))) + (semantic-grammar-token-%type-properties props))) + + (defun semantic-grammar-use-macros () + "Return macro definitions from %use-macros statements. + Also load the specified macro libraries." + (let (lib defs) + (dolist (tag (semantic-find-tags-by-class 'macro (current-buffer))) + (setq lib (intern (semantic-tag-type tag))) + (condition-case nil + ;;(load lib) ;; Be sure to use the latest macro library. + (require lib) + (error nil)) + (dolist (mac (semantic-tag-get-attribute tag :value)) + (push (cons (intern mac) + (intern (format "%s-%s" lib mac))) + defs))) + (nreverse defs))) + + (defvar semantic-grammar-macros nil + "List of associations (MACRO-NAME . EXPANDER).") + (make-variable-buffer-local 'semantic-grammar-macros) + + (defun semantic-grammar-macros () + "Build and return the alist of defined macros." + (append + ;; Definitions found in tags. + (semantic-grammar-use-macros) + ;; Other pre-installed definitions. + semantic-grammar-macros)) + + ;;;; + ;;;; Overloaded functions that build parser data. + ;;;; + + ;;; Keyword table builder + ;; + (defun semantic-grammar-keywordtable-builder-default () + "Return the default value of the keyword table." + (let ((keywords (semantic-grammar-keywords))) + `(semantic-lex-make-keyword-table + ',keywords + ',(semantic-grammar-keyword-properties keywords)))) + + (define-overloadable-function semantic-grammar-keywordtable-builder () + "Return the keyword table table value.") + + ;;; Token table builder + ;; + (defun semantic-grammar-tokentable-builder-default () + "Return the default value of the table of lexical tokens." + (let ((tokens (semantic-grammar-tokens))) + `(semantic-lex-make-type-table + ',tokens + ',(semantic-grammar-token-properties tokens)))) + + (define-overloadable-function semantic-grammar-tokentable-builder () + "Return the value of the table of lexical tokens.") + + ;;; Parser table builder + ;; + (defun semantic-grammar-parsetable-builder-default () + "Return the default value of the parse table." + (error "`semantic-grammar-parsetable-builder' not defined")) + + (define-overloadable-function semantic-grammar-parsetable-builder () + "Return the parser table value.") + + ;;; Parser setup code builder + ;; + (defun semantic-grammar-setupcode-builder-default () + "Return the default value of the setup code form." + (error "`semantic-grammar-setupcode-builder' not defined")) + + (define-overloadable-function semantic-grammar-setupcode-builder () + "Return the parser setup code form.") + + ;;;; + ;;;; Lisp code generation + ;;;; + (defvar semantic--grammar-input-buffer nil) + (defvar semantic--grammar-output-buffer nil) + + (defsubst semantic-grammar-keywordtable () + "Return the variable name of the keyword table." + (concat (file-name-sans-extension + (semantic-grammar-buffer-file + semantic--grammar-output-buffer)) + "--keyword-table")) + + (defsubst semantic-grammar-tokentable () + "Return the variable name of the token table." + (concat (file-name-sans-extension + (semantic-grammar-buffer-file + semantic--grammar-output-buffer)) + "--token-table")) + + (defsubst semantic-grammar-parsetable () + "Return the variable name of the parse table." + (concat (file-name-sans-extension + (semantic-grammar-buffer-file + semantic--grammar-output-buffer)) + "--parse-table")) + + (defsubst semantic-grammar-setupfunction () + "Return the name of the parser setup function." + (concat (file-name-sans-extension + (semantic-grammar-buffer-file + semantic--grammar-output-buffer)) + "--install-parser")) + + (defmacro semantic-grammar-as-string (object) + "Return OBJECT as a string value." + `(if (stringp ,object) + ,object + ;;(require 'pp) + (pp-to-string ,object))) + + (defun semantic-grammar-insert-defconst (name value docstring) + "Insert declaration of constant NAME with VALUE and DOCSTRING." + (let ((start (point))) + (insert (format "(defconst %s\n%s%S)\n\n" name value docstring)) + (save-excursion + (goto-char start) + (indent-sexp)))) + + (defun semantic-grammar-insert-defun (name body docstring) + "Insert declaration of function NAME with BODY and DOCSTRING." + (let ((start (point))) + (insert (format "(defun %s ()\n%S\n%s)\n\n" name docstring body)) + (save-excursion + (goto-char start) + (indent-sexp)))) + + (defun semantic-grammar-insert-define (define) + "Insert the declaration specified by DEFINE expression. + Typically a DEFINE expression should look like this: + + \(define-thing name docstring expression1 ...)" + ;;(require 'pp) + (let ((start (point))) + (insert (format "(%S %S" (car define) (nth 1 define))) + (dolist (item (nthcdr 2 define)) + (insert "\n") + (delete-blank-lines) + (pp item (current-buffer))) + (insert ")\n\n") + (save-excursion + (goto-char start) + (indent-sexp)))) + + (defconst semantic-grammar-header-template + '("\ + ;;; " file " --- Generated parser support file + + " copy " + + ;; Author: " user-full-name " <" user-mail-address "> + ;; Created: " date " + ;; Keywords: syntax + ;; X-RCS: " vcid " + + ;; This file is not part of GNU Emacs. + ;; + ;; This program is free software; you can redistribute it and/or + ;; modify it under the terms of the GNU General Public License as + ;; published by the Free Software Foundation; either version 2, or (at + ;; your option) any later version. + ;; + ;; This software is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + ;; General Public License for more details. + ;; + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs; see the file COPYING. If not, write to the + ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + ;; Boston, MA 02110-1301, USA. + + ;;; Commentary: + ;; + ;; PLEASE DO NOT MANUALLY EDIT THIS FILE! It is automatically + ;; generated from the grammar file " gram ". + + ;;; History: + ;; + + ;;; Code: + ") + "Generated header template. + The symbols in the template are local variables in + `semantic-grammar-header'") + + (defconst semantic-grammar-footer-template + '("\ + + \(provide '" libr ") + + ;;; " file " ends here + ") + "Generated footer template. + The symbols in the list are local variables in + `semantic-grammar-footer'.") + + (defun semantic-grammar-copyright-line () + "Return the grammar copyright line, or nil if not found." + (save-excursion + (goto-char (point-min)) + (when (re-search-forward "^;;+[ \t]+Copyright (C) .*$" + ;; Search only in the four top lines + (save-excursion (forward-line 4) (point)) + t) + (match-string 0)))) + + (defun semantic-grammar-header () + "Return text of a generated standard header." + (let ((file (semantic-grammar-buffer-file + semantic--grammar-output-buffer)) + (gram (semantic-grammar-buffer-file)) + (date (format-time-string "%Y-%m-%d %T%z")) + (vcid (concat "$" "Id" "$")) ;; Avoid expansion + ;; Try to get the copyright from the input grammar, or + ;; generate a new one if not found. + (copy (or (semantic-grammar-copyright-line) + (concat (format-time-string ";; Copyright (C) %Y ") + user-full-name))) + (out "")) + (dolist (S semantic-grammar-header-template) + (cond ((stringp S) + (setq out (concat out S))) + ((symbolp S) + (setq out (concat out (symbol-value S)))))) + out)) + + (defun semantic-grammar-footer () + "Return text of a generated standard footer." + (let* ((file (semantic-grammar-buffer-file + semantic--grammar-output-buffer)) + (libr (file-name-sans-extension file)) + (out "")) + (dolist (S semantic-grammar-footer-template) + (cond ((stringp S) + (setq out (concat out S))) + ((symbolp S) + (setq out (concat out (symbol-value S)))))) + out)) + + (defun semantic-grammar-token-data () + "Return the string value of the table of lexical tokens." + (semantic-grammar-as-string + (semantic-grammar-tokentable-builder))) + + (defun semantic-grammar-keyword-data () + "Return the string value of the table of keywords." + (semantic-grammar-as-string + (semantic-grammar-keywordtable-builder))) + + (defun semantic-grammar-parser-data () + "Return the parser table as a string value." + (semantic-grammar-as-string + (semantic-grammar-parsetable-builder))) + + (defun semantic-grammar-setup-data () + "Return the parser setup code form as a string value." + (semantic-grammar-as-string + (semantic-grammar-setupcode-builder))) + + ;;; Generation of lexical analyzers. + ;; + (defvar semantic-grammar--lex-block-specs) + + (defsubst semantic-grammar--lex-delim-spec (block-spec) + "Return delimiters specification from BLOCK-SPEC." + (condition-case nil + (let* ((standard-input (cdr block-spec)) + (delim-spec (read))) + (if (and (consp delim-spec) + (car delim-spec) (symbolp (car delim-spec)) + (cadr delim-spec) (symbolp (cadr delim-spec))) + delim-spec + (error))) + (error + (error "Invalid delimiters specification %s in block token %s" + (cdr block-spec) (car block-spec))))) + + (defun semantic-grammar--lex-block-specs () + "Compute lexical block specifications for the current buffer. + Block definitions are read from the current table of lexical types." + (cond + ;; Block specifications have been parsed and are invalid. + ((eq semantic-grammar--lex-block-specs 'error) + nil + ) + ;; Parse block specifications. + ((null semantic-grammar--lex-block-specs) + (condition-case err + (let* ((blocks (cdr (semantic-lex-type-value "block" t))) + (open-delims (cdr (semantic-lex-type-value "open-paren" t))) + (close-delims (cdr (semantic-lex-type-value "close-paren" t))) + olist clist block-spec delim-spec open-spec close-spec) + (dolist (block-spec blocks) + (setq delim-spec (semantic-grammar--lex-delim-spec block-spec) + open-spec (assq (car delim-spec) open-delims) + close-spec (assq (cadr delim-spec) close-delims)) + (or open-spec + (error "Missing open-paren token %s required by block %s" + (car delim-spec) (car block-spec))) + (or close-spec + (error "Missing close-paren token %s required by block %s" + (cdr delim-spec) (car block-spec))) + ;; build alist ((OPEN-DELIM OPEN-SYM BLOCK-SYM) ...) + (push (list (cdr open-spec) (car open-spec) (car block-spec)) + olist) + ;; build alist ((CLOSE-DELIM CLOSE-SYM) ...) + (push (list (cdr close-spec) (car close-spec)) + clist)) + (setq semantic-grammar--lex-block-specs (cons olist clist))) + (error + (setq semantic-grammar--lex-block-specs 'error) + (message "%s" (error-message-string err)) + nil)) + ) + ;; Block specifications already parsed. + (t + semantic-grammar--lex-block-specs))) + + (defsubst semantic-grammar-quoted-form (exp) + "Return a quoted form of EXP if it isn't a self evaluating form." + (if (and (not (null exp)) + (or (listp exp) (symbolp exp))) + (list 'quote exp) + exp)) + + (defun semantic-grammar-insert-defanalyzer (type) + "Insert declaration of the lexical analyzer defined with TYPE." + (let* ((type-name (symbol-name type)) + (type-value (symbol-value type)) + (syntax (get type 'syntax)) + (declared (get type :declared)) + spec mtype prefix name doc) + ;; Generate an analyzer if the corresponding type has been + ;; explicitly declared in a %type statement, and if at least the + ;; syntax property has been provided. + (when (and declared syntax) + (setq prefix (file-name-sans-extension + (semantic-grammar-buffer-file + semantic--grammar-output-buffer)) + mtype (or (get type 'matchdatatype) 'regexp) + name (intern (format "%s--<%s>-%s-analyzer" prefix type mtype)) + doc (format "%s analyzer for <%s> tokens." mtype type)) + (cond + ;; Regexp match analyzer + ((eq mtype 'regexp) + (semantic-grammar-insert-define + `(define-lex-regex-type-analyzer ,name + ,doc ,syntax + ,(semantic-grammar-quoted-form (cdr type-value)) + ',(or (car type-value) (intern type-name)))) + ) + ;; String compare analyzer + ((eq mtype 'string) + (semantic-grammar-insert-define + `(define-lex-string-type-analyzer ,name + ,doc ,syntax + ,(semantic-grammar-quoted-form (cdr type-value)) + ',(or (car type-value) (intern type-name)))) + ) + ;; Block analyzer + ((and (eq mtype 'block) + (setq spec (semantic-grammar--lex-block-specs))) + (semantic-grammar-insert-define + `(define-lex-block-type-analyzer ,name + ,doc ,syntax + ,(semantic-grammar-quoted-form spec))) + ) + ;; Sexp analyzer + ((eq mtype 'sexp) + (semantic-grammar-insert-define + `(define-lex-sexp-type-analyzer ,name + ,doc ,syntax + ',(or (car type-value) (intern type-name)))) + ) + ;; keyword analyzer + ((eq mtype 'keyword) + (semantic-grammar-insert-define + `(define-lex-keyword-type-analyzer ,name + ,doc ,syntax)) + ) + )) + )) + + (defun semantic-grammar-insert-defanalyzers () + "Insert declarations of lexical analyzers." + (let (tokens props) + (with-current-buffer semantic--grammar-input-buffer + (setq tokens (semantic-grammar-tokens) + props (semantic-grammar-token-properties tokens))) + (insert "(require 'semantic-lex)\n\n") + (let ((semantic-lex-types-obarray + (semantic-lex-make-type-table tokens props)) + semantic-grammar--lex-block-specs) + (mapatoms 'semantic-grammar-insert-defanalyzer + semantic-lex-types-obarray)))) + + ;;; Generation of the grammar support file. + ;; + (defcustom semantic-grammar-file-regexp "\\.[wb]y$" + "Regexp which matches grammar source files." + :group 'semantic + :type 'regexp) + + (defsubst semantic-grammar-noninteractive () + "Return non-nil if running without interactive terminal." + (if (featurep 'xemacs) + (noninteractive) + noninteractive)) + + (defun semantic-grammar-create-package (&optional force) + "Create package Lisp code from grammar in current buffer. + Does nothing if the Lisp code seems up to date. + If optional argument FORCE is non-nil, unconditionally re-generate the + Lisp code." + (interactive "P") + (setq force (or force current-prefix-arg)) + (semantic-fetch-tags) + (let* ( + ;; Values of the following local variables are obtained from + ;; the grammar parsed tree in current buffer, that is before + ;; switching to the output file. + (package (semantic-grammar-package)) + (output (concat package ".el")) + (semantic--grammar-input-buffer (current-buffer)) + (semantic--grammar-output-buffer (find-file-noselect output)) + (header (semantic-grammar-header)) + (prologue (semantic-grammar-prologue)) + (epilogue (semantic-grammar-epilogue)) + (footer (semantic-grammar-footer)) + ) + (if (and (not force) + (not (buffer-modified-p)) + (file-newer-than-file-p + (buffer-file-name semantic--grammar-output-buffer) + (buffer-file-name semantic--grammar-input-buffer))) + (message "Package `%s' is up to date." package) + ;; Create the package + (set-buffer semantic--grammar-output-buffer) + ;; Use Unix EOLs, so that the file is portable to all platforms. + (setq buffer-file-coding-system 'raw-text-unix) + (erase-buffer) + (unless (eq major-mode 'emacs-lisp-mode) + (emacs-lisp-mode)) + + ;;;; Header + Prologue + + (insert header + " \n;;; Prologue\n;;\n" + prologue + ) + ;; Evaluate the prologue now, because it might provide definition + ;; of grammar macro expanders. + (eval-region (point-min) (point)) + + (save-excursion + + ;;;; Declarations + + (insert " \n;;; Declarations\n;;\n") + + ;; `eval-defun' is not necessary to reset `defconst' values. + (semantic-grammar-insert-defconst + (semantic-grammar-keywordtable) + (with-current-buffer semantic--grammar-input-buffer + (semantic-grammar-keyword-data)) + "Table of language keywords.") + + (semantic-grammar-insert-defconst + (semantic-grammar-tokentable) + (with-current-buffer semantic--grammar-input-buffer + (semantic-grammar-token-data)) + "Table of lexical tokens.") + + (semantic-grammar-insert-defconst + (semantic-grammar-parsetable) + (with-current-buffer semantic--grammar-input-buffer + (semantic-grammar-parser-data)) + "Parser table.") + + (semantic-grammar-insert-defun + (semantic-grammar-setupfunction) + (with-current-buffer semantic--grammar-input-buffer + (semantic-grammar-setup-data)) + "Setup the Semantic Parser.") + + ;;;; Analyzers + (insert " \n;;; Analyzers\n;;\n") + + (semantic-grammar-insert-defanalyzers) + + ;;;; Epilogue & Footer + + (insert " \n;;; Epilogue\n;;\n" + epilogue + footer + ) + + ) + + (save-buffer 16) + + ;; If running in batch mode, there is nothing more to do. + ;; Save the generated file and quit. + (if (semantic-grammar-noninteractive) + (let ((version-control t) + (delete-old-versions t) + (make-backup-files t) + (vc-make-backup-files t)) + (kill-buffer (current-buffer))) + ;; If running interactively, eval declarations and epilogue + ;; code, then pop to the buffer visiting the generated file. + (eval-region (point) (point-max)) + (goto-char (point-min)) + (pop-to-buffer (current-buffer)) + ;; The generated code has been evaluated and updated into + ;; memory. Now find all buffers that match the major modes we + ;; have created this language for, and force them to call our + ;; setup function again, refreshing all semantic data, and + ;; enabling them to work with the new code just created. + ;;;; FIXME? + ;; At this point, I don't know any user's defined setup code :-( + ;; At least, what I can do for now, is to run the generated + ;; parser-install function. + (semantic-map-mode-buffers + (semantic-grammar-setupfunction) + (semantic-grammar-languagemode))) + ) + ;; Return the name of the generated package file. + output)) + + (defun semantic-grammar-recreate-package () + "Unconditionnaly create Lisp code from grammar in current buffer. + Like \\[universal-argument] \\[semantic-grammar-create-package]." + (interactive) + (semantic-grammar-create-package t)) + + (defun semantic-grammar-batch-build-one-package (file) + "Build a Lisp package from the grammar in FILE. + That is, generate Lisp code from FILE, and `byte-compile' it. + Return non-nil if there were no errors, nil if errors." + ;; We need this require so that we can find `byte-compile-dest-file'. + (require 'bytecomp) + (unless (auto-save-file-name-p file) + ;; Create the package + (let ((packagename + (condition-case err + (with-current-buffer (find-file-noselect file) + (semantic-grammar-create-package)) + (error + (message "%s" (error-message-string err)) + nil)))) + (when packagename + ;; Only byte compile if out of date + (if (file-newer-than-file-p + packagename (byte-compile-dest-file packagename)) + (let (;; Some complex grammar table expressions need a few + ;; more resources than the default. + (max-specpdl-size (max 3000 max-specpdl-size)) + (max-lisp-eval-depth (max 1000 max-lisp-eval-depth)) + ) + ;; byte compile the resultant file + (byte-compile-file packagename)) + t))))) + + (defun semantic-grammar-batch-build-packages () + "Build Lisp packages from grammar files on the command line. + That is, run `semantic-grammar-batch-build-one-package' for each file. + Each file is processed even if an error occurred previously. + Must be used from the command line, with `-batch'. + For example, to process grammar files in current directory, invoke: + + \"emacs -batch -f semantic-grammar-batch-build-packages .\". + + See also the variable `semantic-grammar-file-regexp'." + (or (semantic-grammar-noninteractive) + (error "\ + `semantic-grammar-batch-build-packages' must be used with -batch" + )) + (let ((status 0) + ;; Remove vc from find-file-hook. It causes bad stuff to + ;; happen in Emacs 20. + (find-file-hook (delete 'vc-find-file-hook find-file-hook))) + (message "Compiling Grammars from: %s" (locate-library "semantic-grammar")) + (dolist (arg command-line-args-left) + (unless (and arg (file-exists-p arg)) + (error "Argument %s is not a valid file name" arg)) + (setq arg (expand-file-name arg)) + (if (file-directory-p arg) + ;; Directory as argument + (dolist (src (condition-case nil + (directory-files + arg nil semantic-grammar-file-regexp) + (error + (error "Unable to read directory files")))) + (or (semantic-grammar-batch-build-one-package + (expand-file-name src arg)) + (setq status 1))) + ;; Specific file argument + (or (semantic-grammar-batch-build-one-package arg) + (setq status 1)))) + (kill-emacs status) + )) + + ;;;; + ;;;; Macros highlighting + ;;;; + + (defvar semantic--grammar-macros-regexp-1 nil) + (make-variable-buffer-local 'semantic--grammar-macros-regexp-1) + + (defun semantic--grammar-macros-regexp-1 () + "Return font-lock keyword regexp for pre-installed macro names." + (and semantic-grammar-macros + (not semantic--grammar-macros-regexp-1) + (condition-case nil + (setq semantic--grammar-macros-regexp-1 + (concat "(\\s-*" + (regexp-opt + (mapcar #'(lambda (e) (symbol-name (car e))) + semantic-grammar-macros) + t) + "\\>")) + (error nil))) + semantic--grammar-macros-regexp-1) + + (defconst semantic--grammar-macdecl-re + "\\<%use-macros\\>[ \t\r\n]+\\(\\sw\\|\\s_\\)+[ \t\r\n]+{" + "Regexp that matches a macro declaration statement.") + + (defvar semantic--grammar-macros-regexp-2 nil) + (make-variable-buffer-local 'semantic--grammar-macros-regexp-2) + + (defun semantic--grammar-clear-macros-regexp-2 (&rest ignore) + "Clear the cached regexp that match macros local in this grammar. + IGNORE arguments. + Added to `before-change-functions' hooks to be run before each text + change." + (setq semantic--grammar-macros-regexp-2 nil)) + + (defun semantic--grammar-macros-regexp-2 () + "Return the regexp that match macros local in this grammar." + (unless semantic--grammar-macros-regexp-2 + (let (macs) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward semantic--grammar-macdecl-re nil t) + (condition-case nil + (setq macs (nconc macs + (split-string + (buffer-substring-no-properties + (point) + (progn + (backward-char) + (forward-list 1) + (down-list -1) + (point)))))) + (error nil))) + (when macs + (setq semantic--grammar-macros-regexp-2 + (concat "(\\s-*" (regexp-opt macs t) "\\>")))))) + semantic--grammar-macros-regexp-2) + + (defun semantic--grammar-macros-matcher (end) + "Search for a grammar macro name to highlight. + END is the limit of the search." + (let ((regexp (semantic--grammar-macros-regexp-1))) + (or (and regexp (re-search-forward regexp end t)) + (and (setq regexp (semantic--grammar-macros-regexp-2)) + (re-search-forward regexp end t))))) + + ;;;; + ;;;; Define major mode + ;;;; + + (defvar semantic-grammar-syntax-table + (let ((table (make-syntax-table (standard-syntax-table)))) + (modify-syntax-entry ?\: "." table) ;; COLON + (modify-syntax-entry ?\> "." table) ;; GT + (modify-syntax-entry ?\< "." table) ;; LT + (modify-syntax-entry ?\| "." table) ;; OR + (modify-syntax-entry ?\; ". 12" table) ;; SEMI, Comment start ;; + (modify-syntax-entry ?\n ">" table) ;; Comment end + (modify-syntax-entry ?\" "\"" table) ;; String + (modify-syntax-entry ?\% "w" table) ;; Word + (modify-syntax-entry ?\- "_" table) ;; Symbol + (modify-syntax-entry ?\. "_" table) ;; Symbol + (modify-syntax-entry ?\\ "\\" table) ;; Quote + (modify-syntax-entry ?\` "'" table) ;; Prefix ` (backquote) + (modify-syntax-entry ?\' "'" table) ;; Prefix ' (quote) + (modify-syntax-entry ?\, "'" table) ;; Prefix , (comma) + (modify-syntax-entry ?\# "'" table) ;; Prefix # (sharp) + table) + "Syntax table used in a Semantic grammar buffers.") + + (defvar semantic-grammar-mode-hook nil + "Hook run when starting Semantic grammar mode.") + + (defvar semantic-grammar-mode-keywords-1 + `(("\\(\\<%%\\>\\|\\<%[{}]\\)" + 0 font-lock-reference-face) + ("\\(%\\)\\(\\(\\sw\\|\\s_\\)+\\)" + (1 font-lock-reference-face) + (2 font-lock-keyword-face)) + ("\\" + 0 (unless (semantic-grammar-in-lisp-p) 'bold)) + ("^\\(\\(\\sw\\|\\s_\\)+\\)[ \n\r\t]*:" + 1 font-lock-function-name-face) + (semantic--grammar-macros-matcher + 1 ,(if (boundp 'font-lock-builtin-face) + 'font-lock-builtin-face + 'font-lock-preprocessor-face)) + ("\\$\\(\\sw\\|\\s_\\)*" + 0 font-lock-variable-name-face) + ("<\\(\\(\\sw\\|\\s_\\)+\\)>" + 1 font-lock-type-face) + (,semantic-grammar-lex-c-char-re + 0 ,(if (boundp 'font-lock-constant-face) + 'font-lock-constant-face + 'font-lock-string-face) t) + ;; Must highlight :keyword here, because ':' is a punctuation in + ;; grammar mode! + ("[\r\n\t ]+:\\sw+\\>" + 0 font-lock-builtin-face) - ;; Append the Semantic keywords - ,@semantic-fw-font-lock-keywords ++ ;; ;; Append the Semantic keywords ++ ;; ,@semantic-fw-font-lock-keywords + ) + "Font Lock keywords used to highlight Semantic grammar buffers.") + + (defvar semantic-grammar-mode-keywords-2 + (append semantic-grammar-mode-keywords-1 + lisp-font-lock-keywords-1) + "Font Lock keywords used to highlight Semantic grammar buffers.") + + (defvar semantic-grammar-mode-keywords-3 + (append semantic-grammar-mode-keywords-1 + lisp-font-lock-keywords-2) + "Font Lock keywords used to highlight Semantic grammar buffers.") + + (defvar semantic-grammar-mode-keywords + semantic-grammar-mode-keywords-1 + "Font Lock keywords used to highlight Semantic grammar buffers.") + + (defvar semantic-grammar-map + (let ((km (make-sparse-keymap))) + + (define-key km "|" 'semantic-grammar-electric-punctuation) + (define-key km ";" 'semantic-grammar-electric-punctuation) + (define-key km "%" 'semantic-grammar-electric-punctuation) + (define-key km "(" 'semantic-grammar-electric-punctuation) + (define-key km ")" 'semantic-grammar-electric-punctuation) + (define-key km ":" 'semantic-grammar-electric-punctuation) + + (define-key km "\t" 'semantic-grammar-indent) + (define-key km "\M-\t" 'semantic-grammar-complete) + (define-key km "\C-c\C-c" 'semantic-grammar-create-package) + (define-key km "\C-cm" 'semantic-grammar-find-macro-expander) + (define-key km "\C-cik" 'semantic-grammar-insert-keyword) + ;; (define-key km "\C-cc" 'semantic-grammar-generate-and-load) + ;; (define-key km "\C-cr" 'semantic-grammar-generate-one-rule) + + km) + "Keymap used in `semantic-grammar-mode'.") + + (defvar semantic-grammar-menu + '("Grammar" + ["Indent Line" semantic-grammar-indent] + ["Complete Symbol" semantic-grammar-complete] + ["Find Macro" semantic-grammar-find-macro-expander] + "--" + ["Insert %keyword" semantic-grammar-insert-keyword] + "--" + ["Update Lisp Package" semantic-grammar-create-package] + ["Recreate Lisp Package" semantic-grammar-recreate-package] + ) + "Common semantic grammar menu.") + + (defun semantic-grammar-setup-menu-emacs (symbol mode-menu) + "Setup a GNU Emacs grammar menu in variable SYMBOL. + MODE-MENU is an optional specific menu whose items are appended to the + common grammar menu." + (let ((items (make-symbol "items"))) + `(unless (boundp ',symbol) + (easy-menu-define ,symbol (current-local-map) + "Grammar Menu" semantic-grammar-menu) + (let ((,items (cdr ,mode-menu))) + (when ,items + (easy-menu-add-item ,symbol nil "--") + (while ,items + (easy-menu-add-item ,symbol nil (car ,items)) + (setq ,items (cdr ,items)))))) + )) + + (defun semantic-grammar-setup-menu-xemacs (symbol mode-menu) + "Setup an XEmacs grammar menu in variable SYMBOL. + MODE-MENU is an optional specific menu whose items are appended to the + common grammar menu." + (let ((items (make-symbol "items")) + (path (make-symbol "path"))) + `(progn + (unless (boundp ',symbol) + (easy-menu-define ,symbol nil + "Grammar Menu" (copy-sequence semantic-grammar-menu))) + (easy-menu-add ,symbol) + (let ((,items (cdr ,mode-menu)) + (,path (list (car ,symbol)))) + (when ,items + (easy-menu-add-item nil ,path "--") + (while ,items + (easy-menu-add-item nil ,path (car ,items)) + (setq ,items (cdr ,items)))))) + )) + + (defmacro semantic-grammar-setup-menu (&optional mode-menu) + "Setup a mode local grammar menu. + MODE-MENU is an optional specific menu whose items are appended to the + common grammar menu." + (let ((menu (intern (format "%s-menu" major-mode)))) + (if (featurep 'xemacs) + (semantic-grammar-setup-menu-xemacs menu mode-menu) + (semantic-grammar-setup-menu-emacs menu mode-menu)))) + + (defsubst semantic-grammar-in-lisp-p () + "Return non-nil if point is in Lisp code." + (or (>= (point) (semantic-grammar-epilogue-start)) + (condition-case nil + (save-excursion + (up-list -1) + t) + (error nil)))) + + (defun semantic-grammar-edits-new-change-hook-fcn (overlay) + "Function set into `semantic-edits-new-change-hook'. + Argument OVERLAY is the overlay created to mark the change. + When OVERLAY marks a change in the scope of a nonterminal tag extend + the change bounds to encompass the whole nonterminal tag." + (let ((outer (car (semantic-find-tag-by-overlay-in-region + (semantic-edits-os overlay) + (semantic-edits-oe overlay))))) + (if (semantic-tag-of-class-p outer 'nonterminal) + (semantic-overlay-move overlay + (semantic-tag-start outer) + (semantic-tag-end outer))))) + + (defun semantic-grammar-mode () + "Initialize a buffer for editing Semantic grammars. + + \\{semantic-grammar-map}" + (interactive) + (kill-all-local-variables) + (setq major-mode 'semantic-grammar-mode + mode-name "Semantic Grammar Framework") + (set (make-local-variable 'parse-sexp-ignore-comments) t) + (set (make-local-variable 'comment-start) ";;") + ;; Look within the line for a ; following an even number of backslashes + ;; after either a non-backslash or the line beginning. + (set (make-local-variable 'comment-start-skip) + "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") + (set-syntax-table semantic-grammar-syntax-table) + (use-local-map semantic-grammar-map) + (set (make-local-variable 'indent-line-function) + 'semantic-grammar-indent) + (set (make-local-variable 'fill-paragraph-function) + 'lisp-fill-paragraph) + (set (make-local-variable 'font-lock-multiline) + 'undecided) + (set (make-local-variable 'font-lock-defaults) + '((semantic-grammar-mode-keywords + semantic-grammar-mode-keywords-1 + semantic-grammar-mode-keywords-2 + semantic-grammar-mode-keywords-3) + nil ;; perform string/comment fontification + nil ;; keywords are case sensitive. + ;; This puts _ & - as a word constituant, + ;; simplifying our keywords significantly + ((?_ . "w") (?- . "w")))) + ;; Setup Semantic to parse grammar + (semantic-grammar-wy--install-parser) + (setq semantic-lex-comment-regex ";;" + semantic-lex-analyzer 'semantic-grammar-lexer + semantic-type-relation-separator-character '(":") + semantic-symbol->name-assoc-list + '( + (code . "Setup Code") + (keyword . "Keyword") + (token . "Token") + (nonterminal . "Nonterminal") + (rule . "Rule") + )) + (set (make-local-variable 'semantic-format-face-alist) + '( + (code . default) + (keyword . font-lock-keyword-face) + (token . font-lock-type-face) + (nonterminal . font-lock-function-name-face) + (rule . default) + )) + (set (make-local-variable 'semantic-stickyfunc-sticky-classes) + '(nonterminal)) + ;; Before each change, clear the cached regexp used to highlight + ;; macros local in this grammar. + (semantic-make-local-hook 'before-change-functions) + (add-hook 'before-change-functions + 'semantic--grammar-clear-macros-regexp-2 nil t) + ;; Handle safe re-parse of grammar rules. + (semantic-make-local-hook 'semantic-edits-new-change-hooks) + (add-hook 'semantic-edits-new-change-hooks + 'semantic-grammar-edits-new-change-hook-fcn + nil t) + (semantic-run-mode-hooks 'semantic-grammar-mode-hook)) + + ;;;; + ;;;; Useful commands + ;;;; + + (defvar semantic-grammar-skip-quoted-syntax-table + (let ((st (copy-syntax-table semantic-grammar-syntax-table))) + (modify-syntax-entry ?\' "$" st) + st) + "Syntax table to skip a whole quoted expression in grammar code. + Consider quote as a \"paired delimiter\", so `forward-sexp' will skip + whole quoted expression.") + + (defsubst semantic-grammar-backward-item () + "Move point to beginning of the previous grammar item." + (forward-comment (- (point-max))) + (if (zerop (skip-syntax-backward ".")) + (if (eq (char-before) ?\') + (with-syntax-table + ;; Can't be Lisp code here! Temporarily consider quote + ;; as a "paired delimiter", so `forward-sexp' can skip + ;; the whole quoted expression. + semantic-grammar-skip-quoted-syntax-table + (forward-sexp -1)) + (forward-sexp -1)))) + + (defun semantic-grammar-anchored-indentation () + "Return indentation based on previous anchor character found." + (let (indent) + (save-excursion + (while (not indent) + (semantic-grammar-backward-item) + (cond + ((bobp) + (setq indent 0)) + ((looking-at ":\\(\\s-\\|$\\)") + (setq indent (current-column)) + (forward-char) + (skip-syntax-forward "-") + (if (eolp) (setq indent 2)) + ) + ((and (looking-at "[;%]") + (not (looking-at "\\<%prec\\>"))) + (setq indent 0) + )))) + indent)) + + (defun semantic-grammar-do-grammar-indent () + "Indent a line of grammar. + When called the point is not in Lisp code." + (let (indent n) + (save-excursion + (beginning-of-line) + (skip-syntax-forward "-") + (setq indent (current-column)) + (cond + ((or (bobp) + (looking-at "\\(\\w\\|\\s_\\)+\\s-*:") + (and (looking-at "%") + (not (looking-at "%prec\\>")))) + (setq n 0)) + ((looking-at ":") + (setq n 2)) + ((and (looking-at ";;") + (save-excursion (forward-comment (point-max)) + (looking-at ":"))) + (setq n 1)) + (t + (setq n (semantic-grammar-anchored-indentation)) + (unless (zerop n) + (cond + ((looking-at ";;") + (setq n (1- n))) + ((looking-at "[|;]") + ) + (t + (setq n (+ n 2))))))) + (when (/= n indent) + (beginning-of-line) + (delete-horizontal-space) + (indent-to n))))) + + (defvar semantic-grammar-brackets-as-parens-syntax-table + (let ((st (copy-syntax-table emacs-lisp-mode-syntax-table))) + (modify-syntax-entry ?\{ "(} " st) + (modify-syntax-entry ?\} "){ " st) + st) + "Syntax table that consider brackets as parenthesis. + So `lisp-indent-line' will work inside bracket blocks.") + + (defun semantic-grammar-do-lisp-indent () + "Maybe run the Emacs Lisp indenter on a line of code. + Return nil if not in a Lisp expression." + (condition-case nil + (save-excursion + (beginning-of-line) + (skip-chars-forward "\t ") + (let ((first (point))) + (or (>= first (semantic-grammar-epilogue-start)) + (up-list -1)) + (condition-case nil + (while t + (up-list -1)) + (error nil)) + (beginning-of-line) + (save-restriction + (narrow-to-region (point) first) + (goto-char (point-max)) + (with-syntax-table + ;; Temporarily consider brackets as parenthesis so + ;; `lisp-indent-line' can indent Lisp code inside + ;; brackets. + semantic-grammar-brackets-as-parens-syntax-table + (lisp-indent-line)))) + t) + (error nil))) + + (defun semantic-grammar-indent () + "Indent the current line. + Use the Lisp or grammar indenter depending on point location." + (interactive) + (let ((orig (point)) + first) + (or (semantic-grammar-do-lisp-indent) + (semantic-grammar-do-grammar-indent)) + (setq first (save-excursion + (beginning-of-line) + (skip-chars-forward "\t ") + (point))) + (if (or (< orig first) (/= orig (point))) + (goto-char first)))) + + (defun semantic-grammar-electric-punctuation () + "Insert and reindent for the symbol just typed in." + (interactive) + (self-insert-command 1) + (save-excursion + (semantic-grammar-indent))) + + (defun semantic-grammar-complete () + "Attempt to complete the symbol under point. + Completion is position sensitive. If the cursor is in a match section of + a rule, then nonterminals symbols are scanned. If the cursor is in a Lisp + expression then Lisp symbols are completed." + (interactive) + (if (semantic-grammar-in-lisp-p) + ;; We are in lisp code. Do lisp completion. + (lisp-complete-symbol) + ;; We are not in lisp code. Do rule completion. + (let* ((nonterms (semantic-find-tags-by-class 'nonterminal (current-buffer))) + (sym (car (semantic-ctxt-current-symbol))) + (ans (try-completion sym nonterms))) + (cond ((eq ans t) + ;; All done + (message "Symbols is already complete")) + ((and (stringp ans) (string= ans sym)) + ;; Max matchable. Show completions. + (with-output-to-temp-buffer "*Completions*" + (display-completion-list (all-completions sym nonterms))) + ) + ((stringp ans) + ;; Expand the completions + (forward-sexp -1) + (delete-region (point) (progn (forward-sexp 1) (point))) + (insert ans)) + (t (message "No Completions.")) + )) + )) + + (defun semantic-grammar-insert-keyword (name) + "Insert a new %keyword declaration with NAME. + Assumes it is typed in with the correct casing." + (interactive "sKeyword: ") + (if (not (bolp)) (insert "\n")) + (insert "%keyword " (upcase name) " \"" name "\" + %put " (upcase name) " summary + \"\"\n") + (forward-char -2)) + + ;;; Macro facilities + ;; + + (defsubst semantic--grammar-macro-function-tag (name) + "Search for a function tag for the grammar macro with name NAME. + Return the tag found or nil if not found." + (car (semantic-find-tags-by-class + 'function + (or (semantic-find-tags-by-name name (current-buffer)) + (and (featurep 'semanticdb) + semanticdb-current-database + (cdar (semanticdb-find-tags-by-name name nil t))))))) + + (defsubst semantic--grammar-macro-lib-part (def) + "Return the library part of the grammar macro defined by DEF." + (let ((suf (format "-%s\\'" (regexp-quote (symbol-name (car def))))) + (fun (symbol-name (cdr def)))) + (substring fun 0 (string-match suf fun)))) + + (defun semantic--grammar-macro-compl-elt (def &optional full) + "Return a completion entry for the grammar macro defined by DEF. + If optional argument FULL is non-nil qualify the macro name with the + library found in DEF." + (let ((mac (car def)) + (lib (semantic--grammar-macro-lib-part def))) + (cons (if full + (format "%s/%s" mac lib) + (symbol-name mac)) + (list mac lib)))) + + (defun semantic--grammar-macro-compl-dict () + "Return a completion dictionnary of macro definitions." + (let ((defs (semantic-grammar-macros)) + def dups dict) + (while defs + (setq def (car defs) + defs (cdr defs)) + (if (or (assoc (car def) defs) (assoc (car def) dups)) + (push def dups) + (push (semantic--grammar-macro-compl-elt def) dict))) + (while dups + (setq def (car dups) + dups (cdr dups)) + (push (semantic--grammar-macro-compl-elt def t) dict)) + dict)) + + (defun semantic-grammar-find-macro-expander (macro-name library) + "Visit the Emacs Lisp library where a grammar macro is implemented. + MACRO-NAME is a symbol that identifies a grammar macro. + LIBRARY is the name (sans extension) of the Emacs Lisp library where + to start searching the macro implementation. Lookup in included + libraries, if necessary. + Find a function tag (in current tags table) whose name contains MACRO-NAME. + Select the buffer containing the tag's definition, and move point there." + (interactive + (let* ((dic (semantic--grammar-macro-compl-dict)) + (def (assoc (completing-read "Macro: " dic nil 1) dic))) + (or (cdr def) '(nil nil)))) + (when (and macro-name library) + (let* ((lib (format "%s.el" library)) + (buf (find-file-noselect (or (locate-library lib t) lib))) + (tag (with-current-buffer buf + (semantic--grammar-macro-function-tag + (format "%s-%s" library macro-name))))) + (if tag + (progn + (require 'semantic/decorate) + (pop-to-buffer (semantic-tag-buffer tag)) + (goto-char (semantic-tag-start tag)) + (semantic-momentary-highlight-tag tag)) + (pop-to-buffer buf) + (message "No expander found in library %s for macro %s" + library macro-name))))) + + ;;; Additional help + ;; + + (defvar semantic-grammar-syntax-help + `( + ;; Lexical Symbols + ("symbol" . "Syntax: A symbol of alpha numeric and symbol characters") + ("number" . "Syntax: Numeric characters.") + ("punctuation" . "Syntax: Punctuation character.") + ("semantic-list" . "Syntax: A list delimited by any valid list characters") + ("open-paren" . "Syntax: Open Parenthesis character") + ("close-paren" . "Syntax: Close Parenthesis character") + ("string" . "Syntax: String character delimited text") + ("comment" . "Syntax: Comment character delimited text") + ;; Special Macros + ("EMPTY" . "Syntax: Match empty text") + ("ASSOC" . "Lambda Key: (ASSOC key1 value1 key2 value2 ...)") + ("EXPAND" . "Lambda Key: (EXPAND )") + ("EXPANDFULL" . "Lambda Key: (EXPANDFULL )") + ;; Tag Generator Macros + ("TAG" . "Generic Tag Generation: (TAG [ :key value ]*)") + ("VARIABLE-TAG" . "(VARIABLE-TAG [ :key value ]*)") + ("FUNCTION-TAG" . "(FUNCTION-TAG [ :key value ]*)") + ("TYPE-TAG" . "(TYPE-TAG [ :key value ]*)") + ("INCLUDE-TAG" . "(INCLUDE-TAG [ :key value ]*)") + ("PACKAGE-TAG" . "(PACKAGE-TAG [ :key value ]*)") + ("CODE-TAG" . "(CODE-TAG [ :key value ]*)") + ("ALIAS-TAG" . "(ALIAS-TAG [:key value]*)") + ;; Special value macros + ("$1" . "Match Value: Value from match list in slot 1") + ("$2" . "Match Value: Value from match list in slot 2") + ("$3" . "Match Value: Value from match list in slot 3") + ("$4" . "Match Value: Value from match list in slot 4") + ("$5" . "Match Value: Value from match list in slot 5") + ("$6" . "Match Value: Value from match list in slot 6") + ("$7" . "Match Value: Value from match list in slot 7") + ("$8" . "Match Value: Value from match list in slot 8") + ("$9" . "Match Value: Value from match list in slot 9") + ;; Same, but with annoying , in front. + (",$1" . "Match Value: Value from match list in slot 1") + (",$2" . "Match Value: Value from match list in slot 2") + (",$3" . "Match Value: Value from match list in slot 3") + (",$4" . "Match Value: Value from match list in slot 4") + (",$5" . "Match Value: Value from match list in slot 5") + (",$6" . "Match Value: Value from match list in slot 6") + (",$7" . "Match Value: Value from match list in slot 7") + (",$8" . "Match Value: Value from match list in slot 8") + (",$9" . "Match Value: Value from match list in slot 9") + ) + "Association of syntax elements, and the corresponding help.") + + (defun semantic-grammar-eldoc-get-macro-docstring (macro expander) + "Return a one-line docstring for the given grammar MACRO. + EXPANDER is the name of the function that expands MACRO." + (require 'eldoc) + (if (and (eq expander (aref eldoc-last-data 0)) + (eq 'function (aref eldoc-last-data 2))) + (aref eldoc-last-data 1) + (let ((doc (help-split-fundoc (documentation expander t) expander))) + (cond + (doc + (setq doc (car doc)) + (string-match "\\`[^ )]* ?" doc) + (setq doc (concat "(" (substring doc (match-end 0))))) + (t + (setq doc (eldoc-function-argstring expander)))) + (when doc + (setq doc + (eldoc-docstring-format-sym-doc + macro (format "==> %s %s" expander doc) 'default)) + (eldoc-last-data-store expander doc 'function)) + doc))) + + (define-mode-local-override semantic-idle-summary-current-symbol-info + semantic-grammar-mode () + "Display additional eldoc information about grammar syntax elements. + Syntax element is the current symbol at point. + If it is associated a help string in `semantic-grammar-syntax-help', + return that string. + If it is a macro name, return a description of the associated expander + function parameter list. + If it is a function name, return a description of this function + parameter list. + It it is a variable name, return a brief (one-line) documentation + string for the variable. + If a default description of the current context can be obtained, + return it. + Otherwise return nil." + (require 'eldoc) + (let* ((elt (car (semantic-ctxt-current-symbol))) + (val (and elt (cdr (assoc elt semantic-grammar-syntax-help))))) + (when (and (not val) elt (semantic-grammar-in-lisp-p)) + ;; Ensure to load macro definitions before doing `intern-soft'. + (setq val (semantic-grammar-macros) + elt (intern-soft elt) + val (and elt (cdr (assq elt val)))) + (cond + ;; Grammar macro + ((and val (fboundp val)) + (setq val (semantic-grammar-eldoc-get-macro-docstring elt val))) + ;; Function + ((and elt (fboundp elt)) + (setq val (eldoc-get-fnsym-args-string elt))) + ;; Variable + ((and elt (boundp elt)) + (setq val (eldoc-get-var-docstring elt))) + (t nil))) + (or val (semantic-idle-summary-current-symbol-info-default)))) + + (define-mode-local-override semantic-tag-boundary-p + semantic-grammar-mode (tag) + "Return non-nil for tags that should have a boundary drawn. + Only tags of type 'nonterminal will be so marked." + (let ((c (semantic-tag-class tag))) + (eq c 'nonterminal))) + + (define-mode-local-override semantic-ctxt-current-function + semantic-grammar-mode (&optional point) + "Determine the name of the current function at POINT." + (save-excursion + (and point (goto-char point)) + (when (semantic-grammar-in-lisp-p) + (with-mode-local emacs-lisp-mode + (semantic-ctxt-current-function))))) + + (define-mode-local-override semantic-ctxt-current-argument + semantic-grammar-mode (&optional point) + "Determine the argument index of the called function at POINT." + (save-excursion + (and point (goto-char point)) + (when (semantic-grammar-in-lisp-p) + (with-mode-local emacs-lisp-mode + (semantic-ctxt-current-argument))))) + + (define-mode-local-override semantic-ctxt-current-assignment + semantic-grammar-mode (&optional point) + "Determine the tag being assigned into at POINT." + (save-excursion + (and point (goto-char point)) + (when (semantic-grammar-in-lisp-p) + (with-mode-local emacs-lisp-mode + (semantic-ctxt-current-assignment))))) + + (define-mode-local-override semantic-ctxt-current-class-list + semantic-grammar-mode (&optional point) + "Determine the class of tags that can be used at POINT." + (save-excursion + (and point (goto-char point)) + (if (semantic-grammar-in-lisp-p) + (with-mode-local emacs-lisp-mode + (semantic-ctxt-current-class-list)) + '(nonterminal keyword)))) + + (define-mode-local-override semantic-ctxt-current-mode + semantic-grammar-mode (&optional point) + "Return the major mode active at POINT. + POINT defaults to the value of point in current buffer. + Return `emacs-lisp-mode' is POINT is within Lisp code, otherwise + return the current major mode." + (save-excursion + (and point (goto-char point)) + (if (semantic-grammar-in-lisp-p) + 'emacs-lisp-mode + (semantic-ctxt-current-mode-default)))) + + (define-mode-local-override semantic-format-tag-abbreviate + semantic-grammar-mode (tag &optional parent color) + "Return a string abbreviation of TAG. + Optional PARENT is not used. + Optional COLOR is used to flag if color is added to the text." + (let ((class (semantic-tag-class tag)) + (name (semantic-format-tag-name tag parent color))) + (cond + ((eq class 'nonterminal) + (concat name ":")) + ((eq class 'setting) + "%settings%") + ((memq class '(rule keyword)) + name) + (t + (concat "%" (symbol-name class) " " name))))) + + (define-mode-local-override semantic-format-tag-summarize + semantic-grammar-mode (tag &optional parent color) + "Return a string summarizing TAG. + Optional PARENT is not used. + Optional argument COLOR determines if color is added to the text." + (let ((class (semantic-tag-class tag)) + (name (semantic-format-tag-name tag parent color)) + (label nil) + (desc nil)) + (cond + ((eq class 'nonterminal) + (setq label "Nonterminal: " + desc (format + " with %d match lists." + (length (semantic-tag-components tag))))) + ((eq class 'keyword) + (setq label "Keyword: ") + (let (summary) + (semantic--find-tags-by-function + #'(lambda (put) + (unless summary + (setq summary (cdr (assoc "summary" + (semantic-tag-get-attribute + put :value)))))) + ;; Get `put' tag with TAG name. + (semantic-find-tags-by-name-regexp + (regexp-quote (semantic-tag-name tag)) + (semantic-find-tags-by-class 'put (current-buffer)))) + (setq desc (concat " = " + (semantic-tag-get-attribute tag :value) + (if summary + (concat " - " (read summary)) + ""))))) + ((eq class 'token) + (setq label "Token: ") + (let ((val (semantic-tag-get-attribute tag :value)) + (names (semantic-tag-get-attribute tag :rest)) + (type (semantic-tag-type tag))) + (if names + (setq name (mapconcat 'identity (cons name names) " "))) + (setq desc (concat + (if type + (format " <%s>" type) + "") + (if val + (format "%s%S" val (if type " " "")) + ""))))) + ((eq class 'assoc) + (setq label "Assoc: ") + (let ((val (semantic-tag-get-attribute tag :value)) + (type (semantic-tag-type tag))) + (setq desc (concat + (if type + (format " <%s>" type) + "") + (if val + (concat " " (mapconcat 'identity val " ")) + ""))))) + (t + (setq desc (semantic-format-tag-abbreviate tag parent color)))) + (if (and color label) + (setq label (semantic--format-colorize-text label 'label))) + (if (and color label desc) + (setq desc (semantic--format-colorize-text desc 'comment))) + (if label + (concat label name desc) + ;; Just a description is the abbreviated version + desc))) + + ;;; Semantic Analysis + + (define-mode-local-override semantic-analyze-current-context + semantic-grammar-mode (point) + "Provide a semantic analysis object describing a context in a grammar." + (require 'semantic/analyze) + (if (semantic-grammar-in-lisp-p) + (with-mode-local emacs-lisp-mode + (semantic-analyze-current-context point)) + + (let* ((context-return nil) + (prefixandbounds (semantic-ctxt-current-symbol-and-bounds)) + (prefix (car prefixandbounds)) + (bounds (nth 2 prefixandbounds)) + (prefixsym nil) + (prefixclass (semantic-ctxt-current-class-list)) + ) + + ;; Do context for rules when in a match list. + (setq prefixsym + (semantic-find-first-tag-by-name + (car prefix) + (current-buffer))) + + (setq context-return + (semantic-analyze-context + "context-for-semantic-grammar" + :buffer (current-buffer) + :scope nil + :bounds bounds + :prefix (if prefixsym + (list prefixsym) + prefix) + :prefixtypes nil + :prefixclass prefixclass + )) + + context-return))) + + (define-mode-local-override semantic-analyze-possible-completions + semantic-grammar-mode (context) + "Return a list of possible completions based on CONTEXT." + (require 'semantic/analyze/complete) + (if (semantic-grammar-in-lisp-p) + (with-mode-local emacs-lisp-mode + (semantic-analyze-possible-completions context)) + (save-excursion + (set-buffer (oref context buffer)) + (let* ((prefix (car (oref context :prefix))) + (completetext (cond ((semantic-tag-p prefix) + (semantic-tag-name prefix)) + ((stringp prefix) + prefix) + ((stringp (car prefix)) + (car prefix)))) + (tags (semantic-find-tags-for-completion completetext + (current-buffer)))) + (semantic-analyze-tags-of-class-list + tags (oref context prefixclass))) + ))) + + (provide 'semantic/grammar) + + ;;; semantic/grammar.el ends here diff --cc lisp/cedet/semantic/html.el index 00000000000,263541b8af9..c1d9276ff1e mode 000000,100644..100644 --- a/lisp/cedet/semantic/html.el +++ b/lisp/cedet/semantic/html.el @@@ -1,0 -1,265 +1,260 @@@ + ;;; semantic/html.el --- Semantic details for html files + + ;;; Copyright (C) 2004, 2005, 2007, 2008 Free Software Foundation, Inc. + + ;; Author: Eric M. Ludlam + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + ;; + ;; Parse HTML files and organize them in a nice way. + ;; Pay attention to anchors, including them in the tag list. + ;; + ;; Copied from the original semantic-texi.el. + ;; + ;; ToDo: Find