[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] emacs/lisp ChangeLog cedet/cedet.el cedet/ede.e...
|
From: |
Chong Yidong |
|
Subject: |
[Emacs-diffs] emacs/lisp ChangeLog cedet/cedet.el cedet/ede.e... |
|
Date: |
Mon, 28 Sep 2009 15:15:14 +0000 |
CVSROOT: /sources/emacs
Module name: emacs
Changes by: Chong Yidong <cyd> 09/09/28 15:15:12
Modified files:
lisp : ChangeLog
Added files:
lisp/cedet : cedet.el ede.el semantic.el srecode.el
lisp/cedet/ede : .cvsignore autoconf-edit.el cpp-root.el
dired.el emacs.el files.el linux.el locate.el
make.el makefile-edit.el pconf.el pmake.el
proj-archive.el proj-aux.el proj-comp.el
proj-elisp.el proj-info.el proj-misc.el
proj-obj.el proj-prog.el proj-scheme.el
proj-shared.el proj.el project-am.el simple.el
source.el speedbar.el srecode.el system.el
util.el
lisp/cedet/semantic: .cvsignore analyze.el bovine.el chart.el
complete.el ctxt.el db-debug.el
db-ebrowse.el db-el.el db-file.el
db-find.el db-global.el db-javascript.el
db-mode.el db-ref.el db-typecache.el db.el
debug.el decorate.el dep.el doc.el
ede-grammar.el edit.el find.el format.el
fw.el grammar-wy.el grammar.el html.el
ia-sb.el ia.el idle.el java.el lex-spp.el
lex.el mru-bookmark.el sb.el scope.el
senator.el sort.el symref.el tag-file.el
tag-ls.el tag-write.el tag.el texi.el
util-modes.el util.el wisent.el
lisp/cedet/semantic/analyze: complete.el debug.el fcn.el refs.el
lisp/cedet/semantic/bovine: c-by.el c.el debug.el el.el gcc.el
make-by.el make.el scm-by.el scm.el
lisp/cedet/semantic/decorate: include.el mode.el
lisp/cedet/semantic/symref: cscope.el filter.el global.el
grep.el idutils.el list.el
lisp/cedet/semantic/wisent: comp.el java-tags.el javascript.el
javat-wy.el js-wy.el wisent.el
lisp/cedet/srecode: .cvsignore args.el compile.el cpp.el ctxt.el
dictionary.el document.el el.el
expandproto.el extract.el fields.el
filters.el find.el getset.el insert.el
java.el map.el mode.el semantic.el
srt-mode.el srt-wy.el srt.el table.el
template.el texi.el
Log message:
CEDET (development tools) package merged.
* cedet/*.el:
* cedet/ede/*.el:
* cedet/semantic/*.el:
* cedet/srecode/*.el: New files.
CVSWeb URLs:
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/ChangeLog?cvsroot=emacs&r1=1.16281&r2=1.16282
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/cedet.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/srecode.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/.cvsignore?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/autoconf-edit.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/cpp-root.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/dired.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/emacs.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/files.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/linux.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/locate.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/make.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/makefile-edit.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/pconf.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/pmake.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/proj-archive.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/proj-aux.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/proj-comp.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/proj-elisp.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/proj-info.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/proj-misc.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/proj-obj.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/proj-prog.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/proj-scheme.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/proj-shared.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/proj.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/project-am.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/simple.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/source.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/speedbar.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/srecode.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/system.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/ede/util.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/.cvsignore?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/analyze.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/bovine.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/chart.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/complete.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/ctxt.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/db-debug.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/db-ebrowse.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/db-el.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/db-file.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/db-find.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/db-global.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/db-javascript.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/db-mode.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/db-ref.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/db-typecache.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/db.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/debug.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/decorate.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/dep.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/doc.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/ede-grammar.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/edit.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/find.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/format.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/fw.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/grammar-wy.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/grammar.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/html.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/ia-sb.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/ia.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/idle.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/java.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/lex-spp.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/lex.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/mru-bookmark.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/sb.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/scope.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/senator.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/sort.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/symref.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/tag-file.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/tag-ls.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/tag-write.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/tag.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/texi.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/util-modes.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/util.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/wisent.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/analyze/complete.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/analyze/debug.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/analyze/fcn.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/analyze/refs.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/bovine/c-by.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/bovine/c.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/bovine/debug.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/bovine/el.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/bovine/gcc.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/bovine/make-by.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/bovine/make.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/bovine/scm-by.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/bovine/scm.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/decorate/include.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/decorate/mode.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/symref/cscope.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/symref/filter.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/symref/global.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/symref/grep.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/symref/idutils.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/symref/list.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/wisent/comp.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/wisent/java-tags.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/wisent/javascript.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/wisent/javat-wy.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/wisent/js-wy.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/semantic/wisent/wisent.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/srecode/.cvsignore?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/srecode/args.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/srecode/compile.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/srecode/cpp.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/srecode/ctxt.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/srecode/dictionary.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/srecode/document.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/srecode/el.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/srecode/expandproto.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/srecode/extract.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/srecode/fields.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/srecode/filters.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/srecode/find.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/srecode/getset.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/srecode/insert.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/srecode/java.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/srecode/map.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/srecode/mode.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/srecode/semantic.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/srecode/srt-mode.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/srecode/srt-wy.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/srecode/srt.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/srecode/table.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/srecode/template.el?cvsroot=emacs&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/cedet/srecode/texi.el?cvsroot=emacs&rev=1.2
Patches:
Index: ChangeLog
===================================================================
RCS file: /sources/emacs/emacs/lisp/ChangeLog,v
retrieving revision 1.16281
retrieving revision 1.16282
diff -u -b -r1.16281 -r1.16282
--- ChangeLog 28 Sep 2009 12:09:13 -0000 1.16281
+++ ChangeLog 28 Sep 2009 15:15:00 -0000 1.16282
@@ -1,3 +1,12 @@
+2009-09-28 Eric Ludlam <address@hidden>
+
+ CEDET (development tools) package merged.
+
+ * cedet/*.el:
+ * cedet/ede/*.el:
+ * cedet/semantic/*.el:
+ * cedet/srecode/*.el: New files.
+
2009-09-28 Michael Albinus <address@hidden>
* Makefile.in (ELCFILES): Add net/tramp-imap.elc.
Index: cedet/cedet.el
===================================================================
RCS file: cedet/cedet.el
diff -N cedet/cedet.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/cedet.el 28 Sep 2009 15:15:05 -0000 1.2
@@ -0,0 +1,145 @@
+;;; cedet.el --- Setup CEDET environment
+
+;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: David Ponce <address@hidden>
+;; Maintainer: Eric M. Ludlam <address@hidden>
+;; Version: 0.2
+;; Keywords: OO, lisp
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+;;
+;; This file depends on the major components of CEDET, so that you can
+;; load them all by doing (require 'cedet). This is mostly for
+;; compatibility with the upstream, stand-alone CEDET distribution.
+
+(eval-when-compile
+ (require 'cl))
+
+(declare-function inversion-find-version "inversion")
+
+(defconst cedet-version "1.0pre7"
+ "Current version of CEDET.")
+
+(defconst cedet-packages
+ `(
+ ;;PACKAGE MIN-VERSION
+ (cedet ,cedet-version)
+ (eieio "1.2")
+ (semantic "2.0pre7")
+ (srecode "1.0pre7")
+ (ede "1.0pre7")
+ (speedbar "1.0.3"))
+ "Table of CEDET packages to install.")
+
+(defvar cedet-menu-map ;(make-sparse-keymap "CEDET menu")
+ (let ((map (make-sparse-keymap "CEDET menu")))
+ (define-key map [semantic-force-refresh] 'undefined)
+ (define-key map [semantic-edit-menu] 'undefined)
+ (define-key map [navigate-menu] 'undefined)
+ (define-key map [semantic-options-separator] 'undefined)
+ (define-key map [global-semantic-highlight-func-mode] 'undefined)
+ (define-key map [global-semantic-highlight-func-mode] 'undefined)
+ (define-key map [global-semantic-decoration-mode] 'undefined)
+ (define-key map [global-semantic-idle-completions-mode] 'undefined)
+ (define-key map [global-semantic-idle-summary-mode] 'undefined)
+ (define-key map [global-semanticdb-minor-mode] 'undefined)
+ (define-key map [global-semantic-idle-scheduler-mode] 'undefined)
+ (define-key map [semantic-menu-separator] '("--"))
+ (define-key map [semantic-mode]
+ '(menu-item "Enable Parsers (Semantic)" semantic-mode
+ :help "Enable language parsers (Semantic)"
+ :visible (not (bound-and-true-p semantic-mode))))
+ (define-key map [cedet-menu-separator] 'undefined)
+ (define-key map [ede-mode]
+ '(menu-item "Enable Project Support (EDE)" global-ede-mode
+ :help "Enable the Emacs Development Environment (EDE)"
+ :visible (not (bound-and-true-p global-ede-mode))))
+ (define-key map [ede-menu-separator] '("--"))
+ (define-key map [ede-find-file] 'undefined)
+ (define-key map [ede-speedbar] 'undefined)
+ (define-key map [ede] 'undefined)
+ (define-key map [ede-new] 'undefined)
+ (define-key map [ede-target-options] 'undefined)
+ (define-key map [ede-project-options] 'undefined)
+ (define-key map [ede-build-forms-menu] 'undefined)
+ map)
+ "Menu keymap for the CEDET package.
+This is used by `semantic-mode' and `global-ede-mode'.")
+
+(defun cedet-version ()
+ "Display all active versions of CEDET and Dependant packages.
+
+The PACKAGE column is the name of a given package from CEDET.
+
+REQUESTED VERSION is the version requested by the CEDET load script.
+See `cedet-packages' for details.
+
+FILE VERSION is the version number found in the source file
+for the specificed PACKAGE.
+
+LOADED VERSION is the version of PACKAGE current loaded in Emacs
+memory and (presumably) running in this Emacs instance. Value is X
+if the package has not been loaded."
+ (interactive)
+ (require 'inversion)
+ (with-output-to-temp-buffer "*CEDET*"
+ (princ "CEDET Version:\t") (princ cedet-version)
+ (princ "\n \t\t\tRequested\tFile\t\tLoaded")
+ (princ "\n Package\t\tVersion\t\tVersion\t\tVersion")
+ (princ "\n ----------------------------------------------------------")
+ (let ((p cedet-packages))
+ (while p
+ (let ((sym (symbol-name (car (car p)))))
+ (princ "\n ")
+ (princ sym)
+ (princ ":\t")
+ (if (< (length sym) 5)
+ (princ "\t"))
+ (if (< (length sym) 13)
+ (princ "\t"))
+ (let ((reqver (nth 1 (car p)))
+ (filever (car (inversion-find-version sym)))
+ (loadver (when (featurep (car (car p)))
+ (symbol-value (intern-soft (concat sym
"-version"))))))
+ (princ reqver)
+ (if (< (length reqver) 8) (princ "\t"))
+ (princ "\t")
+ (if (string= filever reqver)
+ ;; I tried the words "check" and "match", but that
+ ;; just looked lame.
+ (princ "ok\t")
+ (princ filever)
+ (if (< (length filever) 8) (princ "\t")))
+ (princ "\t")
+ (if loadver
+ (if (string= loadver reqver)
+ (princ "ok")
+ (princ loadver))
+ (princ "Not Loaded"))
+ ))
+ (setq p (cdr p))))
+ (princ "\n\n\nC-h f cedet-version RET\n for details on output format.")
+ ))
+
+(provide 'cedet)
+
+;;; cedet.el ends here
Index: cedet/ede.el
===================================================================
RCS file: cedet/ede.el
diff -N cedet/ede.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede.el 28 Sep 2009 15:15:05 -0000 1.2
@@ -0,0 +1,1986 @@
+;;; ede.el --- Emacs Development Environment gloss
+
+;;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+;;; 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: project, make
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; EDE is the top level Lisp interface to a project management scheme
+;; for Emacs. Emacs does many things well, including editing,
+;; building, and debugging. Folks migrating from other IDEs don't
+;; seem to think this qualifies, however, because they still have to
+;; write the makefiles, and specify parameters to programs.
+;;
+;; This EDE mode will attempt to link these diverse programs together
+;; into a comprehensive single interface, instead of a bunch of
+;; different ones.
+
+;;; Install
+;;
+;; This command enables project mode on all files.
+;;
+;; (global-ede-mode t)
+
+(require 'cedet)
+(require 'eieio)
+(require 'eieio-speedbar)
+(require 'ede/source)
+(require 'ede/loaddefs)
+
+(declare-function ede-convert-path "ede/files")
+(declare-function ede-directory-get-open-project "ede/files")
+(declare-function ede-directory-get-toplevel-open-project "ede/files")
+(declare-function ede-directory-project-p "ede/files")
+(declare-function ede-find-subproject-for-directory "ede/files")
+(declare-function ede-project-directory-remove-hash "ede/files")
+(declare-function ede-project-root "ede/files")
+(declare-function ede-project-root-directory "ede/files")
+(declare-function ede-toplevel "ede/files")
+(declare-function ede-toplevel-project "ede/files")
+(declare-function ede-up-directory "ede/files")
+(declare-function data-debug-new-buffer "data-debug")
+(declare-function data-debug-insert-object-slots "eieio-datadebug")
+(declare-function semantic-lex-make-spp-table "semantic/lex-spp")
+
+(defconst ede-version "1.0pre7"
+ "Current version of the Emacs EDE.")
+
+;;; Code:
+(defun ede-version ()
+ "Display the current running version of EDE."
+ (interactive) (message "EDE %s" ede-version))
+
+(defgroup ede nil
+ "Emacs Development Environment gloss."
+ :group 'tools
+ :group 'convenience
+ )
+
+(defcustom ede-auto-add-method 'ask
+ "Whether a new source file shoud be automatically added to a target.
+Whenever a new file is encountered in a directory controlled by a
+project file, all targets are queried to see if it should be added.
+If the value is 'always, then the new file is added to the first
+target encountered. If the value is 'multi-ask, then if more than one
+target wants the file, the user is asked. If only one target wants
+the file, then then it is automatically added to that target. If the
+value is 'ask, then the user is always asked, unless there is no
+target willing to take the file. 'never means never perform the check."
+ :group 'ede
+ :type '(choice (const always)
+ (const multi-ask)
+ (const ask)
+ (const never)))
+
+(defcustom ede-debug-program-function 'gdb
+ "Default Emacs command used to debug a target."
+ :group 'ede
+ :type 'sexp) ; make this be a list of options some day
+
+
+;;; Top level classes for projects and targets
+
+(defclass ede-project-autoload ()
+ ((name :initarg :name
+ :documentation "Name of this project type")
+ (file :initarg :file
+ :documentation "The lisp file belonging to this class.")
+ (proj-file :initarg :proj-file
+ :documentation "Name of a project file of this type.")
+ (proj-root :initarg :proj-root
+ :type function
+ :documentation "A function symbol to call for the project root.
+This function takes no arguments, and returns the current directories
+root, if available. Leave blank to use the EDE directory walking
+routine instead.")
+ (initializers :initarg :initializers
+ :initform nil
+ :documentation
+ "Initializers passed to the project object.
+These are used so there can be multiple types of projects
+associated with a single object class, based on the initilizeres used.")
+ (load-type :initarg :load-type
+ :documentation "Fn symbol used to load this project file.")
+ (class-sym :initarg :class-sym
+ :documentation "Symbol representing the project class to use.")
+ (new-p :initarg :new-p
+ :initform t
+ :documentation
+ "Non-nil if this is an option when a user creates a project.")
+ )
+ "Class representing minimal knowledge set to run preliminary EDE functions.
+When more advanced functionality is needed from a project type, that projects
+type is required and the load function used.")
+
+(defvar ede-project-class-files
+ (list
+ (ede-project-autoload "edeproject-makefile"
+ :name "Make" :file 'ede/proj
+ :proj-file "Project.ede"
+ :load-type 'ede-proj-load
+ :class-sym 'ede-proj-project)
+ (ede-project-autoload "edeproject-automake"
+ :name "Automake" :file 'ede/proj
+ :proj-file "Project.ede"
+ :initializers '(:makefile-type Makefile.am)
+ :load-type 'ede-proj-load
+ :class-sym 'ede-proj-project)
+ (ede-project-autoload "automake"
+ :name "automake" :file 'ede/project-am
+ :proj-file "Makefile.am"
+ :load-type 'project-am-load
+ :class-sym 'project-am-makefile
+ :new-p nil)
+ (ede-project-autoload "cpp-root"
+ :name "CPP ROOT" :file 'ede/cpp-root
+ :proj-file 'ede-cpp-root-project-file-for-dir
+ :proj-root 'ede-cpp-root-project-root
+ :load-type 'ede-cpp-root-load
+ :class-sym 'ede-cpp-root
+ :new-p nil)
+ (ede-project-autoload "emacs"
+ :name "EMACS ROOT" :file 'ede/emacs
+ :proj-file "src/emacs.c"
+ :proj-root 'ede-emacs-project-root
+ :load-type 'ede-emacs-load
+ :class-sym 'ede-emacs-project
+ :new-p nil)
+ (ede-project-autoload "linux"
+ :name "LINUX ROOT" :file 'ede/linux
+ :proj-file "scripts/ver_linux"
+ :proj-root 'ede-linux-project-root
+ :load-type 'ede-linux-load
+ :class-sym 'ede-linux-project
+ :new-p nil)
+ (ede-project-autoload "simple-overlay"
+ :name "Simple" :file 'ede/simple
+ :proj-file 'ede-simple-projectfile-for-dir
+ :load-type 'ede-simple-load
+ :class-sym 'ede-simple-project))
+ "List of vectos defining how to determine what type of projects exist.")
+
+;;; Generic project information manager objects
+
+(defclass ede-target (eieio-speedbar-directory-button)
+ ((buttonface :initform speedbar-file-face) ;override for superclass
+ (name :initarg :name
+ :type string
+ :custom string
+ :label "Name"
+ :group (default name)
+ :documentation "Name of this target.")
+ ;; @todo - I think this should be "dir", and not "path".
+ (path :initarg :path
+ :type string
+ ;:custom string
+ ;:label "Path to target"
+ ;:group (default name)
+ :documentation "The path to the sources of this target.
+Relative to the path of the project it belongs to.")
+ (source :initarg :source
+ :initform nil
+ ;; I'd prefer a list of strings.
+ :type list
+ :custom (repeat (string :tag "File"))
+ :label "Source Files"
+ :group (default source)
+ :documentation "Source files in this target.")
+ (versionsource :initarg :versionsource
+ :initform nil
+ :type list
+ :custom (repeat (string :tag "File"))
+ :label "Source Files with Version String"
+ :group (source)
+ :documentation
+ "Source files with a version string in them.
+These files are checked for a version string whenever the EDE version
+of the master project is changed. When strings are found, the version
+previously there is updated.")
+ ;; Class level slots
+ ;;
+; (takes-compile-command :allocation :class
+; :initarg :takes-compile-command
+; :type boolean
+; :initform nil
+; :documentation
+; "Non-nil if this target requires a user approved command.")
+ (sourcetype :allocation :class
+ :type list ;; list of symbols
+ :documentation
+ "A list of `ede-sourcecode' objects this class will handle.
+This is used to match target objects with the compilers they can use, and
+which files this object is interested in."
+ :accessor ede-object-sourcecode)
+ (keybindings :allocation :class
+ :initform (("D" . ede-debug-target))
+ :documentation
+"Keybindings specialized to this type of target."
+ :accessor ede-object-keybindings)
+ (menu :allocation :class
+ :initform ( [ "Debug target" ede-debug-target
+ (and ede-object
+ (obj-of-class-p ede-object ede-target)) ]
+ )
+ :documentation "Menu specialized to this type of target."
+ :accessor ede-object-menu)
+ )
+ "A top level target to build.")
+
+(defclass ede-project-placeholder (eieio-speedbar-directory-button)
+ ((name :initarg :name
+ :initform "Untitled"
+ :type string
+ :custom string
+ :label "Name"
+ :group (default name)
+ :documentation "The name used when generating distribution files.")
+ (version :initarg :version
+ :initform "1.0"
+ :type string
+ :custom string
+ :label "Version"
+ :group (default name)
+ :documentation "The version number used when distributing files.")
+ (directory :type string
+ :initarg :directory
+ :documentation "Directory this project is associated with.")
+ (dirinode :documentation "The inode id for :directory.")
+ (file :type string
+ :initarg :file
+ :documentation "File name where this project is stored.")
+ (rootproject ; :initarg - no initarg, don't save this slot!
+ :initform nil
+ :type (or null ede-project-placeholder-child)
+ :documentation "Pointer to our root project.")
+ )
+ "Placeholder object for projects not loaded into memory.
+Projects placeholders will be stored in a user specific location
+and querying them will cause the actual project to get loaded.")
+
+(defclass ede-project (ede-project-placeholder)
+ ((subproj :initform nil
+ :type list
+ :documentation "Sub projects controlled by this project.
+For Automake based projects, each directory is treated as a project.")
+ (targets :initarg :targets
+ :type list
+ :custom (repeat (object :objectcreatefcn ede-new-target-custom))
+ :label "Local Targets"
+ :group (targets)
+ :documentation "List of top level targets in this project.")
+ (locate-obj :type (or null ede-locate-base-child)
+ :documentation
+ "A locate object to use as a backup to `ede-expand-filename'.")
+ (tool-cache :initarg :tool-cache
+ :type list
+ :custom (repeat object)
+ :label "Tool: "
+ :group tools
+ :documentation "List of tool cache configurations in this
project.
+This allows any tool to create, manage, and persist project-specific
settings.")
+ (mailinglist :initarg :mailinglist
+ :initform ""
+ :type string
+ :custom string
+ :label "Mailing List Address"
+ :group name
+ :documentation
+ "An email address where users might send email for help.")
+ (web-site-url :initarg :web-site-url
+ :initform ""
+ :type string
+ :custom string
+ :label "Web Site URL"
+ :group name
+ :documentation "URL to this projects web site.
+This is a URL to be sent to a web site for documentation.")
+ (web-site-directory :initarg :web-site-directory
+ :initform ""
+ :custom string
+ :label "Web Page Directory"
+ :group name
+ :documentation
+ "A directory where web pages can be found by Emacs.
+For remote locations use a path compatible with ange-ftp or EFS.
+You can also use TRAMP for use with rcp & scp.")
+ (web-site-file :initarg :web-site-file
+ :initform ""
+ :custom string
+ :label "Web Page File"
+ :group name
+ :documentation
+ "A file which contains the home page for this project.
+This file can be relative to slot `web-site-directory'.
+This can be a local file, use ange-ftp, EFS, or TRAMP.")
+ (ftp-site :initarg :ftp-site
+ :initform ""
+ :type string
+ :custom string
+ :label "FTP site"
+ :group name
+ :documentation
+ "FTP site where this project's distribution can be found.
+This FTP site should be in Emacs form, as needed by `ange-ftp', but can
+also be of a form used by TRAMP for use with scp, or rcp.")
+ (ftp-upload-site :initarg :ftp-upload-site
+ :initform ""
+ :type string
+ :custom string
+ :label "FTP Upload site"
+ :group name
+ :documentation
+ "FTP Site to upload new distributions to.
+This FTP site should be in Emacs form as needed by `ange-ftp'.
+If this slot is nil, then use `ftp-site' instead.")
+ (configurations :initarg :configurations
+ :initform ("debug" "release")
+ :type list
+ :custom (repeat string)
+ :label "Configuration Options"
+ :group (settings)
+ :documentation "List of available configuration types.
+Individual target/project types can form associations between a configuration,
+and target specific elements such as build variables.")
+ (configuration-default :initarg :configuration-default
+ :initform "debug"
+ :custom string
+ :label "Current Configuration"
+ :group (settings)
+ :documentation "The default configuration.")
+ (local-variables :initarg :local-variables
+ :initform nil
+ :custom (repeat (cons (sexp :tag "Variable")
+ (sexp :tag "Value")))
+ :label "Project Local Variables"
+ :group (settings)
+ :documentation "Project local variables")
+ (keybindings :allocation :class
+ :initform (("D" . ede-debug-target))
+ :documentation "Keybindings specialized to this type of target."
+ :accessor ede-object-keybindings)
+ (menu :allocation :class
+ :initform
+ (
+ [ "Update Version" ede-update-version ede-object ]
+ [ "Version Control Status" ede-vc-project-directory ede-object ]
+ [ "Edit Project Homepage" ede-edit-web-page
+ (and ede-object (oref (ede-toplevel) web-site-file)) ]
+ [ "Browse Project URL" ede-web-browse-home
+ (and ede-object
+ (not (string= "" (oref (ede-toplevel) web-site-url)))) ]
+ "--"
+ [ "Rescan Project Files" ede-rescan-toplevel t ]
+ [ "Edit Projectfile" ede-edit-file-target
+ (and ede-object
+ (or (listp ede-object)
+ (not (obj-of-class-p ede-object ede-project)))) ]
+ )
+ :documentation "Menu specialized to this type of target."
+ :accessor ede-object-menu)
+ )
+ "Top level EDE project specification.
+All specific project types must derive from this project."
+ :method-invocation-order :depth-first)
+
+;;; Management variables
+
+(defvar ede-projects nil
+ "A list of all active projects currently loaded in Emacs.")
+
+(defvar ede-object-root-project nil
+ "The current buffer's current root project.
+If a file is under a project, this specifies the project that is at
+the root of a project tree.")
+(make-variable-buffer-local 'ede-object-root-project)
+
+(defvar ede-object-project nil
+ "The current buffer's current project at that level.
+If a file is under a project, this specifies the project that contains the
+current target.")
+(make-variable-buffer-local 'ede-object-project)
+
+(defvar ede-object nil
+ "The current buffer's target object.
+This object's class determines how to compile and debug from a buffer.")
+(make-variable-buffer-local 'ede-object)
+
+(defvar ede-selected-object nil
+ "The currently user-selected project or target.
+If `ede-object' is nil, then commands will operate on this object.")
+
+(defvar ede-constructing nil
+ "Non nil when constructing a project hierarchy.")
+
+(defvar ede-deep-rescan nil
+ "Non nil means scan down a tree, otherwise rescans are top level only.
+Do not set this to non-nil globally. It is used internally.")
+
+;;; The EDE persistent cache.
+;;
+(defcustom ede-project-placeholder-cache-file
+ (expand-file-name "~/.projects.ede")
+ "File containing the list of projects EDE has viewed."
+ :group 'ede
+ :type 'file)
+
+(defvar ede-project-cache-files nil
+ "List of project files EDE has seen before.")
+
+(defun ede-save-cache ()
+ "Save a cache of EDE objects that Emacs has seen before."
+ (interactive)
+ (let ((p ede-projects)
+ (c ede-project-cache-files)
+ (recentf-exclude '(ignore))
+ )
+ (condition-case nil
+ (progn
+ (set-buffer (find-file-noselect ede-project-placeholder-cache-file t))
+ (erase-buffer)
+ (insert ";; EDE project cache file.
+;; This contains a list of projects you have visited.\n(")
+ (while p
+ (when (and (car p) (ede-project-p p))
+ (let ((f (oref (car p) file)))
+ (when (file-exists-p f)
+ (insert "\n \"" f "\""))))
+ (setq p (cdr p)))
+ (while c
+ (insert "\n \"" (car c) "\"")
+ (setq c (cdr c)))
+ (insert "\n)\n")
+ (condition-case nil
+ (save-buffer 0)
+ (error
+ (message "File %s could not be saved."
+ ede-project-placeholder-cache-file)))
+ (kill-buffer (current-buffer))
+ )
+ (error
+ (message "File %s could not be read."
+ ede-project-placeholder-cache-file))
+
+ )))
+
+(defun ede-load-cache ()
+ "Load the cache of EDE projects."
+ (save-excursion
+ (let ((cachebuffer nil))
+ (condition-case nil
+ (progn
+ (setq cachebuffer
+ (find-file-noselect ede-project-placeholder-cache-file t))
+ (set-buffer cachebuffer)
+ (goto-char (point-min))
+ (let ((c (read (current-buffer)))
+ (new nil)
+ (p ede-projects))
+ ;; Remove loaded projects from the cache.
+ (while p
+ (setq c (delete (oref (car p) file) c))
+ (setq p (cdr p)))
+ ;; Remove projects that aren't on the filesystem
+ ;; anymore.
+ (while c
+ (when (file-exists-p (car c))
+ (setq new (cons (car c) new)))
+ (setq c (cdr c)))
+ ;; Save it
+ (setq ede-project-cache-files (nreverse new))))
+ (error nil))
+ (when cachebuffer (kill-buffer cachebuffer))
+ )))
+
+;;; Important macros for doing commands.
+;;
+(defmacro ede-with-projectfile (obj &rest forms)
+ "For the project in which OBJ resides, execute FORMS."
+ (list 'save-window-excursion
+ (list 'let* (list
+ (list 'pf
+ (list 'if (list 'obj-of-class-p
+ obj 'ede-target)
+ ;; @todo -I think I can change
+ ;; this to not need ede-load-project-file
+ ;; but I'm not sure how to test well.
+ (list 'ede-load-project-file
+ (list 'oref obj 'path))
+ obj))
+ '(dbka (get-file-buffer (oref pf file))))
+ '(if (not dbka) (find-file (oref pf file))
+ (switch-to-buffer dbka))
+ (cons 'progn forms)
+ '(if (not dbka) (kill-buffer (current-buffer))))))
+(put 'ede-with-projectfile 'lisp-indent-function 1)
+
+
+;;; Prompting
+;;
+(defun ede-singular-object (prompt)
+ "Using PROMPT, choose a single object from the current buffer."
+ (if (listp ede-object)
+ (ede-choose-object prompt ede-object)
+ ede-object))
+
+(defun ede-choose-object (prompt list-o-o)
+ "Using PROMPT, ask the user which OBJECT to use based on the name field.
+Argument LIST-O-O is the list of objects to choose from."
+ (let* ((al (object-assoc-list 'name list-o-o))
+ (ans (completing-read prompt al nil t)))
+ (setq ans (assoc ans al))
+ (cdr ans)))
+
+;;; Menu and Keymap
+
+(defvar ede-minor-mode-map
+ (let ((map (make-sparse-keymap))
+ (pmap (make-sparse-keymap)))
+ (define-key pmap "e" 'ede-edit-file-target)
+ (define-key pmap "a" 'ede-add-file)
+ (define-key pmap "d" 'ede-remove-file)
+ (define-key pmap "t" 'ede-new-target)
+ (define-key pmap "g" 'ede-rescan-toplevel)
+ (define-key pmap "s" 'ede-speedbar)
+ (define-key pmap "l" 'ede-load-project-file)
+ (define-key pmap "f" 'ede-find-file)
+ (define-key pmap "C" 'ede-compile-project)
+ (define-key pmap "c" 'ede-compile-target)
+ (define-key pmap "\C-c" 'ede-compile-selected)
+ (define-key pmap "D" 'ede-debug-target)
+ ;; bind our submap into map
+ (define-key map "\C-c." pmap)
+ map)
+ "Keymap used in project minor mode.")
+
+(defvar global-ede-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [menu-bar cedet-menu]
+ (cons "Development" cedet-menu-map))
+ map)
+ "Keymap used in `global-ede-mode'")
+
+;; Activate the EDE items in cedet-menu-map
+
+(define-key cedet-menu-map [ede-find-file]
+ '(menu-item "Find File in Project..." ede-find-file :enable ede-object))
+(define-key cedet-menu-map [ede-speedbar]
+ '(menu-item "View Project Tree" ede-speedbar :enable ede-object))
+(define-key cedet-menu-map [ede]
+ '(menu-item "Load Project" ede))
+(define-key cedet-menu-map [ede-new]
+ '(menu-item "Create Project" ede-new
+ :enable (not ede-object)))
+(define-key cedet-menu-map [ede-target-options]
+ '(menu-item "Target Options" ede-target-options
+ :filter ede-target-forms-menu))
+(define-key cedet-menu-map [ede-project-options]
+ '(menu-item "Project Options" ede-project-options
+ :filter ede-project-forms-menu))
+(define-key cedet-menu-map [ede-build-forms-menu]
+ '(menu-item "Build Project" ede-build-forms-menu
+ :filter ede-build-forms-menu
+ :enable ede-object))
+(define-key cedet-menu-map [semantic-menu-separator] 'undefined)
+(define-key cedet-menu-map [cedet-menu-separator] 'undefined)
+(define-key cedet-menu-map [ede-menu-separator] '("--"))
+
+(defun ede-menu-obj-of-class-p (class)
+ "Return non-nil if some member of `ede-object' is a child of CLASS."
+ (if (listp ede-object)
+ (eval (cons 'or (mapcar (lambda (o) (obj-of-class-p o class))
ede-object)))
+ (obj-of-class-p ede-object class)))
+
+(defun ede-build-forms-menu (menu-def)
+ "Create a sub menu for building different parts of an EDE system.
+Argument MENU-DEF is the menu definition to use."
+ (easy-menu-filter-return
+ (easy-menu-create-menu
+ "Build Forms"
+ (let ((obj (ede-current-project))
+ (newmenu nil) ;'([ "Build Selected..." ede-compile-selected t ]))
+ targets
+ targitems
+ ede-obj
+ (tskip nil))
+ (if (not obj)
+ nil
+ (setq targets (when (slot-boundp obj 'targets)
+ (oref obj targets))
+ ede-obj (if (listp ede-object) ede-object (list ede-object)))
+ ;; First, collect the build items from the project
+ (setq newmenu (append newmenu (ede-menu-items-build obj t)))
+ ;; Second, Declare the current target menu items
+ (if (and ede-obj (ede-menu-obj-of-class-p ede-target))
+ (while ede-obj
+ (setq newmenu (append newmenu
+ (ede-menu-items-build (car ede-obj) t))
+ tskip (car ede-obj)
+ ede-obj (cdr ede-obj))))
+ ;; Third, by name, enable builds for other local targets
+ (while targets
+ (unless (eq tskip (car targets))
+ (setq targitems (ede-menu-items-build (car targets) nil))
+ (setq newmenu
+ (append newmenu
+ (if (= 1 (length targitems))
+ targitems
+ (cons (ede-name (car targets))
+ targitems))))
+ )
+ (setq targets (cdr targets)))
+ ;; Fourth, build sub projects.
+ ;; -- nerp
+ ;; Fifth, Add make distribution
+ (append newmenu (list [ "Make distribution" ede-make-dist t ]))
+ )))))
+
+(defun ede-target-forms-menu (menu-def)
+ "Create a target MENU-DEF based on the object belonging to this buffer."
+ (easy-menu-filter-return
+ (easy-menu-create-menu
+ "Target Forms"
+ (let ((obj (or ede-selected-object ede-object)))
+ (append
+ '([ "Add File" ede-add-file (ede-current-project) ]
+ [ "Remove File" ede-remove-file
+ (and ede-object
+ (or (listp ede-object)
+ (not (obj-of-class-p ede-object ede-project)))) ]
+ "-")
+ (if (not obj)
+ nil
+ (if (and (not (listp obj)) (oref obj menu))
+ (oref obj menu)
+ (when (listp obj)
+ ;; This is bad, but I'm not sure what else to do.
+ (oref (car obj) menu)))))))))
+
+(defun ede-project-forms-menu (menu-def)
+ "Create a target MENU-DEF based on the object belonging to this buffer."
+ (easy-menu-filter-return
+ (easy-menu-create-menu
+ "Project Forms"
+ (let* ((obj (ede-current-project))
+ (class (if obj (object-class obj)))
+ (menu nil))
+ (condition-case err
+ (progn
+ (while (and class (slot-exists-p class 'menu))
+ ;;(message "Looking at class %S" class)
+ (setq menu (append menu (oref class menu))
+ class (class-parent class))
+ (if (listp class) (setq class (car class))))
+ (append
+ '( [ "Add Target" ede-new-target (ede-current-project) ]
+ [ "Remove Target" ede-delete-target ede-object ]
+ "-")
+ menu
+ ))
+ (error (message "Err found: %S" err)
+ menu)
+ )))))
+
+(defun ede-customize-forms-menu (menu-def)
+ "Create a menu of the project, and targets that can be customized.
+Argument MENU-DEF is the definition of the current menu."
+ (easy-menu-filter-return
+ (easy-menu-create-menu
+ "Customize Project"
+ (let* ((obj (ede-current-project))
+ targ)
+ (when obj
+ (setq targ (when (slot-boundp obj 'targets)
+ (oref obj targets)))
+ ;; Make custom menus for everything here.
+ (append (list
+ (cons (concat "Project " (ede-name obj))
+ (eieio-customize-object-group obj))
+ [ "Reorder Targets" ede-project-sort-targets t ]
+ )
+ (mapcar (lambda (o)
+ (cons (concat "Target " (ede-name o))
+ (eieio-customize-object-group o)))
+ targ)))))))
+
+
+(defun ede-apply-object-keymap (&optional default)
+ "Add target specific keybindings into the local map.
+Optional argument DEFAULT indicates if this should be set to the default
+version of the keymap."
+ (let ((object (or ede-object ede-selected-object)))
+ (condition-case nil
+ (let ((keys (ede-object-keybindings object)))
+ (while keys
+ (local-set-key (concat "\C-c." (car (car keys)))
+ (cdr (car keys)))
+ (setq keys (cdr keys))))
+ (error nil))))
+
+;;; Menu building methods for building
+;;
+(defmethod ede-menu-items-build ((obj ede-project) &optional current)
+ "Return a list of menu items for building project OBJ.
+If optional argument CURRENT is non-nil, return sub-menu code."
+ (if current
+ (list [ "Build Current Project" ede-compile-project t ])
+ (list (vector
+ (list
+ (concat "Build Project " (ede-name obj))
+ `(project-compile-project ,obj))))))
+
+(defmethod ede-menu-items-build ((obj ede-target) &optional current)
+ "Return a list of menu items for building target OBJ.
+If optional argument CURRENT is non-nil, return sub-menu code."
+ (if current
+ (list [ "Build Current Target" ede-compile-target t ])
+ (list (vector
+ (concat "Build Target " (ede-name obj))
+ `(project-compile-target ,obj)
+ t))))
+
+;;; Mode Declarations
+;;
+(eval-and-compile
+ (autoload 'ede-dired-minor-mode "ede/dired" "EDE commands for dired" t))
+
+(defun ede-apply-target-options ()
+ "Apply options to the current buffer for the active project/target."
+ (if (ede-current-project)
+ (ede-set-project-variables (ede-current-project)))
+ (ede-apply-object-keymap)
+ (ede-apply-preprocessor-map)
+ )
+
+(defun ede-turn-on-hook ()
+ "Turn on EDE minor mode in the current buffer if needed.
+To be used in hook functions."
+ (if (or (and (stringp (buffer-file-name))
+ (stringp default-directory))
+ ;; Emacs 21 has no buffer file name for directory edits.
+ ;; so we need to add these hacks in.
+ (eq major-mode 'dired-mode)
+ (eq major-mode 'vc-dired-mode))
+ (ede-minor-mode 1)))
+
+(define-minor-mode ede-minor-mode
+ "Toggle EDE (Emacs Development Environment) minor mode.
+With non-nil argument ARG, enable EDE minor mode if ARG is
+positive; otherwise, disable it.
+
+If this file is contained, or could be contained in an EDE
+controlled project, then this mode is activated automatically
+provided `global-ede-mode' is enabled."
+ :group 'ede
+ (cond ((or (eq major-mode 'dired-mode)
+ (eq major-mode 'vc-dired-mode))
+ (ede-dired-minor-mode (if ede-minor-mode 1 -1)))
+ (ede-minor-mode
+ (if (and (not ede-constructing)
+ (ede-directory-project-p default-directory t))
+ (let* ((ROOT nil)
+ (proj (ede-directory-get-open-project default-directory
+ 'ROOT)))
+ (when (not proj)
+ ;; @todo - this could be wasteful.
+ (setq proj (ede-load-project-file default-directory 'ROOT)))
+ (setq ede-object-project proj)
+ (setq ede-object-root-project
+ (or ROOT (ede-project-root proj)))
+ (setq ede-object (ede-buffer-object))
+ (if (and (not ede-object) ede-object-project)
+ (ede-auto-add-to-target))
+ (ede-apply-target-options))
+ ;; If we fail to have a project here, turn it back off.
+ (ede-minor-mode -1)))))
+
+(defun ede-reset-all-buffers (onoff)
+ "Reset all the buffers due to change in EDE.
+ONOFF indicates enabling or disabling the mode."
+ (let ((b (buffer-list)))
+ (while b
+ (when (buffer-file-name (car b))
+ (ede-buffer-object (car b))
+ )
+ (setq b (cdr b)))))
+
+;;;###autoload
+(define-minor-mode global-ede-mode
+ "Toggle global EDE (Emacs Development Environment) mode.
+With non-nil argument ARG, enable global EDE mode if ARG is
+positive; otherwise, disable it.
+
+This global minor mode enables `ede-minor-mode' in all buffers in
+an EDE controlled project."
+ :global t
+ :group 'ede
+ (if global-ede-mode
+ ;; Turn on global-ede-mode
+ (progn
+ (add-hook 'semanticdb-project-predicate-functions
'ede-directory-project-p)
+ (add-hook 'semanticdb-project-root-functions
'ede-toplevel-project-or-nil)
+ (add-hook 'ecb-source-path-functions 'ede-ecb-project-paths)
+ (add-hook 'find-file-hook 'ede-turn-on-hook)
+ (add-hook 'dired-mode-hook 'ede-turn-on-hook)
+ (add-hook 'kill-emacs-hook 'ede-save-cache)
+ (ede-load-cache)
+ (ede-reset-all-buffers 1))
+ ;; Turn off global-ede-mode
+ (remove-hook 'semanticdb-project-predicate-functions
'ede-directory-project-p)
+ (remove-hook 'semanticdb-project-root-functions
'ede-toplevel-project-or-nil)
+ (remove-hook 'ecb-source-path-functions 'ede-ecb-project-paths)
+ (remove-hook 'find-file-hook 'ede-turn-on-hook)
+ (remove-hook 'dired-mode-hook 'ede-turn-on-hook)
+ (remove-hook 'kill-emacs-hook 'ede-save-cache)
+ (ede-save-cache)
+ (ede-reset-all-buffers -1)))
+
+(defvar ede-ignored-file-alist
+ '( "\\.cvsignore$"
+ "\\.#"
+ "~$"
+ )
+ "List of file name patters that EDE will never ask about.")
+
+(defun ede-ignore-file (filename)
+ "Should we ignore FILENAME?"
+ (let ((any nil)
+ (F ede-ignored-file-alist))
+ (while (and (not any) F)
+ (when (string-match (car F) filename)
+ (setq any t))
+ (setq F (cdr F)))
+ any))
+
+(defun ede-auto-add-to-target ()
+ "Look for a target that wants to own the current file.
+Follow the preference set with `ede-auto-add-method' and get the list
+of objects with the `ede-want-file-p' method."
+ (if ede-object (error "Ede-object already defined for %s" (buffer-name)))
+ (if (or (eq ede-auto-add-method 'never)
+ (ede-ignore-file (buffer-file-name)))
+ nil
+ (let (wants desires)
+ ;; Find all the objects.
+ (setq wants (oref (ede-current-project) targets))
+ (while wants
+ (if (ede-want-file-p (car wants) (buffer-file-name))
+ (setq desires (cons (car wants) desires)))
+ (setq wants (cdr wants)))
+ (if desires
+ (cond ((or (eq ede-auto-add-method 'ask)
+ (and (eq ede-auto-add-method 'multi-ask)
+ (< 1 (length desires))))
+ (let* ((al (append
+ ;; some defaults
+ '(("none" . nil)
+ ("new target" . new))
+ ;; If we are in an unparented subdir,
+ ;; offer new a subproject
+ (if (ede-directory-project-p default-directory)
+ ()
+ '(("create subproject" . project)))
+ ;; Here are the existing objects we want.
+ (object-assoc-list 'name desires)))
+ (case-fold-search t)
+ (ans (completing-read
+ (format "Add %s to target: " (buffer-file-name))
+ al nil t)))
+ (setq ans (assoc ans al))
+ (cond ((eieio-object-p (cdr ans))
+ (ede-add-file (cdr ans)))
+ ((eq (cdr ans) 'new)
+ (ede-new-target))
+ (t nil))))
+ ((or (eq ede-auto-add-method 'always)
+ (and (eq ede-auto-add-method 'multi-ask)
+ (= 1 (length desires))))
+ (ede-add-file (car desires)))
+ (t nil))))))
+
+
+;;; Interactive method invocations
+;;
+(defun ede (file)
+ "Start up EDE on something.
+Argument FILE is the file or directory to load a project from."
+ (interactive "fProject File: ")
+ (if (not (file-exists-p file))
+ (ede-new file)
+ (ede-load-project-file (file-name-directory file))))
+
+(defun ede-new (type &optional name)
+ "Create a new project starting of project type TYPE.
+Optional argument NAME is the name to give this project."
+ (interactive
+ (list (completing-read "Project Type: "
+ (object-assoc-list
+ 'name
+ (let* ((l ede-project-class-files)
+ (cp (ede-current-project))
+ (cs (when cp (object-class cp)))
+ (r nil))
+ (while l
+ (if cs
+ (if (eq (oref (car l) :class-sym)
+ cs)
+ (setq r (cons (car l) r)))
+ (if (oref (car l) new-p)
+ (setq r (cons (car l) r))))
+ (setq l (cdr l)))
+ (when (not r)
+ (if cs
+ (error "No valid interactive sub project
types for %s"
+ cs)
+ (error "EDE error: Can't fin project types to
create")))
+ r)
+ )
+ nil t)))
+ ;; Make sure we have a valid directory
+ (when (not (file-exists-p default-directory))
+ (error "Cannot create project in non-existant directory %s"
default-directory))
+ (when (not (file-writable-p default-directory))
+ (error "No write permissions for %s" default-directory))
+ ;; Create the project
+ (let* ((obj (object-assoc type 'name ede-project-class-files))
+ (nobj (let ((f (oref obj file))
+ (pf (oref obj proj-file)))
+ ;; We are about to make something new, changing the
+ ;; state of existing directories.
+ (ede-project-directory-remove-hash default-directory)
+ ;; Make sure this class gets loaded!
+ (require f)
+ (make-instance (oref obj class-sym)
+ :name (or name (read-string "Name: "))
+ :directory default-directory
+ :file (cond ((stringp pf)
+ (expand-file-name pf))
+ ((fboundp pf)
+ (funcall pf))
+ (t
+ (error
+ "Unknown file name specifier %S"
+ pf)))
+ :targets nil)))
+ (inits (oref obj initializers)))
+ ;; Force the name to match for new objects.
+ (object-set-name-string nobj (oref nobj :name))
+ ;; Handle init args.
+ (while inits
+ (eieio-oset nobj (car inits) (car (cdr inits)))
+ (setq inits (cdr (cdr inits))))
+ (let ((pp (ede-parent-project)))
+ (when pp
+ (ede-add-subproject pp nobj)
+ (ede-commit-project pp)))
+ (ede-commit-project nobj))
+ ;; Have the menu appear
+ (setq ede-minor-mode t)
+ ;; Allert the user
+ (message "Project created and saved. You may now create targets."))
+
+(defmethod ede-add-subproject ((proj-a ede-project) proj-b)
+ "Add into PROJ-A, the subproject PROJ-B."
+ (oset proj-a subproj (cons proj-b (oref proj-a subproj))))
+
+(defmethod ede-subproject-relative-path ((proj ede-project) &optional
parent-in)
+ "Get a path name for PROJ which is relative to the parent project.
+If PARENT is specified, then be relative to the PARENT project.
+Specifying PARENT is useful for sub-sub projects relative to the root project."
+ (let* ((parent (or parent-in (ede-parent-project proj)))
+ (dir (file-name-directory (oref proj file))))
+ (if (and parent (not (eq parent proj)))
+ (file-relative-name dir (file-name-directory (oref parent file)))
+ "")))
+
+(defmethod ede-subproject-p ((proj ede-project))
+ "Return non-nil if PROJ is a sub project."
+ (ede-parent-project proj))
+
+(defun ede-invoke-method (sym &rest args)
+ "Invoke method SYM on the current buffer's project object.
+ARGS are additional arguments to pass to method sym."
+ (if (not ede-object)
+ (error "Cannot invoke %s for %s" (symbol-name sym)
+ (buffer-name)))
+ ;; Always query a target. There should never be multiple
+ ;; projects in a single buffer.
+ (apply sym (ede-singular-object "Target: ") args))
+
+(defun ede-rescan-toplevel ()
+ "Rescan all project files."
+ (interactive)
+ (let ((toppath (ede-toplevel-project default-directory))
+ (ede-deep-rescan t))
+ (project-rescan (ede-load-project-file toppath))
+ (ede-reset-all-buffers 1)
+ ))
+
+(defun ede-new-target (&rest args)
+ "Create a new target specific to this type of project file.
+Different projects accept different arguments ARGS.
+Typically you can specify NAME, target TYPE, and AUTOADD, where AUTOADD is
+a string \"y\" or \"n\", which answers the y/n question done interactively."
+ (interactive)
+ (apply 'project-new-target (ede-current-project) args)
+ (setq ede-object nil)
+ (setq ede-object (ede-buffer-object (current-buffer)))
+ (ede-apply-target-options))
+
+(defun ede-new-target-custom ()
+ "Create a new target specific to this type of project file."
+ (interactive)
+ (project-new-target-custom (ede-current-project)))
+
+(defun ede-delete-target (target)
+ "Delete TARGET from the current project."
+ (interactive (list
+ (let ((ede-object (ede-current-project)))
+ (ede-invoke-method 'project-interactive-select-target
+ "Target: "))))
+ ;; Find all sources in buffers associated with the condemned buffer.
+ (let ((condemned (ede-target-buffers target)))
+ (project-delete-target target)
+ ;; Loop over all project controlled buffers
+ (save-excursion
+ (while condemned
+ (set-buffer (car condemned))
+ (setq ede-object nil)
+ (setq ede-object (ede-buffer-object (current-buffer)))
+ (setq condemned (cdr condemned))))
+ (ede-apply-target-options)))
+
+(defun ede-add-file (target)
+ "Add the current buffer to a TARGET in the current project."
+ (interactive (list
+ (let ((ede-object (ede-current-project)))
+ (ede-invoke-method 'project-interactive-select-target
+ "Target: "))))
+ (when (stringp target)
+ (let* ((proj (ede-current-project))
+ (ob (object-assoc-list 'name (oref proj targets))))
+ (setq target (cdr (assoc target ob)))))
+
+ (when (not target)
+ (error "Could not find specified target %S" target))
+
+ (project-add-file target (buffer-file-name))
+ (setq ede-object nil)
+ (setq ede-object (ede-buffer-object (current-buffer)))
+ (when (not ede-object)
+ (error "Can't add %s to target %s: Wrong file type"
+ (file-name-nondirectory (buffer-file-name))
+ (object-name target)))
+ (ede-apply-target-options))
+
+(defun ede-remove-file (&optional force)
+ "Remove the current file from targets.
+Optional argument FORCE forces the file to be removed without asking."
+ (interactive "P")
+ (if (not ede-object)
+ (error "Cannot invoke remove-file for %s" (buffer-name)))
+ (let ((eo (if (listp ede-object)
+ (prog1
+ ede-object
+ (setq force nil))
+ (list ede-object))))
+ (while eo
+ (if (or force (y-or-n-p (format "Remove from %s? " (ede-name (car eo)))))
+ (project-remove-file (car eo) (buffer-file-name)))
+ (setq eo (cdr eo)))
+ (setq ede-object nil)
+ (setq ede-object (ede-buffer-object (current-buffer)))
+ (ede-apply-target-options)))
+
+(defun ede-edit-file-target ()
+ "Enter the project file to hand edit the current buffer's target."
+ (interactive)
+ (ede-invoke-method 'project-edit-file-target))
+
+(defun ede-compile-project ()
+ "Compile the current project."
+ (interactive)
+ ;; @TODO - This just wants the root. There should be a better way.
+ (let ((cp (ede-current-project)))
+ (while (ede-parent-project cp)
+ (setq cp (ede-parent-project cp)))
+ (let ((ede-object cp))
+ (ede-invoke-method 'project-compile-project))))
+
+(defun ede-compile-selected (target)
+ "Compile some TARGET from the current project."
+ (interactive (list (project-interactive-select-target (ede-current-project)
+ "Target to Build: ")))
+ (project-compile-target target))
+
+(defun ede-compile-target ()
+ "Compile the current buffer's associated target."
+ (interactive)
+ (ede-invoke-method 'project-compile-target))
+
+(defun ede-debug-target ()
+ "Debug the current buffer's assocated target."
+ (interactive)
+ (ede-invoke-method 'project-debug-target))
+
+(defun ede-make-dist ()
+ "Create a distribution from the current project."
+ (interactive)
+ (let ((ede-object (ede-current-project)))
+ (ede-invoke-method 'project-make-dist)))
+
+;;; Customization
+;;
+;; Routines for customizing projects and targets.
+
+(defvar eieio-ede-old-variables nil
+ "The old variables for a project.")
+
+(defalias 'customize-project 'ede-customize-project)
+(defun ede-customize-project (&optional group)
+ "Edit fields of the current project through EIEIO & Custom.
+Optional GROUP specifies the subgroup of slots to customize."
+ (interactive "P")
+ (require 'eieio-custom)
+ (let* ((ov (oref (ede-current-project) local-variables))
+ (cp (ede-current-project))
+ (group (if group (eieio-read-customization-group cp))))
+ (eieio-customize-object cp group)
+ (make-local-variable 'eieio-ede-old-variables)
+ (setq eieio-ede-old-variables ov)))
+
+(defalias 'customize-target 'ede-customize-current-target)
+(defun ede-customize-current-target(&optional group)
+ "Edit fields of the current target through EIEIO & Custom.
+Optional argument OBJ is the target object to customize.
+Optional argument GROUP is the slot group to display."
+ (interactive "P")
+ (require 'eieio-custom)
+ (if (not (obj-of-class-p ede-object ede-target))
+ (error "Current file is not part of a target."))
+ (let ((group (if group (eieio-read-customization-group ede-object))))
+ (ede-customize-target ede-object group)))
+
+(defun ede-customize-target (obj group)
+ "Edit fields of the current target through EIEIO & Custom.
+Optional argument OBJ is the target object to customize.
+Optional argument GROUP is the slot group to display."
+ (require 'eieio-custom)
+ (if (and obj (not (obj-of-class-p obj ede-target)))
+ (error "No logical target to customize"))
+ (eieio-customize-object obj (or group 'default)))
+;;; Target Sorting
+;;
+;; Target order can be important, but custom doesn't support a way
+;; to resort items in a list. This function by David Engster allows
+;; targets to be re-arranged.
+
+(defvar ede-project-sort-targets-order nil
+ "Variable for tracking target order in `ede-project-sort-targets'.")
+
+(defun ede-project-sort-targets ()
+ "Create a custom-like buffer for sorting targets of current project."
+ (interactive)
+ (let ((proj (ede-current-project))
+ (count 1)
+ current order)
+ (switch-to-buffer (get-buffer-create "*EDE sort targets*"))
+ (erase-buffer)
+ (setq ede-object-project proj)
+ (widget-create 'push-button
+ :notify (lambda (&rest ignore)
+ (let ((targets (oref ede-object-project targets))
+ cur newtargets)
+ (while (setq cur (pop
ede-project-sort-targets-order))
+ (setq newtargets (append newtargets
+ (list (nth cur
targets)))))
+ (oset ede-object-project targets newtargets))
+ (ede-commit-project ede-object-project)
+ (kill-buffer))
+ " Accept ")
+ (widget-insert " ")
+ (widget-create 'push-button
+ :notify (lambda (&rest ignore)
+ (kill-buffer))
+ " Cancel ")
+ (widget-insert "\n\n")
+ (setq ede-project-sort-targets-order nil)
+ (mapc (lambda (x)
+ (add-to-ordered-list
+ 'ede-project-sort-targets-order
+ x x))
+ (number-sequence 0 (1- (length (oref proj targets)))))
+ (ede-project-sort-targets-list)
+ (use-local-map widget-keymap)
+ (widget-setup)
+ (goto-char (point-min))))
+
+(defun ede-project-sort-targets-list ()
+ "Sort the target list while using `ede-project-sort-targets'."
+ (save-excursion
+ (let ((count 0)
+ (targets (oref ede-object-project targets))
+ (inhibit-read-only t)
+ (inhibit-modification-hooks t))
+ (goto-char (point-min))
+ (forward-line 2)
+ (delete-region (point) (point-max))
+ (while (< count (length targets))
+ (if (> count 0)
+ (widget-create 'push-button
+ :notify `(lambda (&rest ignore)
+ (let ((cur
ede-project-sort-targets-order))
+ (add-to-ordered-list
+ 'ede-project-sort-targets-order
+ (nth ,count cur)
+ (1- ,count))
+ (add-to-ordered-list
+ 'ede-project-sort-targets-order
+ (nth (1- ,count) cur) ,count))
+ (ede-project-sort-targets-list))
+ " Up ")
+ (widget-insert " "))
+ (if (< count (1- (length targets)))
+ (widget-create 'push-button
+ :notify `(lambda (&rest ignore)
+ (let ((cur
ede-project-sort-targets-order))
+ (add-to-ordered-list
+ 'ede-project-sort-targets-order
+ (nth ,count cur) (1+ ,count))
+ (add-to-ordered-list
+ 'ede-project-sort-targets-order
+ (nth (1+ ,count) cur) ,count))
+ (ede-project-sort-targets-list))
+ " Down ")
+ (widget-insert " "))
+ (widget-insert (concat " " (number-to-string (1+ count)) ".: "
+ (oref (nth (nth count
ede-project-sort-targets-order)
+ targets) name) "\n"))
+ (setq count (1+ count))))))
+
+;;; Customization hooks
+;;
+;; These hooks are used when finishing up a customization.
+(defmethod eieio-done-customizing ((proj ede-project))
+ "Call this when a user finishes customizing PROJ."
+ (let ((ov eieio-ede-old-variables)
+ (nv (oref proj local-variables)))
+ (setq eieio-ede-old-variables nil)
+ (while ov
+ (if (not (assoc (car (car ov)) nv))
+ (save-excursion
+ (mapc (lambda (b)
+ (set-buffer b)
+ (kill-local-variable (car (car ov))))
+ (ede-project-buffers proj))))
+ (setq ov (cdr ov)))
+ (mapc (lambda (b) (ede-set-project-variables proj b))
+ (ede-project-buffers proj))))
+
+(defmethod eieio-done-customizing ((target ede-target))
+ "Call this when a user finishes customizing TARGET."
+ nil)
+
+(defmethod ede-commit-project ((proj ede-project))
+ "Commit any change to PROJ to its file."
+ nil
+ )
+
+
+;;; EDE project placeholder methods
+;;
+(defmethod ede-project-force-load ((this ede-project-placeholder))
+ "Make sure the placeholder THIS is replaced with the real thing.
+Return the new object created in its place."
+ this
+ )
+
+
+;;; EDE project target baseline methods.
+;;
+;; If you are developing a new project type, you need to implement
+;; all of these methods, unless, of course, they do not make sense
+;; for your particular project.
+;;
+;; Your targets should inherit from `ede-target', and your project
+;; files should inherit from `ede-project'. Create the appropriate
+;; methods based on those below.
+
+(defmethod project-interactive-select-target ((this ede-project-placeholder)
prompt)
+ ; checkdoc-params: (prompt)
+ "Make sure placeholder THIS is replaced with the real thing, and pass
through."
+ (project-interactive-select-target (ede-project-force-load this) prompt))
+
+(defmethod project-interactive-select-target ((this ede-project) prompt)
+ "Interactively query for a target that exists in project THIS.
+Argument PROMPT is the prompt to use when querying the user for a target."
+ (let ((ob (object-assoc-list 'name (oref this targets))))
+ (cdr (assoc (completing-read prompt ob nil t) ob))))
+
+(defmethod project-add-file ((this ede-project-placeholder) file)
+ ; checkdoc-params: (file)
+ "Make sure placeholder THIS is replaced with the real thing, and pass
through."
+ (project-add-file (ede-project-force-load this) file))
+
+(defmethod project-add-file ((ot ede-target) file)
+ "Add the current buffer into project project target OT.
+Argument FILE is the file to add."
+ (error "add-file not supported by %s" (object-name ot)))
+
+(defmethod project-remove-file ((ot ede-target) fnnd)
+ "Remove the current buffer from project target OT.
+Argument FNND is an argument."
+ (error "remove-file not supported by %s" (object-name ot)))
+
+(defmethod project-edit-file-target ((ot ede-target))
+ "Edit the target OT associated w/ this file."
+ (find-file (oref (ede-current-project) file)))
+
+(defmethod project-new-target ((proj ede-project) &rest args)
+ "Create a new target. It is up to the project PROJ to get the name."
+ (error "new-target not supported by %s" (object-name proj)))
+
+(defmethod project-new-target-custom ((proj ede-project))
+ "Create a new target. It is up to the project PROJ to get the name."
+ (error "New-target-custom not supported by %s" (object-name proj)))
+
+(defmethod project-delete-target ((ot ede-target))
+ "Delete the current target OT from it's parent project."
+ (error "add-file not supported by %s" (object-name ot)))
+
+(defmethod project-compile-project ((obj ede-project) &optional command)
+ "Compile the entire current project OBJ.
+Argument COMMAND is the command to use when compiling."
+ (error "compile-project not supported by %s" (object-name obj)))
+
+(defmethod project-compile-target ((obj ede-target) &optional command)
+ "Compile the current target OBJ.
+Argument COMMAND is the command to use for compiling the target."
+ (error "compile-target not supported by %s" (object-name obj)))
+
+(defmethod project-debug-target ((obj ede-target))
+ "Run the current project target OBJ in a debugger."
+ (error "debug-target not supported by %s" (object-name obj)))
+
+(defmethod project-make-dist ((this ede-project))
+ "Build a distribution for the project based on THIS project."
+ (error "Make-dist not supported by %s" (object-name this)))
+
+(defmethod project-dist-files ((this ede-project))
+ "Return a list of files that constitutes a distribution of THIS project."
+ (error "Dist-files is not supported by %s" (object-name this)))
+
+(defmethod project-rescan ((this ede-project))
+ "Rescan the EDE proj project THIS."
+ (error "Rescanning a project is not supported by %s" (object-name this)))
+
+;;; Default methods for EDE classes
+;;
+;; These are methods which you might want to override, but there is
+;; no need to in most situations because they are either a) simple, or
+;; b) cosmetic.
+
+(defmethod ede-name ((this ede-target))
+ "Return the name of THIS targt."
+ (oref this name))
+
+(defmethod ede-target-name ((this ede-target))
+ "Return the name of THIS target, suitable for make or debug style commands."
+ (oref this name))
+
+(defmethod ede-name ((this ede-project))
+ "Return a short-name for THIS project file.
+Do this by extracting the lowest directory name."
+ (oref this name))
+
+(defmethod ede-description ((this ede-project))
+ "Return a description suitable for the minibuffer about THIS."
+ (format "Project %s: %d subprojects, %d targets."
+ (ede-name this) (length (oref this subproj))
+ (length (oref this targets))))
+
+(defmethod ede-description ((this ede-target))
+ "Return a description suitable for the minibuffer about THIS."
+ (format "Target %s: with %d source files."
+ (ede-name this) (length (oref this source))))
+
+(defmethod ede-want-file-p ((this ede-target) file)
+ "Return non-nil if THIS target wants FILE."
+ ;; By default, all targets reference the source object, and let it decide.
+ (let ((src (ede-target-sourcecode this)))
+ (while (and src (not (ede-want-file-p (car src) file)))
+ (setq src (cdr src)))
+ src))
+
+(defmethod ede-want-file-source-p ((this ede-target) file)
+ "Return non-nil if THIS target wants FILE."
+ ;; By default, all targets reference the source object, and let it decide.
+ (let ((src (ede-target-sourcecode this)))
+ (while (and src (not (ede-want-file-source-p (car src) file)))
+ (setq src (cdr src)))
+ src))
+
+(defun ede-header-file ()
+ "Return the header file for the current buffer.
+Not all buffers need headers, so return nil if no applicable."
+ (if ede-object
+ (ede-buffer-header-file ede-object (current-buffer))
+ nil))
+
+(defmethod ede-buffer-header-file ((this ede-project) buffer)
+ "Return nil, projects don't have header files."
+ nil)
+
+(defmethod ede-buffer-header-file ((this ede-target) buffer)
+ "There are no default header files in EDE.
+Do a quick check to see if there is a Header tag in this buffer."
+ (save-excursion
+ (set-buffer buffer)
+ (if (re-search-forward "::Header:: \\([a-zA-Z0-9.]+\\)" nil t)
+ (buffer-substring-no-properties (match-beginning 1)
+ (match-end 1))
+ (let ((src (ede-target-sourcecode this))
+ (found nil))
+ (while (and src (not found))
+ (setq found (ede-buffer-header-file (car src) (buffer-file-name))
+ src (cdr src)))
+ found))))
+
+(defun ede-documentation-files ()
+ "Return the documentation files for the current buffer.
+Not all buffers need documentations, so return nil if no applicable.
+Some projects may have multiple documentation files, so return a list."
+ (if ede-object
+ (ede-buffer-documentation-files ede-object (current-buffer))
+ nil))
+
+(defmethod ede-buffer-documentation-files ((this ede-project) buffer)
+ "Return all documentation in project THIS based on BUFFER."
+ ;; Find the info node.
+ (ede-documentation this))
+
+(defmethod ede-buffer-documentation-files ((this ede-target) buffer)
+ "Check for some documentation files for THIS.
+Also do a quick check to see if there is a Documentation tag in this BUFFER."
+ (save-excursion
+ (set-buffer buffer)
+ (if (re-search-forward "::Documentation:: \\([a-zA-Z0-9.]+\\)" nil t)
+ (buffer-substring-no-properties (match-beginning 1)
+ (match-end 1))
+ ;; Check the master project
+ (let ((cp (ede-toplevel)))
+ (ede-buffer-documentation-files cp (current-buffer))))))
+
+(defmethod ede-documentation ((this ede-project))
+ "Return a list of files that provides documentation.
+Documentation is not for object THIS, but is provided by THIS for other
+files in the project."
+ (let ((targ (oref this targets))
+ (proj (oref this subproj))
+ (found nil))
+ (while targ
+ (setq found (append (ede-documentation (car targ)) found)
+ targ (cdr targ)))
+ (while proj
+ (setq found (append (ede-documentation (car proj)) found)
+ proj (cdr proj)))
+ found))
+
+(defmethod ede-documentation ((this ede-target))
+ "Return a list of files that provides documentation.
+Documentation is not for object THIS, but is provided by THIS for other
+files in the project."
+ nil)
+
+(defun ede-html-documentation-files ()
+ "Return a list of HTML documentation files associated with this project."
+ (ede-html-documentation (ede-toplevel))
+ )
+
+(defmethod ede-html-documentation ((this ede-project))
+ "Return a list of HTML files provided by project THIS."
+
+ )
+
+(defun ede-ecb-project-paths ()
+ "Return a list of all paths for all active EDE projects.
+This functions is meant for use with ECB."
+ (let ((p ede-projects)
+ (d nil))
+ (while p
+ (setq d (cons (file-name-directory (oref (car p) file))
+ d)
+ p (cdr p)))
+ d))
+
+;;; EDE project-autoload methods
+;;
+(defmethod ede-dir-to-projectfile ((this ede-project-autoload) dir)
+ "Return a full file name of project THIS found in DIR.
+Return nil if the project file does not exist."
+ (let* ((d (file-name-as-directory dir))
+ (root (ede-project-root-directory this d))
+ (pf (oref this proj-file))
+ (f (cond ((stringp pf)
+ (expand-file-name pf (or root d)))
+ ((and (symbolp pf) (fboundp pf))
+ (funcall pf (or root d)))))
+ )
+ (when (and f (file-exists-p f))
+ f)))
+
+;;; EDE basic functions
+;;
+(defun ede-add-project-to-global-list (proj)
+ "Add the project PROJ to the master list of projects.
+On success, return the added project."
+ (when (not proj)
+ (error "No project created to add to master list"))
+ (when (not (eieio-object-p proj))
+ (error "Attempt to add Non-object to master project list"))
+ (when (not (obj-of-class-p proj ede-project-placeholder))
+ (error "Attempt to add a non-project to the ede projects list"))
+ (add-to-list 'ede-projects proj)
+ proj)
+
+(defun ede-load-project-file (dir &optional rootreturn)
+ "Project file independent way to read a project in from DIR.
+Optional ROOTRETURN will return the root project for DIR."
+ ;; Only load if something new is going on. Flush the dirhash.
+ (ede-project-directory-remove-hash dir)
+ ;; Do the load
+ ;;(message "EDE LOAD : %S" file)
+ (let* ((file dir)
+ (path (expand-file-name (file-name-directory file)))
+ (pfc (ede-directory-project-p path))
+ (toppath nil)
+ (o nil))
+ (cond
+ ((not pfc)
+ ;; @TODO - Do we really need to scan? Is this a waste of time?
+ ;; Scan upward for a the next project file style.
+ (let ((p path))
+ (while (and p (not (ede-directory-project-p p)))
+ (setq p (ede-up-directory p)))
+ (if p (ede-load-project-file p)
+ nil)
+ ;; recomment as we go
+ ;nil
+ ))
+ ;; Do nothing if we are buiding an EDE project already
+ (ede-constructing
+ nil)
+ ;; Load in the project in question.
+ (t
+ (setq toppath (ede-toplevel-project path))
+ ;; We found the top-most directory. Check to see if we already
+ ;; have an object defining it's project.
+ (setq pfc (ede-directory-project-p toppath t))
+
+ ;; See if it's been loaded before
+ (setq o (object-assoc (ede-dir-to-projectfile pfc toppath) 'file
+ ede-projects))
+ (if (not o)
+ ;; If not, get it now.
+ (let ((ede-constructing t))
+ (setq o (funcall (oref pfc load-type) toppath))
+ (when (not o)
+ (error "Project type error: :load-type failed to create a
project"))
+ (ede-add-project-to-global-list o)))
+
+ ;; Return the found root project.
+ (when rootreturn (set rootreturn o))
+
+ (let (tocheck found)
+ ;; Now find the project file belonging to FILE!
+ (setq tocheck (list o))
+ (setq file (ede-dir-to-projectfile pfc (expand-file-name path)))
+ (while (and tocheck (not found))
+ (let ((newbits nil))
+ (when (car tocheck)
+ (if (string= file (oref (car tocheck) file))
+ (setq found (car tocheck)))
+ (setq newbits (oref (car tocheck) subproj)))
+ (setq tocheck
+ (append (cdr tocheck) newbits))))
+ (if (not found)
+ (message "No project for %s, but passes project-p test" file)
+ ;; Now that the file has been reset inside the project object, do
+ ;; the cache maintenance.
+ (setq ede-project-cache-files
+ (delete (oref found file) ede-project-cache-files)))
+ found)))))
+
+(defun ede-parent-project (&optional obj)
+ "Return the project belonging to the parent directory.
+nil if there is no previous directory.
+Optional argument OBJ is an object to find the parent of."
+ (let* ((proj (or obj ede-object-project)) ;; Current project.
+ (root (if obj (ede-project-root obj)
+ ede-object-root-project)))
+ ;; This case is a SHORTCUT if the project has defined
+ ;; a way to calculate the project root.
+ (if (and root proj (eq root proj))
+ nil ;; we are at the root.
+ ;; Else, we may have a nil proj or root.
+ (let* ((thisdir (if obj (oref obj directory)
+ default-directory))
+ (updir (ede-up-directory thisdir)))
+ (when updir
+ ;; If there was no root, perhaps we can derive it from
+ ;; updir now.
+ (let ((root (or root (ede-directory-get-toplevel-open-project
updir))))
+ (or
+ ;; This lets us find a subproject under root based on updir.
+ (and root
+ (ede-find-subproject-for-directory root updir))
+ ;; Try the all structure based search.
+ (ede-directory-get-open-project updir)
+ ;; Load up the project file as a last resort.
+ ;; Last resort since it uses file-truename, and other
+ ;; slow features.
+ (and (ede-directory-project-p updir)
+ (ede-load-project-file
+ (file-name-as-directory updir))))))))))
+
+(defun ede-current-project (&optional dir)
+ "Return the current project file.
+If optional DIR is provided, get the project for DIR instead."
+ (let ((ans nil))
+ ;; If it matches the current directory, do we have a pre-existing project?
+ (when (and (or (not dir) (string= dir default-directory))
+ ede-object-project)
+ (setq ans ede-object-project)
+ )
+ ;; No current project.
+ (when (not ans)
+ (let* ((ldir (or dir default-directory)))
+ (setq ans (ede-directory-get-open-project ldir))
+ (or ans
+ ;; No open project, if this dir pass project-p, then load.
+ (when (ede-directory-project-p ldir)
+ (setq ans (ede-load-project-file ldir))))))
+ ;; Return what we found.
+ ans))
+
+(defun ede-buffer-object (&optional buffer)
+ "Return the target object for BUFFER.
+This function clears cached values and recalculates."
+ (save-excursion
+ (if (not buffer) (setq buffer (current-buffer)))
+ (set-buffer buffer)
+ (setq ede-object nil)
+ (let ((po (ede-current-project)))
+ (if po (setq ede-object (ede-find-target po buffer))))
+ (if (= (length ede-object) 1)
+ (setq ede-object (car ede-object)))
+ ede-object))
+
+(defmethod ede-target-in-project-p ((proj ede-project) target)
+ "Is PROJ the parent of TARGET?
+If TARGET belongs to a subproject, return that project file."
+ (if (and (slot-boundp proj 'targets)
+ (memq target (oref proj targets)))
+ proj
+ (let ((s (oref proj subproj))
+ (ans nil))
+ (while (and s (not ans))
+ (setq ans (ede-target-in-project-p (car s) target))
+ (setq s (cdr s)))
+ ans)))
+
+(defun ede-target-parent (target)
+ "Return the project which is the parent of TARGET.
+It is recommended you track the project a different way as this function
+could become slow in time."
+ ;; @todo - use ede-object-project as a starting point.
+ (let ((ans nil) (projs ede-projects))
+ (while (and (not ans) projs)
+ (setq ans (ede-target-in-project-p (car projs) target)
+ projs (cdr projs)))
+ ans))
+
+(defun ede-maybe-checkout (&optional buffer)
+ "Check BUFFER out of VC if necessary."
+ (save-excursion
+ (if buffer (set-buffer buffer))
+ (if (and buffer-read-only vc-mode
+ (y-or-n-p "Checkout Makefile.am from VC? "))
+ (vc-toggle-read-only))))
+
+(defmethod ede-find-target ((proj ede-project) buffer)
+ "Fetch the target in PROJ belonging to BUFFER or nil."
+ (save-excursion
+ (set-buffer buffer)
+ (or ede-object
+ (if (ede-buffer-mine proj buffer)
+ proj
+ (let ((targets (oref proj targets))
+ (f nil))
+ (while targets
+ (if (ede-buffer-mine (car targets) buffer)
+ (setq f (cons (car targets) f)))
+ (setq targets (cdr targets)))
+ f)))))
+
+(defmethod ede-target-buffer-in-sourcelist ((this ede-target) buffer source)
+ "Return non-nil if object THIS is in BUFFER to a SOURCE list.
+Handles complex path issues."
+ (member (ede-convert-path this (buffer-file-name buffer)) source))
+
+(defmethod ede-buffer-mine ((this ede-project) buffer)
+ "Return non-nil if object THIS lays claim to the file in BUFFER."
+ nil)
+
+(defmethod ede-buffer-mine ((this ede-target) buffer)
+ "Return non-nil if object THIS lays claim to the file in BUFFER."
+ (condition-case nil
+ (ede-target-buffer-in-sourcelist this buffer (oref this source))
+ ;; An error implies a bad match.
+ (error nil)))
+
+
+;;; Project mapping
+;;
+(defun ede-project-buffers (project)
+ "Return a list of all active buffers controlled by PROJECT.
+This includes buffers controlled by a specific target of PROJECT."
+ (let ((bl (buffer-list))
+ (pl nil))
+ (while bl
+ (save-excursion
+ (set-buffer (car bl))
+ (if (and ede-object (eq (ede-current-project) project))
+ (setq pl (cons (car bl) pl))))
+ (setq bl (cdr bl)))
+ pl))
+
+(defun ede-target-buffers (target)
+ "Return a list of buffers that are controlled by TARGET."
+ (let ((bl (buffer-list))
+ (pl nil))
+ (while bl
+ (save-excursion
+ (set-buffer (car bl))
+ (if (if (listp ede-object)
+ (memq target ede-object)
+ (eq ede-object target))
+ (setq pl (cons (car bl) pl))))
+ (setq bl (cdr bl)))
+ pl))
+
+(defun ede-buffers ()
+ "Return a list of all buffers controled by an EDE object."
+ (let ((bl (buffer-list))
+ (pl nil))
+ (while bl
+ (save-excursion
+ (set-buffer (car bl))
+ (if ede-object
+ (setq pl (cons (car bl) pl))))
+ (setq bl (cdr bl)))
+ pl))
+
+(defun ede-map-buffers (proc)
+ "Execute PROC on all buffers controled by EDE."
+ (mapcar proc (ede-buffers)))
+
+(defmethod ede-map-project-buffers ((this ede-project) proc)
+ "For THIS, execute PROC on all buffers belonging to THIS."
+ (mapcar proc (ede-project-buffers this)))
+
+(defmethod ede-map-target-buffers ((this ede-target) proc)
+ "For THIS, execute PROC on all buffers belonging to THIS."
+ (mapcar proc (ede-target-buffers this)))
+
+;; other types of mapping
+(defmethod ede-map-subprojects ((this ede-project) proc)
+ "For object THIS, execute PROC on all direct subprojects.
+This function does not apply PROC to sub-sub projects.
+See also `ede-map-all-subprojects'."
+ (mapcar proc (oref this subproj)))
+
+(defmethod ede-map-all-subprojects ((this ede-project) allproc)
+ "For object THIS, execute PROC on THIS and all subprojects.
+This function also applies PROC to sub-sub projects.
+See also `ede-map-subprojects'."
+ (apply 'append
+ (list (funcall allproc this))
+ (ede-map-subprojects
+ this
+ (lambda (sp)
+ (ede-map-all-subprojects sp allproc))
+ )))
+
+;; (ede-map-all-subprojects (ede-load-project-file "../semantic/") (lambda
(sp) (oref sp file)))
+
+(defmethod ede-map-targets ((this ede-project) proc)
+ "For object THIS, execute PROC on all targets."
+ (mapcar proc (oref this targets)))
+
+(defmethod ede-map-any-target-p ((this ede-project) proc)
+ "For project THIS, map PROC to all targets and return if any non-nil.
+Return the first non-nil value returned by PROC."
+ (eval (cons 'or (ede-map-targets this proc))))
+
+
+;;; Some language specific methods.
+;;
+;; These items are needed by ede-cpp-root to add better support for
+;; configuring items for Semantic.
+(defun ede-apply-preprocessor-map ()
+ "Apply preprocessor tables onto the current buffer."
+ (when (and ede-object (boundp 'semantic-lex-spp-macro-symbol-obarray))
+ (let ((map (ede-preprocessor-map ede-object)))
+ (when map
+ ;; We can't do a require for the below symbol.
+ (setq semantic-lex-spp-macro-symbol-obarray
+ (semantic-lex-make-spp-table map))
+ ))))
+
+(defmethod ede-system-include-path ((this ede-project))
+ "Get the system include path used by project THIS."
+ nil)
+
+(defmethod ede-preprocessor-map ((this ede-project))
+ "Get the pre-processor map for project THIS."
+ nil)
+
+(defmethod ede-system-include-path ((this ede-target))
+ "Get the system include path used by project THIS."
+ nil)
+
+(defmethod ede-preprocessor-map ((this ede-target))
+ "Get the pre-processor map for project THIS."
+ nil)
+
+
+;;; Project-local variables
+;;
+(defun ede-make-project-local-variable (variable &optional project)
+ "Make VARIABLE project-local to PROJECT."
+ (if (not project) (setq project (ede-current-project)))
+ (if (assoc variable (oref project local-variables))
+ nil
+ (oset project local-variables (cons (list variable)
+ (oref project local-variables)))
+ (mapcar (lambda (b) (save-excursion
+ (set-buffer b)
+ (make-local-variable variable)))
+ (ede-project-buffers project))))
+
+(defmethod ede-set-project-variables ((project ede-project) &optional buffer)
+ "Set variables local to PROJECT in BUFFER."
+ (if (not buffer) (setq buffer (current-buffer)))
+ (save-excursion
+ (set-buffer buffer)
+ (mapcar (lambda (v)
+ (make-local-variable (car v))
+ ;; set it's value here?
+ (set (car v) (cdr v))
+ )
+ (oref project local-variables))))
+
+(defun ede-set (variable value &optional proj)
+ "Set the project local VARIABLE to VALUE.
+If VARIABLE is not project local, just use set."
+ (let ((p (or proj (ede-current-project)))
+ a)
+ (if (and p (setq a (assoc variable (oref p local-variables))))
+ (progn
+ (setcdr a value)
+ (mapc (lambda (b) (save-excursion
+ (set-buffer b)
+ (set variable value)))
+ (ede-project-buffers p)))
+ (set variable value))
+ (ede-commit-local-variables p))
+ value)
+
+(defmethod ede-commit-local-variables ((proj ede-project))
+ "Commit change to local variables in PROJ."
+ nil)
+
+
+;;; Accessors for more complex types where oref is inappropriate.
+;;
+(defmethod ede-target-sourcecode ((this ede-target))
+ "Return the sourcecode objects which THIS permits."
+ (let ((sc (oref this sourcetype))
+ (rs nil))
+ (while (and (listp sc) sc)
+ (setq rs (cons (symbol-value (car sc)) rs)
+ sc (cdr sc)))
+ rs))
+
+
+;;; Debugging.
+
+(defun ede-adebug-project ()
+ "Run adebug against the current ede project.
+Display the results as a debug list."
+ (interactive)
+ (require 'data-debug)
+ (when (ede-current-project)
+ (data-debug-new-buffer "*Analyzer ADEBUG*")
+ (data-debug-insert-object-slots (ede-current-project) "")
+ ))
+
+(defun ede-adebug-project-parent ()
+ "Run adebug against the current ede parent project.
+Display the results as a debug list."
+ (interactive)
+ (require 'data-debug)
+ (when (ede-parent-project)
+ (data-debug-new-buffer "*Analyzer ADEBUG*")
+ (data-debug-insert-object-slots (ede-parent-project) "")
+ ))
+
+(defun ede-adebug-project-root ()
+ "Run adebug against the current ede parent project.
+Display the results as a debug list."
+ (interactive)
+ (require 'data-debug)
+ (when (ede-toplevel)
+ (data-debug-new-buffer "*Analyzer ADEBUG*")
+ (data-debug-insert-object-slots (ede-toplevel) "")
+ ))
+
+;;; Hooks & Autoloads
+;;
+;; These let us watch various activities, and respond apropriatly.
+
+;; (add-hook 'edebug-setup-hook
+;; (lambda ()
+;; (def-edebug-spec ede-with-projectfile
+;; (form def-body))))
+
+(provide 'ede)
+
+;; Include this last because it depends on ede.
+(require 'ede/files)
+
+;; If this does not occur after the provide, we can get a recursive
+;; load. Yuck!
+(if (featurep 'speedbar)
+ (ede-speedbar-file-setup)
+ (add-hook 'speedbar-load-hook 'ede-speedbar-file-setup))
+
+;;; ede.el ends here
Index: cedet/semantic.el
===================================================================
RCS file: cedet/semantic.el
diff -N cedet/semantic.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic.el 28 Sep 2009 15:15:05 -0000 1.2
@@ -0,0 +1,1115 @@
+;;; semantic.el --- Semantic buffer evaluator.
+
+;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+;;; 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; API for providing the semantic content of a buffer.
+;;
+;; The semantic API provides an interface to a series of different parser
+;; implementations. Each parser outputs a parse tree in a similar format
+;; designed to handle typical functional and object oriented languages.
+
+(require 'cedet)
+(require 'semantic/tag)
+(require 'semantic/lex)
+
+(defvar semantic-version "2.0pre7"
+ "Current version of Semantic.")
+
+(declare-function inversion-test "inversion")
+(declare-function semanticdb-load-ebrowse-caches "semantic/db-ebrowse")
+
+(defun semantic-require-version (major minor &optional beta)
+ "Non-nil if this version of semantic does not satisfy a specific version.
+Arguments can be:
+
+ (MAJOR MINOR &optional BETA)
+
+ Values MAJOR and MINOR must be integers. BETA can be an integer, or
+excluded if a released version is required.
+
+It is assumed that if the current version is newer than that specified,
+everything passes. Exceptions occur when known incompatibilities are
+introduced."
+ (require 'inversion)
+ (inversion-test 'semantic
+ (concat major "." minor
+ (when beta (concat "beta" beta)))))
+
+(defgroup semantic nil
+ "Parser Generator and parser framework."
+ :group 'lisp)
+
+(defgroup semantic-faces nil
+ "Faces used for Semantic enabled tools."
+ :group 'semantic)
+
+(require 'semantic/fw)
+
+;;; Code:
+;;
+
+;;; Variables and Configuration
+;;
+(defvar semantic--parse-table nil
+ "Variable that defines how to parse top level items in a buffer.
+This variable is for internal use only, and its content depends on the
+external parser used.")
+(make-variable-buffer-local 'semantic--parse-table)
+(semantic-varalias-obsolete 'semantic-toplevel-bovine-table
+ 'semantic--parse-table)
+
+(defvar semantic-symbol->name-assoc-list
+ '((type . "Types")
+ (variable . "Variables")
+ (function . "Functions")
+ (include . "Dependencies")
+ (package . "Provides"))
+ "Association between symbols returned, and a string.
+The string is used to represent a group of objects of the given type.
+It is sometimes useful for a language to use a different string
+in place of the default, even though that language will still
+return a symbol. For example, Java return's includes, but the
+string can be replaced with `Imports'.")
+(make-variable-buffer-local 'semantic-symbol->name-assoc-list)
+
+(defvar semantic-symbol->name-assoc-list-for-type-parts nil
+ "Like `semantic-symbol->name-assoc-list' for type parts.
+Some tags that have children (see `semantic-tag-children-compatibility')
+will want to define the names of classes of tags differently than at
+the top level. For example, in C++, a Function may be called a
+Method. In addition, there may be new types of tags that exist only
+in classes, such as protection labels.")
+(make-variable-buffer-local 'semantic-symbol->name-assoc-list-for-type-parts)
+
+(defvar semantic-case-fold nil
+ "Value for `case-fold-search' when parsing.")
+(make-variable-buffer-local 'semantic-case-fold)
+
+(defvar semantic-expand-nonterminal nil
+ "Function to call for each nonterminal production.
+Return a list of non-terminals derived from the first argument, or nil
+if it does not need to be expanded.
+Languages with compound definitions should use this function to expand
+from one compound symbol into several. For example, in C the definition
+ int a, b;
+is easily parsed into one tag. This function should take this
+compound tag and turn it into two tags, one for A, and the other for B.")
+(make-variable-buffer-local 'semantic-expand-nonterminal)
+
+(defvar semantic--buffer-cache nil
+ "A cache of the fully parsed buffer.
+If no significant changes have been made (based on the state) then
+this is returned instead of re-parsing the buffer.
+
+ DO NOT USE THIS VARIABLE IN PROGRAMS.
+
+If you need a tag list, use `semantic-fetch-tags'. If you need the
+cached values for some reason, chances are you can, add a hook to
+`semantic-after-toplevel-cache-change-hook'.")
+(make-variable-buffer-local 'semantic--buffer-cache)
+(semantic-varalias-obsolete 'semantic-toplevel-bovine-cache
+ 'semantic--buffer-cache)
+
+(defvar semantic-unmatched-syntax-cache nil
+ "A cached copy of unmatched syntax tokens.")
+(make-variable-buffer-local 'semantic-unmatched-syntax-cache)
+
+(defvar semantic-unmatched-syntax-cache-check nil
+ "Non nil if the unmatched syntax cache is out of date.
+This is tracked with `semantic-change-function'.")
+(make-variable-buffer-local 'semantic-unmatched-syntax-cache-check)
+
+(defvar semantic-edits-are-safe nil
+ "When non-nil, modifications do not require a reparse.
+This prevents tags from being marked dirty, and it prevents top level
+edits from causing a cache check.
+Use this when writing programs that could cause a full reparse, but
+will not change the tag structure, such as adding or updating
+`top-level' comments.")
+
+(defvar semantic-unmatched-syntax-hook nil
+ "Hooks run when semantic detects syntax not matched in a grammar.
+Each individual piece of syntax (such as a symbol or punctuation
+character) is called with this hook when it doesn't match in the
+grammar, and multiple unmatched syntax elements are not grouped
+together. Each hook is called with one argument, which is a list of
+syntax tokens created by the semantic lexer. Use the functions
+`semantic-lex-token-start', `semantic-lex-token-end' and
+`semantic-lex-token-text' to get information about these tokens. The
+current buffer is the buffer these tokens are derived from.")
+
+(defvar semantic--before-fetch-tags-hook nil
+ "Hooks run before a buffer is parses for tags.
+It is called before any request for tags is made via the function
+`semantic-fetch-tags' by an application.
+If any hook returns a nil value, the cached value is returned
+immediately, even if it is empty.")
+(semantic-varalias-obsolete 'semantic-before-toplevel-bovination-hook
+ 'semantic--before-fetch-tags-hook)
+
+(defvar semantic-after-toplevel-bovinate-hook nil
+ "Hooks run after a toplevel parse.
+It is not run if the toplevel parse command is called, and buffer does
+not need to be fully reparsed.
+For language specific hooks, make sure you define this as a local hook.
+
+This hook should not be used any more.
+Use `semantic-after-toplevel-cache-change-hook' instead.")
+(make-obsolete-variable 'semantic-after-toplevel-bovinate-hook nil)
+
+(defvar semantic-after-toplevel-cache-change-hook nil
+ "Hooks run after the buffer tag list has changed.
+This list will change when a buffer is reparsed, or when the tag list
+in a buffer is cleared. It is *NOT* called if the current tag list is
+partially reparsed.
+
+Hook functions must take one argument, which is the new list of tags
+associated with this buffer.
+
+For language specific hooks, make sure you define this as a local hook.")
+
+(defvar semantic-before-toplevel-cache-flush-hook nil
+ "Hooks run before the toplevel tag cache is flushed.
+For language specific hooks, make sure you define this as a local
+hook. This hook is called before a corresponding
+`semantic-after-toplevel-cache-change-hook' which is also called
+during a flush when the cache is given a new value of nil.")
+
+(defcustom semantic-dump-parse nil
+ "When non-nil, dump parsing information."
+ :group 'semantic
+ :type 'boolean)
+
+(defvar semantic-parser-name "LL"
+ "Optional name of the parser used to parse input stream.")
+(make-variable-buffer-local 'semantic-parser-name)
+
+(defvar semantic--completion-cache nil
+ "Internal variable used by `semantic-complete-symbol'.")
+(make-variable-buffer-local 'semantic--completion-cache)
+
+;;; Parse tree state management API
+;;
+(defvar semantic-parse-tree-state 'needs-rebuild
+ "State of the current parse tree.")
+(make-variable-buffer-local 'semantic-parse-tree-state)
+
+(defmacro semantic-parse-tree-unparseable ()
+ "Indicate that the current buffer is unparseable.
+It is also true that the parse tree will need either updating or
+a rebuild. This state will be changed when the user edits the buffer."
+ `(setq semantic-parse-tree-state 'unparseable))
+
+(defmacro semantic-parse-tree-unparseable-p ()
+ "Return non-nil if the current buffer has been marked unparseable."
+ `(eq semantic-parse-tree-state 'unparseable))
+
+(defmacro semantic-parse-tree-set-needs-update ()
+ "Indicate that the current parse tree needs to be updated.
+The parse tree can be updated by `semantic-parse-changes'."
+ `(setq semantic-parse-tree-state 'needs-update))
+
+(defmacro semantic-parse-tree-needs-update-p ()
+ "Return non-nil if the current parse tree needs to be updated."
+ `(eq semantic-parse-tree-state 'needs-update))
+
+(defmacro semantic-parse-tree-set-needs-rebuild ()
+ "Indicate that the current parse tree needs to be rebuilt.
+The parse tree must be rebuilt by `semantic-parse-region'."
+ `(setq semantic-parse-tree-state 'needs-rebuild))
+
+(defmacro semantic-parse-tree-needs-rebuild-p ()
+ "Return non-nil if the current parse tree needs to be rebuilt."
+ `(eq semantic-parse-tree-state 'needs-rebuild))
+
+(defmacro semantic-parse-tree-set-up-to-date ()
+ "Indicate that the current parse tree is up to date."
+ `(setq semantic-parse-tree-state nil))
+
+(defmacro semantic-parse-tree-up-to-date-p ()
+ "Return non-nil if the current parse tree is up to date."
+ `(null semantic-parse-tree-state))
+
+;;; Interfacing with the system
+;;
+(defcustom semantic-inhibit-functions nil
+ "List of functions to call with no arguments before Semantic is setup.
+If any of these functions returns non-nil, the current buffer is not
+setup to use Semantic."
+ :group 'semantic
+ :type 'hook)
+
+(defvar semantic-init-hook nil
+ "Hook run when a buffer is initialized with a parsing table.")
+
+(defvar semantic-init-mode-hook nil
+ "Hook run when a buffer of a particular mode is initialized.")
+(make-variable-buffer-local 'semantic-init-mode-hook)
+
+(defvar semantic-init-db-hook nil
+ "Hook run when a buffer is initialized with a parsing table for DBs.
+This hook is for database functions which intend to swap in a tag table.
+This guarantees that the DB will go before other modes that require
+a parse of the buffer.")
+
+(semantic-varalias-obsolete 'semantic-init-hooks
+ 'semantic-init-hook)
+(semantic-varalias-obsolete 'semantic-init-mode-hooks
+ 'semantic-init-mode-hook)
+(semantic-varalias-obsolete 'semantic-init-db-hooks
+ 'semantic-init-db-hook)
+
+(defvar semantic-new-buffer-fcn-was-run nil
+ "Non nil after `semantic-new-buffer-fcn' has been executed.")
+(make-variable-buffer-local 'semantic-new-buffer-fcn-was-run)
+
+(defsubst semantic-active-p ()
+ "Return non-nil if the current buffer was set up for parsing."
+ semantic-new-buffer-fcn-was-run)
+
+(defsubst semantic--umatched-syntax-needs-refresh-p ()
+ "Return non-nil if the unmatched syntax cache needs a refresh.
+That is if it is dirty or if the current parse tree isn't up to date."
+ (or semantic-unmatched-syntax-cache-check
+ (not (semantic-parse-tree-up-to-date-p))))
+
+(defun semantic-new-buffer-fcn ()
+ "Setup the current buffer to use Semantic.
+If the major mode is ready for Semantic, and no
+`semantic-inhibit-functions' disabled it, the current buffer is setup
+to use Semantic, and `semantic-init-hook' is run."
+ ;; Do stuff if semantic was activated by a mode hook in this buffer,
+ ;; and not afterwards disabled.
+ (when (and semantic--parse-table
+ (not (semantic-active-p))
+ (not (run-hook-with-args-until-success
+ 'semantic-inhibit-functions)))
+ ;; Make sure that if this buffer is cloned, our tags and overlays
+ ;; don't go along for the ride.
+ (add-hook 'clone-indirect-buffer-hook 'semantic-clear-toplevel-cache
+ nil t)
+ ;; Specify that this function has done it's work. At this point
+ ;; we can consider that semantic is active in this buffer.
+ (setq semantic-new-buffer-fcn-was-run t)
+ ;; Here are some buffer local variables we can initialize ourselves
+ ;; of a mode does not choose to do so.
+ (semantic-lex-init)
+ ;; Force this buffer to have its cache refreshed.
+ (semantic-clear-toplevel-cache)
+ ;; Call DB hooks before regular init hooks
+ (run-hooks 'semantic-init-db-hook)
+ ;; Set up semantic modes
+ (run-hooks 'semantic-init-hook)
+ ;; Set up major-mode specific semantic modes
+ (run-hooks 'semantic-init-mode-hook)))
+
+(defun semantic-fetch-tags-fast ()
+ "For use in a hook. When only a partial reparse is needed, reparse."
+ (condition-case nil
+ (if (semantic-parse-tree-needs-update-p)
+ (semantic-fetch-tags))
+ (error nil))
+ semantic--buffer-cache)
+
+;;; Parsing Commands
+;;
+(eval-when-compile
+ (condition-case nil (require 'pp) (error nil)))
+
+(defvar semantic-edebug nil
+ "When non-nil, activate the interactive parsing debugger.
+Do not set this yourself. Call `semantic-debug'.")
+
+(defun semantic-elapsed-time (start end)
+ "Copied from elp.el. Was elp-elapsed-time.
+Argument START and END bound the time being calculated."
+ (+ (* (- (car end) (car start)) 65536.0)
+ (- (car (cdr end)) (car (cdr start)))
+ (/ (- (car (cdr (cdr end))) (car (cdr (cdr start)))) 1000000.0)))
+
+(defun bovinate (&optional clear)
+ "Parse the current buffer. Show output in a temp buffer.
+Optional argument CLEAR will clear the cache before parsing.
+If CLEAR is negative, it will do a full reparse, and also not display
+the output buffer."
+ (interactive "P")
+ (if clear (semantic-clear-toplevel-cache))
+ (if (eq clear '-) (setq clear -1))
+ (let* ((start (current-time))
+ (out (semantic-fetch-tags))
+ (end (current-time)))
+ (message "Retrieving tags took %.2f seconds."
+ (semantic-elapsed-time start end))
+ (when (or (null clear) (not (listp clear)))
+ (pop-to-buffer "*Parser Output*")
+ (require 'pp)
+ (erase-buffer)
+ (insert (pp-to-string out))
+ (goto-char (point-min)))))
+
+;;; Functions of the parser plug-in API
+;;
+;; Overload these functions to create new types of parsers.
+;;
+(define-overloadable-function semantic-parse-stream (stream nonterminal)
+ "Parse STREAM, starting at the first NONTERMINAL rule.
+For bovine and wisent based parsers, STREAM is from the output of
+`semantic-lex', and NONTERMINAL is a rule in the apropriate language
+specific rules file.
+The default parser table used for bovine or wisent based parsers is
+`semantic--parse-table'.
+
+Must return a list: (STREAM TAGS) where STREAM is the unused elements
+from STREAM, and TAGS is the list of semantic tags found, usually only
+one tag is returned with the exception of compound statements")
+
+(define-overloadable-function semantic-parse-changes ()
+ "Reparse changes in the current buffer.
+The list of changes are tracked as a series of overlays in the buffer.
+When overloading this function, use `semantic-changes-in-region' to
+analyze.")
+
+(define-overloadable-function semantic-parse-region
+ (start end &optional nonterminal depth returnonerror)
+ "Parse the area between START and END, and return any tags found.
+If END needs to be extended due to a lexical token being too large, it
+will be silently ignored.
+
+Optional arguments:
+NONTERMINAL is the rule to start parsing at.
+DEPTH specifies the lexical depth to decend for parser that use
+lexical analysis as their first step.
+RETURNONERROR specifies that parsing should stop on the first
+unmatched syntax encountered. When nil, parsing skips the syntax,
+adding it to the unmatched syntax cache.
+
+Must return a list of semantic tags wich have been cooked
+\(repositioned properly) but which DO NOT HAVE OVERLAYS associated
+with them. When overloading this function, use `semantic--tag-expand'
+to cook raw tags.")
+
+(defun semantic-parse-region-default
+ (start end &optional nonterminal depth returnonerror)
+ "Parse the area between START and END, and return any tags found.
+If END needs to be extended due to a lexical token being too large, it
+will be silently ignored.
+Optional arguments:
+NONTERMINAL is the rule to start parsing at if it is known.
+DEPTH specifies the lexical depth to scan.
+RETURNONERROR specifies that parsing should end when encountering
+unterminated syntax."
+ (when (or (null semantic--parse-table) (eq semantic--parse-table t))
+ ;; If there is no table, or it was set to t, then we are here by
+ ;; some other mistake. Do not throw an error deep in the parser.
+ (error "No support found to parse buffer %S" (buffer-name)))
+ (save-restriction
+ (widen)
+ (when (or (< end start) (> end (point-max)))
+ (error "Invalid parse region bounds %S, %S" start end))
+ (nreverse
+ (semantic-repeat-parse-whole-stream
+ (or (cdr (assq start semantic-lex-block-streams))
+ (semantic-lex start end depth))
+ nonterminal returnonerror))))
+
+;;; Parsing functions
+;;
+(defun semantic-set-unmatched-syntax-cache (unmatched-syntax)
+ "Set the unmatched syntax cache.
+Argument UNMATCHED-SYNTAX is the syntax to set into the cache."
+ ;; This function is not actually called by the main parse loop.
+ ;; This is intended for use by semanticdb.
+ (setq semantic-unmatched-syntax-cache unmatched-syntax
+ semantic-unmatched-syntax-cache-check nil)
+ ;; Refresh the display of unmatched syntax tokens if enabled
+ (run-hook-with-args 'semantic-unmatched-syntax-hook
+ semantic-unmatched-syntax-cache))
+
+(defun semantic-clear-unmatched-syntax-cache ()
+ "Clear the cache of unmatched syntax tokens."
+ (setq semantic-unmatched-syntax-cache nil
+ semantic-unmatched-syntax-cache-check t))
+
+(defun semantic-unmatched-syntax-tokens ()
+ "Return the list of unmatched syntax tokens."
+ ;; If the cache need refresh then do a full re-parse.
+ (if (semantic--umatched-syntax-needs-refresh-p)
+ ;; To avoid a recursive call, temporarily disable
+ ;; `semantic-unmatched-syntax-hook'.
+ (let (semantic-unmatched-syntax-hook)
+ (condition-case nil
+ (progn
+ (semantic-clear-toplevel-cache)
+ (semantic-fetch-tags))
+ (quit
+ (message "semantic-unmatched-syntax-tokens:\
+ parsing of buffer canceled"))
+ )))
+ semantic-unmatched-syntax-cache)
+
+(defun semantic-clear-toplevel-cache ()
+ "Clear the toplevel tag cache for the current buffer.
+Clearing the cache will force a complete reparse next time a tag list
+is requested."
+ (interactive)
+ (run-hooks 'semantic-before-toplevel-cache-flush-hook)
+ (setq semantic--buffer-cache nil)
+ (semantic-clear-unmatched-syntax-cache)
+ (semantic-clear-parser-warnings)
+ ;; Nuke all semantic overlays. This is faster than deleting based
+ ;; on our data structure.
+ (let ((l (semantic-overlay-lists)))
+ (mapc 'semantic-delete-overlay-maybe (car l))
+ (mapc 'semantic-delete-overlay-maybe (cdr l))
+ )
+ (semantic-parse-tree-set-needs-rebuild)
+ ;; Remove this hook which tracks if a buffer is up to date or not.
+ (remove-hook 'after-change-functions 'semantic-change-function t)
+ ;; Old model. Delete someday.
+ ;;(run-hooks 'semantic-after-toplevel-bovinate-hook)
+
+ (run-hook-with-args 'semantic-after-toplevel-cache-change-hook
+ semantic--buffer-cache)
+
+ (setq semantic--completion-cache nil))
+
+(defvar semantic-bovinate-nonterminal-check-obarray)
+
+(defun semantic--set-buffer-cache (tagtable)
+ "Set the toplevel cache cache to TAGTABLE."
+ (setq semantic--buffer-cache tagtable
+ semantic-unmatched-syntax-cache-check nil)
+ ;; This is specific to the bovine parser.
+ (set (make-local-variable 'semantic-bovinate-nonterminal-check-obarray)
+ nil)
+ (semantic-parse-tree-set-up-to-date)
+ (semantic-make-local-hook 'after-change-functions)
+ (add-hook 'after-change-functions 'semantic-change-function nil t)
+ (run-hook-with-args 'semantic-after-toplevel-cache-change-hook
+ semantic--buffer-cache)
+ (setq semantic--completion-cache nil)
+ ;; Refresh the display of unmatched syntax tokens if enabled
+ (run-hook-with-args 'semantic-unmatched-syntax-hook
+ semantic-unmatched-syntax-cache)
+ ;; Old Semantic 1.3 hook API. Maybe useful forever?
+ (run-hooks 'semantic-after-toplevel-bovinate-hook)
+ )
+
+(defvar semantic-working-type 'percent
+ "*The type of working message to use when parsing.
+'percent means we are doing a linear parse through the buffer.
+'dynamic means we are reparsing specific tags.")
+(semantic-varalias-obsolete 'semantic-bovination-working-type
+ 'semantic-working-type)
+
+(defvar semantic-minimum-working-buffer-size (* 1024 5)
+ "*The minimum size of a buffer before working messages are displayed.
+Buffers smaller than will parse silently.
+Bufferse larger than this will display the working progress bar.")
+
+(defsubst semantic-parser-working-message (&optional arg)
+ "Return the message string displayed while parsing.
+If optional argument ARG is non-nil it is appended to the message
+string."
+ (concat "Parsing"
+ (if arg (format " %s" arg))
+ (if semantic-parser-name (format " (%s)" semantic-parser-name))
+ "..."))
+
+;;; Application Parser Entry Points
+;;
+;; The best way to call the parser from programs is via
+;; `semantic-fetch-tags'. This, in turn, uses other internal
+;; API functions which plug-in parsers can take advantage of.
+
+(defun semantic-fetch-tags ()
+ "Fetch semantic tags from the current buffer.
+If the buffer cache is up to date, return that.
+If the buffer cache is out of date, attempt an incremental reparse.
+If the buffer has not been parsed before, or if the incremental reparse
+fails, then parse the entire buffer.
+If a lexcial error had been previously discovered and the buffer
+was marked unparseable, then do nothing, and return the cache."
+ (and
+ ;; Is this a semantic enabled buffer?
+ (semantic-active-p)
+ ;; Application hooks say the buffer is safe for parsing
+ (run-hook-with-args-until-failure
+ 'semantic-before-toplevel-bovination-hook)
+ (run-hook-with-args-until-failure
+ 'semantic--before-fetch-tags-hook)
+ ;; If the buffer was previously marked unparseable,
+ ;; then don't waste our time.
+ (not (semantic-parse-tree-unparseable-p))
+ ;; The parse tree actually needs to be refreshed
+ (not (semantic-parse-tree-up-to-date-p))
+ ;; So do it!
+ (let* ((gc-cons-threshold (max gc-cons-threshold 10000000))
+ (semantic-lex-block-streams nil)
+ (res nil))
+ (garbage-collect)
+ (cond
+
+;;;; Try the incremental parser to do a fast update.
+ ((semantic-parse-tree-needs-update-p)
+ (setq res (semantic-parse-changes))
+ (if (semantic-parse-tree-needs-rebuild-p)
+ ;; If the partial reparse fails, jump to a full reparse.
+ (semantic-fetch-tags)
+ ;; Clear the cache of unmatched syntax tokens
+ ;;
+ ;; NOTE TO SELF:
+ ;;
+ ;; Move this into the incremental parser. This is a bug.
+ ;;
+ (semantic-clear-unmatched-syntax-cache)
+ (run-hook-with-args ;; Let hooks know the updated tags
+ 'semantic-after-partial-cache-change-hook res))
+ (setq semantic--completion-cache nil))
+
+;;;; Parse the whole system.
+ ((semantic-parse-tree-needs-rebuild-p)
+ ;; Use Emacs' built-in progress-reporter
+ (let ((semantic--progress-reporter
+ (and (>= (point-max) semantic-minimum-working-buffer-size)
+ (eq semantic-working-type 'percent)
+ (make-progress-reporter
+ (semantic-parser-working-message (buffer-name))
+ 0 100))))
+ (setq res (semantic-parse-region (point-min) (point-max)))
+ (if semantic--progress-reporter
+ (progress-reporter-done semantic--progress-reporter)))
+
+ ;; Clear the caches when we see there were no errors.
+ ;; But preserve the unmatched syntax cache and warnings!
+ (let (semantic-unmatched-syntax-cache
+ semantic-unmatched-syntax-cache-check
+ semantic-parser-warnings)
+ (semantic-clear-toplevel-cache))
+ ;; Set up the new overlays
+ (semantic--tag-link-list-to-buffer res)
+ ;; Set up the cache with the new results
+ (semantic--set-buffer-cache res)
+ ))))
+
+ ;; Always return the current parse tree.
+ semantic--buffer-cache)
+
+(defun semantic-refresh-tags-safe ()
+ "Refreshes the current buffer's tags safely.
+
+Return non-nil if the refresh was successful.
+Return nil if there is some sort of syntax error preventing a reparse.
+
+Does nothing if the current buffer doesn't need reparsing."
+
+ ;; These checks actually occur in `semantic-fetch-tags', but if we
+ ;; do them here, then all the bovination hooks are not run, and
+ ;; we save lots of time.
+ (cond
+ ;; If the buffer was previously marked unparseable,
+ ;; then don't waste our time.
+ ((semantic-parse-tree-unparseable-p)
+ nil)
+ ;; The parse tree is already ok.
+ ((semantic-parse-tree-up-to-date-p)
+ t)
+ (t
+ (let* ((inhibit-quit nil)
+ (lexically-safe t)
+ )
+
+ (unwind-protect
+ ;; Perform the parsing.
+ (progn
+ (when (semantic-lex-catch-errors safe-refresh
+ (save-excursion (semantic-fetch-tags))
+ nil)
+ ;; If we are here, it is because the lexical step failed,
+ ;; proably due to unterminated lists or something like that.
+
+ ;; We do nothing, and just wait for the next idle timer
+ ;; to go off. In the meantime, remember this, and make sure
+ ;; no other idle services can get executed.
+ (setq lexically-safe nil))
+ )
+ )
+ ;; Return if we are lexically safe
+ lexically-safe))))
+
+(defun semantic-bovinate-toplevel (&optional ignored)
+ "Backward Compatibility Function."
+ (semantic-fetch-tags))
+(make-obsolete 'semantic-bovinate-toplevel 'semantic-fetch-tags)
+
+;; Another approach is to let Emacs call the parser on idle time, when
+;; needed, use `semantic-fetch-available-tags' to only retrieve
+;; available tags, and setup the `semantic-after-*-hook' hooks to
+;; synchronize with new tags when they become available.
+
+(defsubst semantic-fetch-available-tags ()
+ "Fetch available semantic tags from the current buffer.
+That is, return tags currently in the cache without parsing the
+current buffer.
+Parse operations happen asynchronously when needed on Emacs idle time.
+Use the `semantic-after-toplevel-cache-change-hook' and
+`semantic-after-partial-cache-change-hook' hooks to synchronize with
+new tags when they become available."
+ semantic--buffer-cache)
+
+;;; Iterative parser helper function
+;;
+;; Iterative parsers are better than rule-based iterative functions
+;; in that they can handle obscure errors more cleanly.
+;;
+;; `semantic-repeat-parse-whole-stream' abstracts this action for
+;; other parser centric routines.
+;;
+(defun semantic-repeat-parse-whole-stream
+ (stream nonterm &optional returnonerror)
+ "Iteratively parse the entire stream STREAM starting with NONTERM.
+Optional argument RETURNONERROR indicates that the parser should exit
+with the current results on a parse error.
+This function returns semantic tags without overlays."
+ (let ((result nil)
+ (case-fold-search semantic-case-fold)
+ nontermsym tag)
+ (while stream
+ (setq nontermsym (semantic-parse-stream stream nonterm)
+ tag (car (cdr nontermsym)))
+ (if (not nontermsym)
+ (error "Parse error @ %d" (car (cdr (car stream)))))
+ (if (eq (car nontermsym) stream)
+ (error "Parser error: Infinite loop?"))
+ (if tag
+ (if (car tag)
+ (setq tag (mapcar
+ #'(lambda (tag)
+ ;; Set the 'reparse-symbol property to
+ ;; NONTERM unless it was already setup
+ ;; by a tag expander
+ (or (semantic--tag-get-property
+ tag 'reparse-symbol)
+ (semantic--tag-put-property
+ tag 'reparse-symbol nonterm))
+ tag)
+ (semantic--tag-expand tag))
+ result (append tag result))
+ ;; No error in this case, a purposeful nil means don't
+ ;; store anything.
+ )
+ (if returnonerror
+ (setq stream nil)
+ ;; The current item in the stream didn't match, so add it to
+ ;; the list of syntax items which didn't match.
+ (setq semantic-unmatched-syntax-cache
+ (cons (car stream) semantic-unmatched-syntax-cache))
+ ))
+ ;; Designated to ignore.
+ (setq stream (car nontermsym))
+ (if stream
+ ;; Use Emacs' built-in progress reporter:
+ (and (boundp 'semantic--progress-reporter)
+ semantic--progress-reporter
+ (eq semantic-working-type 'percent)
+ (progress-reporter-update
+ semantic--progress-reporter
+ (/ (* 100 (semantic-lex-token-start (car stream)))
+ (point-max))))))
+ result))
+
+;;; Parsing Warnings:
+;;
+;; Parsing a buffer may result in non-critical things that we should
+;; alert the user to without interrupting the normal flow.
+;;
+;; Any parser can use this API to provide a list of warnings during a
+;; parse which a user may want to investigate.
+(defvar semantic-parser-warnings nil
+ "A list of parser warnings since the last full reparse.")
+(make-variable-buffer-local 'semantic-parser-warnings)
+
+(defun semantic-clear-parser-warnings ()
+ "Clear the current list of parser warnings for this buffer."
+ (setq semantic-parser-warnings nil))
+
+(defun semantic-push-parser-warning (warning start end)
+ "Add a parser WARNING that covers text from START to END."
+ (setq semantic-parser-warnings
+ (cons (cons warning (cons start end))
+ semantic-parser-warnings)))
+
+(defun semantic-dump-parser-warnings ()
+ "Dump any parser warnings."
+ (interactive)
+ (if semantic-parser-warnings
+ (let ((pw semantic-parser-warnings))
+ (pop-to-buffer "*Parser Warnings*")
+ (require 'pp)
+ (erase-buffer)
+ (insert (pp-to-string pw))
+ (goto-char (point-min)))
+ (message "No parser warnings.")))
+
+
+
+;;; Compatibility:
+;;
+;; Semantic 1.x parser action helper functions, used by some parsers.
+;; Please move away from these functions, and try using semantic 2.x
+;; interfaces instead.
+;;
+(defsubst semantic-bovinate-region-until-error
+ (start end nonterm &optional depth)
+ "NOTE: Use `semantic-parse-region' instead.
+
+Bovinate between START and END starting with NONTERM.
+Optional DEPTH specifies how many levels of parenthesis to enter.
+This command will parse until an error is encountered, and return
+the list of everything found until that moment.
+This is meant for finding variable definitions at the beginning of
+code blocks in methods. If `bovine-inner-scope' can also support
+commands, use `semantic-bovinate-from-nonterminal-full'."
+ (semantic-parse-region start end nonterm depth t))
+(make-obsolete 'semantic-bovinate-region-until-error
+ 'semantic-parse-region)
+
+(defsubst semantic-bovinate-from-nonterminal
+ (start end nonterm &optional depth length)
+ "Bovinate from within a nonterminal lambda from START to END.
+Argument NONTERM is the nonterminal symbol to start with.
+Optional argument DEPTH is the depth of lists to dive into. When used
+in a `lambda' of a MATCH-LIST, there is no need to include a START and
+END part.
+Optional argument LENGTH specifies we are only interested in LENGTH
+tokens."
+ (car-safe (cdr (semantic-parse-stream
+ (semantic-lex start end (or depth 1) length)
+ nonterm))))
+
+(defsubst semantic-bovinate-from-nonterminal-full
+ (start end nonterm &optional depth)
+ "NOTE: Use `semantic-parse-region' instead.
+
+Bovinate from within a nonterminal lambda from START to END.
+Iterates until all the space between START and END is exhausted.
+Argument NONTERM is the nonterminal symbol to start with.
+If NONTERM is nil, use `bovine-block-toplevel'.
+Optional argument DEPTH is the depth of lists to dive into.
+When used in a `lambda' of a MATCH-LIST, there is no need to include
+a START and END part."
+ (semantic-parse-region start end nonterm (or depth 1)))
+(make-obsolete 'semantic-bovinate-from-nonterminal-full
+ 'semantic-parse-region)
+
+;;; User interface
+
+(defun semantic-force-refresh ()
+ "Force a full refresh of the current buffer's tags.
+Throw away all the old tags, and recreate the tag database."
+ (interactive)
+ (semantic-clear-toplevel-cache)
+ (semantic-fetch-tags)
+ (message "Buffer reparsed."))
+
+(defvar semantic-mode-map
+ (let ((map (make-sparse-keymap)))
+ ;; Key bindings:
+ ;; (define-key km "f" 'senator-search-set-tag-class-filter)
+ ;; (define-key km "i" 'senator-isearch-toggle-semantic-mode)
+ (define-key map "\C-c,j" 'semantic-complete-jump-local)
+ (define-key map "\C-c,J" 'semantic-complete-jump)
+ (define-key map "\C-c,g" 'semantic-symref-symbol)
+ (define-key map "\C-c,G" 'semantic-symref)
+ (define-key map "\C-c,p" 'senator-previous-tag)
+ (define-key map "\C-c,n" 'senator-next-tag)
+ (define-key map "\C-c,u" 'senator-go-to-up-reference)
+ (define-key map "\C-c, " 'semantic-complete-analyze-inline)
+ (define-key map "\C-c,\C-w" 'senator-kill-tag)
+ (define-key map "\C-c,\M-w" 'senator-copy-tag)
+ (define-key map "\C-c,\C-y" 'senator-yank-tag)
+ (define-key map "\C-c,r" 'senator-copy-tag-to-register)
+ (define-key map [?\C-c ?, up] 'senator-transpose-tags-up)
+ (define-key map [?\C-c ?, down] 'senator-transpose-tags-down)
+ (define-key map "\C-c,l" 'semantic-analyze-possible-completions)
+ ;; This hack avoids showing the CEDET menu twice if ede-minor-mode
+ ;; and Semantic are both enabled. Is there a better way?
+ (define-key map [menu-bar cedet-menu]
+ (list 'menu-item "Development" cedet-menu-map
+ :enable (quote (not (bound-and-true-p global-ede-mode)))))
+ ;; (define-key km "-" 'senator-fold-tag)
+ ;; (define-key km "+" 'senator-unfold-tag)
+ map))
+
+;; Activate the Semantic items in cedet-menu-map
+(let ((navigate-menu (make-sparse-keymap "Navigate Tags"))
+ (edit-menu (make-sparse-keymap "Edit Tags")))
+
+ ;; Edit Tags submenu:
+ (define-key edit-menu [semantic-analyze-possible-completions]
+ '(menu-item "List Completions" semantic-analyze-possible-completions
+ :help "Display a list of completions for the tag at point"))
+ (define-key edit-menu [semantic-complete-analyze-inline]
+ '(menu-item "Complete Tag Inline" semantic-complete-analyze-inline
+ :help "Display inline completion for the tag at point"))
+ (define-key edit-menu [semantic-completion-separator]
+ '("--"))
+ (define-key edit-menu [senator-transpose-tags-down]
+ '(menu-item "Transpose Tags Down" senator-transpose-tags-down
+ :active (semantic-current-tag)
+ :help "Transpose the current tag and the next tag"))
+ (define-key edit-menu [senator-transpose-tags-up]
+ '(menu-item "Transpose Tags Up" senator-transpose-tags-up
+ :active (semantic-current-tag)
+ :help "Transpose the current tag and the previous tag"))
+ (define-key edit-menu [semantic-edit-separator]
+ '("--"))
+ (define-key edit-menu [senator-yank-tag]
+ '(menu-item "Yank Tag" senator-yank-tag
+ :active (not (ring-empty-p senator-tag-ring))
+ :help "Yank the head of the tag ring into the buffer"))
+ (define-key edit-menu [senator-copy-tag-to-register]
+ '(menu-item "Copy Tag To Register" senator-copy-tag-to-register
+ :active (semantic-current-tag)
+ :help "Yank the head of the tag ring into the buffer"))
+ (define-key edit-menu [senator-copy-tag]
+ '(menu-item "Copy Tag" senator-copy-tag
+ :active (semantic-current-tag)
+ :help "Copy the current tag to the tag ring"))
+ (define-key edit-menu [senator-kill-tag]
+ '(menu-item "Kill Tag" senator-kill-tag
+ :active (semantic-current-tag)
+ :help "Kill the current tag, and copy it to the tag ring"))
+
+ ;; Navigate Tags submenu:
+ (define-key navigate-menu [senator-narrow-to-defun]
+ '(menu-item "Narrow to Tag" senator-narrow-to-defun
+ :active (semantic-current-tag)
+ :help "Narrow the buffer to the bounds of the current tag"))
+ (define-key navigate-menu [semantic-narrow-to-defun-separator]
+ '("--"))
+ (define-key navigate-menu [semantic-symref-symbol]
+ '(menu-item "Find Tag References..." semantic-symref-symbol
+ :help "Read a tag and list the references to it"))
+ (define-key navigate-menu [semantic-complete-jump]
+ '(menu-item "Find Tag Globally..." semantic-complete-jump
+ :help "Read a tag name and find it in the current project"))
+ (define-key navigate-menu [semantic-complete-jump-local]
+ '(menu-item "Find Tag in This Buffer..." semantic-complete-jump-local
+ :help "Read a tag name and find it in this buffer"))
+ (define-key navigate-menu [semantic-navigation-separator]
+ '("--"))
+ (define-key navigate-menu [senator-go-to-up-reference]
+ '(menu-item "Parent Tag" senator-go-to-up-reference
+ :help "Navigate up one reference by tag."))
+ (define-key navigate-menu [senator-next-tag]
+ '(menu-item "Next Tag" senator-next-tag
+ :help "Go to the next tag"))
+ (define-key navigate-menu [senator-previous-tag]
+ '(menu-item "Previous Tag" senator-previous-tag
+ :help "Go to the previous tag"))
+
+ ;; Top level menu items:
+ (define-key cedet-menu-map [semantic-force-refresh]
+ '(menu-item "Reparse Buffer" semantic-force-refresh
+ :help "Force a full reparse of the current buffer."
+ :visible semantic-mode))
+ (define-key cedet-menu-map [semantic-edit-menu]
+ `(menu-item "Edit Tags" ,edit-menu
+ :visible semantic-mode))
+ (define-key cedet-menu-map [navigate-menu]
+ `(menu-item "Navigate Tags" ,navigate-menu
+ :visible semantic-mode))
+ (define-key cedet-menu-map [semantic-options-separator]
+ '("--"))
+ (define-key cedet-menu-map [global-semantic-highlight-func-mode]
+ '(menu-item "Highlight Current Function"
global-semantic-highlight-func-mode
+ :help "Highlight the tag at point"
+ :visible semantic-mode
+ :button (:toggle . global-semantic-highlight-func-mode)))
+ (define-key cedet-menu-map [global-semantic-decoration-mode]
+ '(menu-item "Decorate Tags" global-semantic-decoration-mode
+ :help "Decorate tags based on tag attributes"
+ :visible semantic-mode
+ :button (:toggle . (bound-and-true-p
+ global-semantic-decoration-mode))))
+ (define-key cedet-menu-map [global-semantic-idle-completions-mode]
+ '(menu-item "Show Tag Completions" global-semantic-idle-completions-mode
+ :help "Show tag completions when idle"
+ :visible semantic-mode
+ :button (:toggle . global-semantic-idle-completions-mode)))
+ (define-key cedet-menu-map [global-semantic-idle-summary-mode]
+ '(menu-item "Show Tag Summaries" global-semantic-idle-summary-mode
+ :help "Show tag summaries when idle"
+ :visible semantic-mode
+ :button (:toggle . global-semantic-idle-summary-mode)))
+ (define-key cedet-menu-map [global-semanticdb-minor-mode]
+ '(menu-item "Semantic Database" global-semanticdb-minor-mode
+ :help "Store tag information in a database"
+ :visible semantic-mode
+ :button (:toggle . global-semanticdb-minor-mode)))
+ (define-key cedet-menu-map [global-semantic-idle-scheduler-mode]
+ '(menu-item "Reparse When Idle" global-semantic-idle-scheduler-mode
+ :help "Keep a buffer's parse tree up to date when idle"
+ :visible semantic-mode
+ :button (:toggle . global-semantic-idle-scheduler-mode)))
+ (define-key cedet-menu-map [ede-menu-separator] 'undefined)
+ (define-key cedet-menu-map [cedet-menu-separator] 'undefined)
+ (define-key cedet-menu-map [semantic-menu-separator] '("--")))
+
+;; The `semantic-mode' command, in conjuction with the
+;; `semantic-default-submodes' variable, toggles Semantic's various
+;; auxilliary minor modes.
+
+(defvar semantic-load-system-cache-loaded nil
+ "Non nil when the Semantic system caches have been loaded.
+Prevent this load system from loading files in twice.")
+
+(defconst semantic-submode-list
+ '(global-semantic-highlight-func-mode
+ global-semantic-decoration-mode
+ global-semantic-stickyfunc-mode
+ global-semantic-idle-completions-mode
+ global-semantic-idle-scheduler-mode
+ global-semanticdb-minor-mode
+ global-semantic-idle-summary-mode
+ global-semantic-mru-bookmark-mode)
+ "List of auxilliary minor modes in the Semantic package.")
+
+;;;###autoload
+(defcustom semantic-default-submodes
+ '(global-semantic-idle-scheduler-mode global-semanticdb-minor-mode)
+ "List of auxilliary Semantic minor modes enabled by `semantic-mode'.
+The possible elements of this list include the following:
+
+ `semantic-highlight-func-mode' - Highlight the current tag.
+ `semantic-decoration-mode' - Decorate tags based on various attributes.
+ `semantic-stickyfunc-mode' - Track current function in the header-line.
+ `semantic-idle-completions-mode' - Provide smart symbol completion
+ automatically when idle.
+ `semantic-idle-scheduler-mode' - Keep a buffer's parse tree up to date.
+ `semanticdb-minor-mode' - Store tags when a buffer is not in memory.
+ `semantic-idle-summary-mode' - Show a summary for the code at point.
+ `semantic-mru-bookmark-mode' - Provide `switch-to-buffer'-like
+ keybinding for tag names."
+ :group 'semantic
+ :type `(set ,@(mapcar (lambda (c) (list 'const c))
+ semantic-submode-list)))
+
+;;;###autoload
+(define-minor-mode semantic-mode
+ "Toggle Semantic mode.
+With ARG, turn Semantic mode on if ARG is positive, off otherwise.
+
+In Semantic mode, Emacs parses the buffers you visit for their
+semantic content. This information is used by a variety of
+auxilliary minor modes, listed in `semantic-default-submodes';
+all the minor modes in this list are also enabled when you enable
+Semantic mode.
+
+\\{semantic-mode-map}"
+ :global t
+ :group 'semantic
+ (if semantic-mode
+ ;; Turn on Semantic mode
+ (progn
+ ;; Enable all the global auxilliary minor modes in
+ ;; `semantic-submode-list'.
+ (dolist (mode semantic-submode-list)
+ (if (memq mode semantic-default-submodes)
+ (funcall mode 1)))
+ (unless semantic-load-system-cache-loaded
+ (setq semantic-load-system-cache-loaded t)
+ (when (and (boundp 'semanticdb-default-system-save-directory)
+ (stringp semanticdb-default-system-save-directory)
+ (file-exists-p semanticdb-default-system-save-directory))
+ (require 'semantic/db-ebrowse)
+ (semanticdb-load-ebrowse-caches)))
+ (add-hook 'mode-local-init-hook 'semantic-new-buffer-fcn)
+ ;; Add mode-local hooks
+ (add-hook 'javascript-mode-hook 'wisent-javascript-setup-parser)
+ (add-hook 'ecmascript-mode-hook 'wisent-javascript-setup-parser)
+ (add-hook 'java-mode-hook 'wisent-java-default-setup)
+ (add-hook 'scheme-mode-hook 'semantic-default-scheme-setup)
+ (add-hook 'makefile-mode-hook 'semantic-default-make-setup)
+ (add-hook 'c-mode-hook 'semantic-default-c-setup)
+ (add-hook 'c++-mode-hook 'semantic-default-c-setup)
+ (add-hook 'html-mode-hook 'semantic-default-html-setup))
+ ;; Disable all Semantic features.
+ (remove-hook 'mode-local-init-hook 'semantic-new-buffer-fcn)
+ (remove-hook 'javascript-mode-hook 'wisent-javascript-setup-parser)
+ (remove-hook 'ecmascript-mode-hook 'wisent-javascript-setup-parser)
+ (remove-hook 'java-mode-hook 'wisent-java-default-setup)
+ (remove-hook 'scheme-mode-hook 'semantic-default-scheme-setup)
+ (remove-hook 'makefile-mode-hook 'semantic-default-make-setup)
+ (remove-hook 'c-mode-hook 'semantic-default-c-setup)
+ (remove-hook 'c++-mode-hook 'semantic-default-c-setup)
+ (remove-hook 'html-mode-hook 'semantic-default-html-setup)
+
+ ;; FIXME: handle semanticdb-load-ebrowse-caches
+ (dolist (mode semantic-submode-list)
+ (if (and (boundp mode) (eval mode))
+ (funcall mode -1)))))
+
+;;; Autoload some functions that are not in semantic/loaddefs
+
+(autoload 'global-semantic-idle-completions-mode "semantic/idle"
+ "Toggle global use of `semantic-idle-completions-mode'.
+If ARG is positive, enable, if it is negative, disable.
+If ARG is nil, then toggle." t nil)
+
+(autoload 'semantic-idle-completions-mode "semantic/idle"
+ "Display a list of possible completions in a tooltip.
+
+This is a minor mode which performs actions during idle time.
+With prefix argument ARG, turn on if positive, otherwise off. The
+minor mode can be turned on only if semantic feature is available and
+the current buffer was set up for parsing. Return non-nil if the
+minor mode is enabled." t nil)
+
+(autoload 'global-semantic-idle-summary-mode "semantic/idle"
+ "Toggle global use of `semantic-idle-summary-mode'.
+If ARG is positive, enable, if it is negative, disable.
+If ARG is nil, then toggle." t nil)
+
+(autoload 'semantic-idle-summary-mode "semantic/idle"
+ "Display a tag summary of the lexical token under the cursor.
+Call `semantic-idle-summary-current-symbol-info' for getting the
+current tag to display information.
+
+This is a minor mode which performs actions during idle time.
+With prefix argument ARG, turn on if positive, otherwise off. The
+minor mode can be turned on only if semantic feature is available and
+the current buffer was set up for parsing. Return non-nil if the
+minor mode is enabled." t nil)
+
+(provide 'semantic)
+
+;; Semantic-util is a part of the semantic API. Include it last
+;; because it depends on semantic.
+(require 'semantic/util)
+
+;; (require 'semantic/load)
+
+;;; semantic.el ends here
Index: cedet/srecode.el
===================================================================
RCS file: cedet/srecode.el
diff -N cedet/srecode.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/srecode.el 28 Sep 2009 15:15:06 -0000 1.2
@@ -0,0 +1,53 @@
+;;; srecode.el --- Semantic buffer evaluator.
+
+;;; Copyright (C) 2005, 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: codegeneration
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Semantic does the job of converting source code into useful tag
+;; information. The set of `semantic-format-tag' functions has one
+;; function that will create a prototype of a tag, which has severe
+;; issues of complexity (in the format tag file itself) and inaccuracy
+;; (for the purpose of C++ code.)
+;;
+;; Contemplation of the simplistic problem within the scope of
+;; semantic showed that the solution was more complex than could
+;; possibly be handled in semantic-format.el. Semantic Recode, or
+;; srecode is a rich API for generating code out of semantic tags, or
+;; recoding the tags.
+;;
+;; See the srecode manual for specific details.
+
+(require 'eieio)
+(require 'mode-local)
+(require 'srecode/loaddefs)
+
+(defvar srecode-version "1.0pre7"
+ "Current version of the Semantic Recoder.")
+
+;;; Code:
+(defgroup srecode nil
+ "Semantic Recoder."
+ :group 'tools)
+
+(provide 'srecode)
+
+;;; srecode.el ends here
Index: cedet/ede/.cvsignore
===================================================================
RCS file: cedet/ede/.cvsignore
diff -N cedet/ede/.cvsignore
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/.cvsignore 28 Sep 2009 15:15:06 -0000 1.2
@@ -0,0 +1 @@
+loaddefs.el
Index: cedet/ede/autoconf-edit.el
===================================================================
RCS file: cedet/ede/autoconf-edit.el
diff -N cedet/ede/autoconf-edit.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/autoconf-edit.el 28 Sep 2009 15:15:06 -0000 1.2
@@ -0,0 +1,424 @@
+;;; ede/autoconf-edit.el --- Keymap for autoconf
+
+;;; Copyright (C) 1998, 1999, 2000, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: project
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Autoconf editing and modification support, and compatibility layer
+;; for Emacses w/out autoconf mode built in.
+
+;;; Code:
+(require 'autoconf)
+
+(defvar autoconf-new-automake-string
+ "dnl Process this file with autoconf to produce a configure script
+
+AC_INIT(%s)
+AM_INIT_AUTOMAKE([%s], 0)
+AM_CONFIG_HEADER(config.h)
+
+dnl End the configure script.
+AC_OUTPUT(Makefile, [date > stamp-h] )\n"
+ "This string is used to initialize a new configure.in.
+The default is designed to be used with automake.
+The first %s will be filled with the test file.
+The second %s will be filled with the program name.")
+
+(defun autoconf-new-program (rootdir program testfile)
+ "Initialize a new configure.in in ROOTDIR for PROGRAM using TESTFILE.
+ROOTDIR is the root directory of a given autoconf controlled project.
+PROGRAM is the program to be configured.
+TESTFILE is the file used with AC_INIT.
+configure the initial configure script using `autoconf-new-automake-string'"
+ (interactive "DRoot Dir: \nsProgram: \nsTest File: ")
+ (if (bufferp rootdir)
+ (set-buffer rootdir)
+ (let ((cf1 (expand-file-name "configure.in" rootdir))
+ (cf2 (expand-file-name "configure.ac" rootdir)))
+ (if (and (or (file-exists-p cf1) (file-exists-p cf2))
+ (not (y-or-n-p (format "File %s exists. Start Over? "
+ (if (file-exists-p cf1)
+ cf1 cf2)
+ ))))
+ (error "Quit"))
+ (find-file cf2)))
+ ;; Note, we only ask about overwrite if a string/path is specified.
+ (erase-buffer)
+ (insert (format autoconf-new-automake-string testfile program)))
+
+(defvar autoconf-preferred-macro-order
+ '("AC_INIT"
+ "AM_INIT_AUTOMAKE"
+ "AM_CONFIG_HEADER"
+ ;; Arg parsing
+ "AC_ARG_ENABLE"
+ "AC_ARG_WITH"
+ ;; Programs
+ "AC_PROG_MAKE_SET"
+ "AC_PROG_AWK"
+ "AC_PROG_CC"
+ "AC_PROG_CC_C_O"
+ "AC_PROG_CPP"
+ "AC_PROG_CXX"
+ "AC_PROG_CXXCPP"
+ "AC_ISC_POSIX"
+ "AC_PROG_F77"
+ "AC_PROG_GCC_TRADITIONAL"
+ "AC_PROG_INSTALL"
+ "AC_PROG_LEX"
+ "AC_PROG_LN_S"
+ "AC_PROG_RANLIB"
+ "AC_PROG_YACC"
+ "AC_CHECK_PROG"
+ "AC_CHECK_PROGS"
+ "AC_PROG_LIBTOOL"
+ ;; Libraries
+ "AC_CHECK_LIB"
+ "AC_PATH_XTRA"
+ ;; Headers
+ "AC_HEADER_STDC"
+ "AC_HEADER_SYS_WAIT"
+ "AC_HEADER_TIME"
+ "AC_HEADERS"
+ ;; Typedefs, structures
+ "AC_TYPE_PID_T"
+ "AC_TYPE_SIGNAL"
+ "AC_TYPE_UID_T"
+ "AC_STRUCT_TM"
+ ;; Compiler characteristics
+ "AC_CHECK_SIZEOF"
+ "AC_C_CONST"
+ ;; Library functions
+ "AC_CHECK_FUNCS"
+ "AC_TRY_LINK"
+ ;; System Services
+ ;; Other
+ "AM_PATH_LISPDIR"
+ "AM_INIT_GUILE_MODULE"
+ ;; AC_OUTPUT is always last
+ "AC_OUTPUT"
+ )
+ "List of macros in the order that they prefer to occur in.
+This helps when inserting a macro which doesn't yet exist
+by positioning it near other macros which may exist.
+From the autoconf manual:
+ `AC_INIT(FILE)'
+ checks for programs
+ checks for libraries
+ checks for header files
+ checks for typedefs
+ checks for structures
+ checks for compiler characteristics
+ checks for library functions
+ checks for system services
+ `AC_OUTPUT([FILE...])'")
+
+(defvar autoconf-multiple-macros
+ '("AC_ARG_ENABLE"
+ "AC_ARG_WITH"
+ "AC_CHECK_PROGS"
+ "AC_CHECK_LIB"
+ "AC_CHECK_SIZEOF"
+ "AC_TRY_LINK"
+ )
+ "Macros which appear multiple times.")
+
+(defvar autoconf-multiple-multiple-macros
+ '("AC_HEADERS" "AC_CHECK_FUNCS")
+ "Macros which appear multiple times, and perform multiple queries.")
+
+(defun autoconf-in-macro (macro)
+ "Non-nil if point is in a macro of type MACRO."
+ (save-excursion
+ (beginning-of-line)
+ (looking-at (concat "\\(A[CM]_" macro "\\|" macro "\\)"))))
+
+(defun autoconf-find-last-macro (macro)
+ "Move to the last occurance of MACRO in FILE, and return that point.
+The last macro is usually the one in which we would like to insert more
+items such as CHECK_HEADERS."
+ (let ((op (point)))
+ (goto-char (point-max))
+ (if (re-search-backward (concat "^" (regexp-quote macro)
"\\s-*\\((\\|$\\)") nil t)
+ (progn
+ (beginning-of-line)
+ (point))
+ (goto-char op)
+ nil)))
+
+(defun autoconf-parameter-strip (param)
+ "Strip the parameter PARAM of whitespace and misc characters."
+ (when (string-match "^\\s-*\\[?\\s-*" param)
+ (setq param (substring param (match-end 0))))
+ (when (string-match "\\s-*\\]?\\s-*$" param)
+ (setq param (substring param 0 (match-beginning 0))))
+ param)
+
+(defun autoconf-parameters-for-macro (macro)
+ "Retrieve the parameters to MACRO.
+Returns a list of the arguments passed into MACRO as strings."
+ (save-excursion
+ (when (autoconf-find-last-macro macro)
+ (forward-sexp 1)
+ (mapcar
+ #'autoconf-parameter-strip
+ (when (looking-at "(")
+ (let* ((start (+ (point) 1))
+ (end (save-excursion
+ (forward-sexp 1)
+ (- (point) 1)))
+ (ans (buffer-substring-no-properties start end)))
+ (split-string ans "," t)))))))
+
+(defun autoconf-position-for-macro (macro)
+ "Position the cursor where a new MACRO could be inserted.
+This will appear at the BEGINNING of the macro MACRO should appear AFTER.
+This is to make it compatible with `autoconf-find-last-macro'.
+Assume that MACRO doesn't appear in the buffer yet, so search
+the ordering list `autoconf-preferred-macro-order'."
+ ;; Search this list backwards.. heh heh heh
+ ;; This lets us do a reverse search easilly.
+ (let ((ml (member macro (reverse autoconf-preferred-macro-order))))
+ (if (not ml) (error "Don't know how to position for %s yet" macro))
+ (setq ml (cdr ml))
+ (goto-char (point-max))
+ (while (and ml (not (autoconf-find-last-macro (car ml))))
+ (setq ml (cdr ml)))
+ (if (not ml) (error "Could not find context for positioning %s" macro))))
+
+(defun autoconf-insert-macro-at-point (macro &optional param)
+ "Add MACRO at the current point with PARAM."
+ (insert macro)
+ (if param
+ (progn
+ (insert "(" param ")")
+ (if (< (current-column) 3) (insert " dnl")))))
+
+(defun autoconf-insert-new-macro (macro &optional param)
+ "Add a call to MACRO in the current autoconf file.
+Deals with macro order. See `autoconf-preferred-macro-order' and
+`autoconf-multi-macros'.
+Optional argument PARAM is the parameter to pass to the macro as one string."
+ (cond ((member macro autoconf-multiple-macros)
+ ;; This occurs multiple times
+ (or (autoconf-find-last-macro macro)
+ (autoconf-position-for-macro macro))
+ (forward-sexp 2)
+ (end-of-line)
+ (insert "\n")
+ (autoconf-insert-macro-at-point macro param))
+ ((member macro autoconf-multiple-multiple-macros)
+ (if (not param)
+ (error "You must have a paramter for %s" macro))
+ (if (not (autoconf-find-last-macro macro))
+ (progn
+ ;; Doesn't exist yet....
+ (autoconf-position-for-macro macro)
+ (forward-sexp 2)
+ (end-of-line)
+ (insert "\n")
+ (autoconf-insert-macro-at-point macro param))
+ ;; Does exist, can we fit onto the current line?
+ (forward-sexp 2)
+ (down-list -1)
+ (if (> (+ (current-column) (length param)) fill-column)
+ (insert " " param)
+ (up-list 1)
+ (end-of-line)
+ (insert "\n")
+ (autoconf-insert-macro-at-point macro param))))
+ ((autoconf-find-last-macro macro)
+ ;; If it isn't one of the multi's, it's a singleton.
+ ;; If it exists, ignore it.
+ nil)
+ (t
+ (autoconf-position-for-macro macro)
+ (forward-sexp 1)
+ (if (looking-at "\\s-*(")
+ (forward-sexp 1))
+ (end-of-line)
+ (insert "\n")
+ (autoconf-insert-macro-at-point macro param))))
+
+(defun autoconf-find-query-for-header (header)
+ "Position the cursor where HEADER is queried."
+ (interactive "sHeader: ")
+ (let ((op (point))
+ (found t))
+ (goto-char (point-min))
+ (condition-case nil
+ (while (not
+ (progn
+ (re-search-forward
+ (concat "\\b" (regexp-quote header) "\\b"))
+ (save-excursion
+ (beginning-of-line)
+ (looking-at "AC_CHECK_HEADERS")))))
+ ;; We depend on the search failing to exit our loop on failure.
+ (error (setq found nil)))
+ (if (not found) (goto-char op))
+ found))
+
+(defun autoconf-add-query-for-header (header)
+ "Add in HEADER to be queried for in our autoconf file."
+ (interactive "sHeader: ")
+ (or (autoconf-find-query-for-header header)
+ (autoconf-insert-new-macro "AC_CHECK_HEADERS" header)))
+
+
+(defun autoconf-find-query-for-func (func)
+ "Position the cursor where FUNC is queried."
+ (interactive "sFunction: ")
+ (let ((op (point))
+ (found t))
+ (goto-char (point-min))
+ (condition-case nil
+ (while (not
+ (progn
+ (re-search-forward
+ (concat "\\b" (regexp-quote func) "\\b"))
+ (save-excursion
+ (beginning-of-line)
+ (looking-at "AC_CHECK_FUNCS")))))
+ ;; We depend on the search failing to exit our loop on failure.
+ (error (setq found nil)))
+ (if (not found) (goto-char op))
+ found))
+
+(defun autoconf-add-query-for-func (func)
+ "Add in FUNC to be queried for in our autoconf file."
+ (interactive "sFunction: ")
+ (or (autoconf-find-query-for-func func)
+ (autoconf-insert-new-macro "AC_CHECK_FUNCS" func)))
+
+(defvar autoconf-program-builtin
+ '(("AWK" . "AC_PROG_AWK")
+ ("CC" . "AC_PROG_CC")
+ ("CPP" . "AC_PROG_CPP")
+ ("CXX" . "AC_PROG_CXX")
+ ("CXXCPP" . "AC_PROG_CXXCPP")
+ ("F77" . "AC_PROG_F77")
+ ("GCC_TRADITIONAL" . "AC_PROG_GCC_TRADITIONAL")
+ ("INSTALL" . "AC_PROG_INSTALL")
+ ("LEX" . "AC_PROG_LEX")
+ ("LN_S" . "AC_PROG_LN_S")
+ ("RANLIB" . "AC_PROG_RANLIB")
+ ("YACC" . "AC_PROG_YACC")
+ )
+ "Association list of PROGRAM variables and their built-in MACRO.")
+
+(defun autoconf-find-query-for-program (prog)
+ "Position the cursor where PROG is queried.
+PROG is the VARIABLE to use in autoconf to identify the program.
+PROG excludes the _PROG suffix. Thus if PROG were EMACS, then the
+variable in configure.in would be EMACS_PROG."
+ (let ((op (point))
+ (found t)
+ (builtin (assoc prog autoconf-program-builtin)))
+ (goto-char (point-min))
+ (condition-case nil
+ (re-search-forward
+ (concat "^"
+ (or (cdr-safe builtin)
+ (concat "AC_CHECK_PROG\\s-*(\\s-*" prog "_PROG"))
+ "\\>"))
+ (error (setq found nil)))
+ (if (not found) (goto-char op))
+ found))
+
+(defun autoconf-add-query-for-program (prog &optional names)
+ "Add in PROG to be queried for in our autoconf file.
+Optional NAMES is for non-built-in programs, and is the list
+of possible names."
+ (interactive "sProgram: ")
+ (if (autoconf-find-query-for-program prog)
+ nil
+ (let ((builtin (assoc prog autoconf-program-builtin)))
+ (if builtin
+ (autoconf-insert-new-macro (cdr builtin))
+ ;; Not built in, try the params item
+ (autoconf-insert-new-macro "AC_CHECK_PROGS" (concat prog "," names))
+ ))))
+
+;;; Scrappy little changes
+;;
+(defvar autoconf-deleted-text nil
+ "Set to the last bit of text deleted during an edit.")
+
+(defvar autoconf-inserted-text nil
+ "Set to the last bit of text inserted during an edit.")
+
+(defmacro autoconf-edit-cycle (&rest body)
+ "Start an edit cycle, unsetting the modified flag if there is no change.
+Optional argument BODY is the code to execute which edits the autoconf file."
+ `(let ((autoconf-deleted-text nil)
+ (autoconf-inserted-text nil)
+ (mod (buffer-modified-p)))
+ ,@body
+ (if (and (not mod)
+ (string= autoconf-deleted-text autoconf-inserted-text))
+ (set-buffer-modified-p nil))))
+
+(defun autoconf-delete-parameter (index)
+ "Delete the INDEXth parameter from the macro starting on the current line.
+Leaves the cursor where a new parameter can be inserted.
+INDEX starts at 1."
+ (beginning-of-line)
+ (down-list 1)
+ (re-search-forward ", ?" nil nil (1- index))
+ (let ((end (save-excursion
+ (re-search-forward ",\\|)" (save-excursion
+ (end-of-line)
+ (point)))
+ (forward-char -1)
+ (point))))
+ (setq autoconf-deleted-text (buffer-substring (point) end))
+ (delete-region (point) end)))
+
+(defun autoconf-insert (text)
+ "Insert TEXT."
+ (setq autoconf-inserted-text text)
+ (insert text))
+
+(defun autoconf-set-version (version)
+ "Set the version used with automake to VERSION."
+ (if (not (stringp version))
+ (signal 'wrong-type-argument '(stringp version)))
+ (if (not (autoconf-find-last-macro "AM_INIT_AUTOMAKE"))
+ (error "Cannot update version")
+ ;; Move to correct position.
+ (autoconf-edit-cycle
+ (autoconf-delete-parameter 2)
+ (autoconf-insert version))))
+
+(defun autoconf-set-output (outputlist)
+ "Set the files created in AC_OUTPUT to OUTPUTLIST.
+OUTPUTLIST is a list of strings representing relative paths
+to Makefiles, or other files using Autoconf substitution."
+ (if (not (autoconf-find-last-macro "AC_OUTPUT"))
+ (error "Cannot update version")
+ (autoconf-edit-cycle
+ (autoconf-delete-parameter 1)
+ (autoconf-insert (mapconcat (lambda (a) a) outputlist " ")))))
+
+(provide 'ede/autoconf-edit)
+
+;;; ede/autoconf-edit.el ends here
Index: cedet/ede/cpp-root.el
===================================================================
RCS file: cedet/ede/cpp-root.el
diff -N cedet/ede/cpp-root.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/cpp-root.el 28 Sep 2009 15:15:06 -0000 1.2
@@ -0,0 +1,515 @@
+;;; ede/cpp-root.el --- A simple way to wrap a C++ project with a single root
+
+;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; NOTE: ede-cpp-root.el has been commented so as to also make it
+;; useful for learning how to make similar project types.
+;;
+;; Not everyone can use automake, or an EDE project type. For
+;; pre-existing code, it is often helpful jut to be able to wrap the
+;; whole thing up in as simple a way as possible.
+;;
+;; The cpp-root project type will allow you to create a single object
+;; with no save-file in your .emacs file that will be recognized, and
+;; provide a way to easilly allow EDE to provide Semantic with the
+;; ability to find header files, and other various source files
+;; quickly.
+;;
+;; The cpp-root class knows a few things about C++ projects, such as
+;; the prevalence of "include" directories, and typical file-layout
+;; stuff. If this isn't sufficient, you can subclass
+;; `ede-cpp-root-project' and add your own tweaks in just a few lines.
+;; See the end of this file for an example.
+;;
+;;; EXAMPLE
+;;
+;; Add this to your .emacs file, modifying apropriate bits as needed.
+;;
+;; (ede-cpp-root-project "SOMENAME" :file "/dir/to/some/file")
+;;
+;; Replace SOMENAME with whatever name you want, and the filename to
+;; an actual file at the root of your project. It might be a
+;; Makefile, a README file. Whatever. It doesn't matter. It's just
+;; a key to hang the rest of EDE off of.
+;;
+;; The most likely reason to create this project, is to help make
+;; finding files within the project faster. In conjunction with
+;; Semantic completion, having a short include path is key. You can
+;; override the include path like this:
+;;
+;; (ede-cpp-root-project "NAME" :file "FILENAME"
+;; :include-path '( "/include" "../include" "/c/include" )
+;; :system-include-path '( "/usr/include/c++/3.2.2/" )
+;; :spp-table '( ("MOOSE" . "")
+;; ("CONST" . "const") )
+;; :spp-files '( "include/config.h" )
+;; )
+;;
+;; In this case each item in the include path list is searched. If
+;; the directory starts with "/", then that expands to the project
+;; root directory. If a directory does not start with "/", then it
+;; is relative to the default-directory of the current buffer when
+;; the file name is expanded.
+;;
+;; The include path only affects C/C++ header files. Use the slot
+;; :header-match-regexp to change it.
+;;
+;; The :system-include-path allows you to specify full directory
+;; names to include directories where system header files can be
+;; found. These will be applied to files in this project only.
+;;
+;; The :spp-table provides a list of project specific #define style
+;; macros that are unique to this project, passed in to the compiler
+;; on the command line, or are in special headers.
+;;
+;; The :spp-files option is like :spp-table, except you can provide a
+;; file name for a header in your project where most of your CPP
+;; macros reside. Doing this can be easier than listing everything in
+;; the :spp-table option. The files listed in :spp-files should not
+;; start with a /, and are relative to something in :include-path.;;
+;;
+;; If you want to override the file-finding tool with your own
+;; function you can do this:
+;;
+;; (ede-cpp-root-project "NAME" :file "FILENAME" :locate-fcn 'MYFCN)
+;;
+;; Where FILENAME is a file in the root directory of the project.
+;; Where MYFCN is a symbol for a function. See:
+;;
+;; M-x describe-class RET ede-cpp-root-project RET
+;;
+;; for documentation about the locate-fcn extension.
+;;
+;;; ADVANCED EXAMPLE
+;;
+;; If the cpp-root project style is right for you, but you want a
+;; dynamic loader, instead of hard-coding values in your .emacs, you
+;; can do that too, but you will need to write some lisp code.
+;;
+;; To do that, you need to add an entry to the
+;; `ede-project-class-files' list, and also provide two functions to
+;; teach EDE how to load your project pattern
+;;
+;; It would oook like this:
+;;
+;; (defun MY-FILE-FOR-DIR (&optional dir)
+;; "Return a full file name to the project file stored in DIR."
+;; <write your code here, or return nil>
+;; )
+;;
+;; (defun MY-ROOT-FCN ()
+;; "Return the root directory for `default-directory'"
+;; ;; You might be able to use `ede-cpp-root-project-root'.
+;; )
+;;
+;; (defun MY-LOAD (dir)
+;; "Load a project of type `cpp-root' for the directory DIR.
+;; Return nil if there isn't one."
+;; (ede-cpp-root-project "NAME" :file (expand-file-name "FILE" dir)
+;; :locate-fcn 'MYFCN)
+;; )
+;;
+;; (add-to-list 'ede-project-class-files
+;; (ede-project-autoload "cpp-root"
+;; :name "CPP ROOT"
+;; :file 'ede-cpp-root
+;; :proj-file 'MY-FILE-FOR-DIR
+;; :proj-root 'MY-ROOT-FCN
+;; :load-type 'MY-LOAD
+;; :class-sym 'ede-cpp-root)
+;; t)
+;;
+;;; TODO
+;;
+;; Need a way to reconfigure a project, and have it affect all open buffers.
+;; From Tobias Gerdin:
+;;
+;; >>3) Is there any way to refresh a ede-cpp-root-project dynamically? I
have
+;; >>some file open part of the project, fiddle with the include paths and
would
+;; >>like the open buffer to notice this when I re-evaluate the
+;; >>ede-cpp-root-project constructor.
+;; >
+;; > Another good idea. The easy way is to "revert-buffer" as needed. The
+;; > ede "project local variables" does this already, so it should be easy
+;; > to adapt something.
+;;
+;; I actually tried reverting the buffer but Semantic did not seem to pick
+;; up the differences (the "include summary" reported the same include
paths).
+
+(require 'ede)
+
+(defvar semantic-lex-spp-project-macro-symbol-obarray)
+(declare-function semantic-lex-make-spp-table "semantic/lex-spp")
+(declare-function semanticdb-file-table-object "semantic/db")
+(declare-function semanticdb-needs-refresh-p "semantic/db")
+(declare-function semanticdb-refresh-table "semantic/db")
+
+;;; Code:
+
+;;; PROJECT CACHE:
+;;
+;; cpp-root projects are created in a .emacs or other config file, but
+;; there still needs to be a way for a particular file to be
+;; identified against it. The cache is where we look to map a file
+;; against a project.
+;;
+;; Setting up a simple in-memory cache of active projects allows the
+;; user to re-load their configuration file several times without
+;; messing up the active project set.
+;;
+(defvar ede-cpp-root-project-list nil
+ "List of projects created by option `ede-cpp-root-project'.")
+
+(defun ede-cpp-root-file-existing (dir)
+ "Find a cpp-root project in the list of cpp-root projects.
+DIR is the directory to search from."
+ (let ((projs ede-cpp-root-project-list)
+ (ans nil))
+ (while (and projs (not ans))
+ (let ((root (ede-project-root-directory (car projs))))
+ (when (string-match (concat "^" (regexp-quote root)) dir)
+ (setq ans (car projs))))
+ (setq projs (cdr projs)))
+ ans))
+
+;;; PROJECT AUTOLOAD CONFIG
+;;
+;; Each project type registers itself into the project-class list.
+;; This way, each time a file is loaded, EDE can map that file to a
+;; project. This project type checks files against the internal cache
+;; of projects created by the user.
+;;
+;; EDE asks two kinds of questions. One is, does this DIR belong to a
+;; project. If it does, it then asks, what is the ROOT directory to
+;; the project in DIR. This is easy for cpp-root projects, but more
+;; complex for multiply nested projects.
+;;
+;; If EDE finds out that a project exists for DIR, it then loads that
+;; project. The LOAD routine can either create a new project object
+;; (if it needs to load it off disk) or more likely can return an
+;; existing object for the discovered directory. cpp-root always uses
+;; the second case.
+
+(defun ede-cpp-root-project-file-for-dir (&optional dir)
+ "Return a full file name to the project file stored in DIR."
+ (let ((proj (ede-cpp-root-file-existing dir)))
+ (when proj (oref proj :file))))
+
+(defvar ede-cpp-root-count 0
+ "Count number of hits to the cpp root thing.
+This is a debugging variable to test various optimizations in file
+lookup in the main EDE logic.")
+
+;;;###autoload
+(defun ede-cpp-root-project-root (&optional dir)
+ "Get the root directory for DIR."
+ (let ((projfile (ede-cpp-root-project-file-for-dir
+ (or dir default-directory))))
+ (setq ede-cpp-root-count (1+ ede-cpp-root-count))
+ ;(debug)
+ (when projfile
+ (file-name-directory projfile))))
+
+(defun ede-cpp-root-load (dir &optional rootproj)
+ "Return a CPP root object if you created one.
+Return nil if there isn't one.
+Argument DIR is the directory it is created for.
+ROOTPROJ is nil, since there is only one project."
+ ;; Snoop through our master list.
+ (ede-cpp-root-file-existing dir))
+
+;;; CLASSES
+;;
+;; EDE sets up projects with two kinds of objects.
+;;
+;; The PROJECT is a class that represents everything under a directory
+;; hierarchy. A TARGET represents a subset of files within a project.
+;; A project can have multiple targets, and multiple sub-projects.
+;; Sub projects should map to sub-directories.
+;;
+;; The CPP-ROOT project maps any file in C or C++ mode to a target for
+;; C files.
+;;
+;; When creating a custom project the project developer an opportunity
+;; to run code to setup various tools whenever an associated buffer is
+;; loaded. The CPP-ROOT project spends most of its time setting up C
+;; level include paths, and PreProcessor macro tables.
+
+(defclass ede-cpp-root-target (ede-target)
+ ()
+ "EDE cpp-root project target.
+All directories need at least one target.")
+
+(defclass ede-cpp-root-project (ede-project eieio-instance-tracker)
+ ((tracking-symbol :initform 'ede-cpp-root-project-list)
+ (include-path :initarg :include-path
+ :initform '( "/include" "../include/" )
+ :type list
+ :documentation
+ "The default locate function expands filenames within a
project.
+If a header file (.h, .hh, etc) name is expanded, and
+the :locate-fcn slot is nil, then the include path is checked
+first, and other directories are ignored. For very large
+projects, this optimization can save a lot of time.
+
+Directory names in the path can be relative to the current
+buffer's `default-directory' (not starting with a /). Directories
+that are relative to the project's root should start with a /, such
+as \"/include\", meaning the directory `include' off the project root
+directory.")
+ (system-include-path :initarg :system-include-path
+ :initform nil
+ :type list
+ :documentation
+ "The system include path for files in this project.
+C files initialized in an ede-cpp-root-project have their semantic
+system include path set to this value. If this is nil, then the
+semantic path is not modified.")
+ (spp-table :initarg :spp-table
+ :initform nil
+ :type list
+ :documentation
+ "C Preprocessor macros for your files.
+Preprocessor symbols will be used while parsing your files.
+These macros might be passed in through the command line compiler, or
+are critical symbols derived from header files. Providing header files
+macro values through this slot improves accuracy and performance.
+Use `:spp-files' to use these files directly.")
+ (spp-files :initarg :spp-files
+ :initform nil
+ :type list
+ :documentation
+ "C header file with Preprocessor macros for your files.
+The PreProcessor symbols appearing in these files will be used while
+parsing files in this project.
+See `semantic-lex-c-preprocessor-symbol-map' for more on how this works.")
+ (header-match-regexp :initarg :header-match-regexp
+ :initform
+ "\\.\\(h\\(h\\|xx\\|pp\\|\\+\\+\\)?\\|H\\)$\\|\\<\\w+$"
+ :type string
+ :documentation
+ "Regexp used to identify C/C++ header files.")
+ (locate-fcn :initarg :locate-fcn
+ :initform nil
+ :type (or null function)
+ :documentation
+ "The locate function can be used in place of
+`ede-expand-filename' so you can quickly customize your custom target
+to use specialized local routines instead of the EDE routines.
+The function symbol must take two arguments:
+ NAME - The name of the file to find.
+ DIR - The directory root for this cpp-root project.
+
+It should return the fully qualified file name passed in from NAME. If that
file does not
+exist, it should return nil."
+ )
+ )
+ "EDE cpp-root project class.
+Each directory needs a a project file to control it.")
+
+;;; INIT
+;;
+;; Most projects use `initialize-instance' to do special setup
+;; on the object when it is created. In this case, EDE-CPP-ROOT can
+;; find previous copies of this project, and make sure that one of the
+;; objects is deleted.
+
+(defmethod initialize-instance ((this ede-cpp-root-project)
+ &rest fields)
+ "Make sure the :file is fully expanded."
+ ;; Add ourselves to the master list
+ (call-next-method)
+ (let ((f (expand-file-name (oref this :file))))
+ ;; Remove any previous entries from the main list.
+ (let ((old (eieio-instance-tracker-find (file-name-directory f)
+ :directory
'ede-cpp-root-project-list)))
+ ;; This is safe, because :directory isn't filled in till later.
+ (when (and old (not (eq old this)))
+ (delete-instance old)))
+ ;; Basic initialization.
+ (when (or (not (file-exists-p f))
+ (file-directory-p f))
+ (delete-instance this)
+ (error ":file for ede-cpp-root must be a file."))
+ (oset this :file f)
+ (oset this :directory (file-name-directory f))
+ (ede-project-directory-remove-hash (file-name-directory f))
+ (ede-add-project-to-global-list this)
+ (unless (slot-boundp this 'targets)
+ (oset this :targets nil))
+ ;; We need to add ourselves to the master list.
+ ;;(setq ede-projects (cons this ede-projects))
+ ))
+
+;;; SUBPROJ Management.
+;;
+;; This is a way to allow a subdirectory to point back to the root
+;; project, simplifying authoring new single-point projects.
+
+(defmethod ede-find-subproject-for-directory ((proj ede-cpp-root-project)
+ dir)
+ "Return PROJ, for handling all subdirs below DIR."
+ proj)
+
+;;; TARGET MANAGEMENT
+;;
+;; Creating new targets on a per directory basis is a good way to keep
+;; files organized. See ede-emacs for an example with multiple file
+;; types.
+(defmethod ede-find-target ((proj ede-cpp-root-project) buffer)
+ "Find an EDE target in PROJ for BUFFER.
+If one doesn't exist, create a new one for this directory."
+ (let* ((targets (oref proj targets))
+ (dir default-directory)
+ (ans (object-assoc dir :path targets))
+ )
+ (when (not ans)
+ (setq ans (ede-cpp-root-target dir
+ :name (file-name-nondirectory
+ (directory-file-name dir))
+ :path dir
+ :source nil))
+ (object-add-to-list proj :targets ans)
+ )
+ ans))
+
+;;; FILE NAMES
+;;
+;; One of the more important jobs of EDE is to find files in a
+;; directory structure. cpp-root has tricks it knows about how most C
+;; projects are set up with include paths.
+;;
+;; This tools also uses the ede-locate setup for augmented file name
+;; lookup using external tools.
+(defmethod ede-expand-filename-impl ((proj ede-cpp-root-project) name)
+ "Within this project PROJ, find the file NAME.
+This knows details about or source tree."
+ ;; The slow part of the original is looping over subprojects.
+ ;; This version has no subprojects, so this will handle some
+ ;; basic cases.
+ (let ((ans (call-next-method)))
+ (unless ans
+ (let* ((lf (oref proj locate-fcn))
+ (dir (file-name-directory (oref proj file))))
+ (if lf
+ (setq ans (funcall lf name dir))
+ (if (ede-cpp-root-header-file-p proj name)
+ ;; Else, use our little hack.
+ (let ((ip (oref proj include-path))
+ (tmp nil))
+ (while ip
+ ;; Translate
+ (setq tmp (ede-cpp-root-translate-file proj (car ip)))
+ ;; Test this name.
+ (setq tmp (expand-file-name name tmp))
+ (if (file-exists-p tmp)
+ (setq ans tmp))
+ (setq ip (cdr ip)) ))
+ ;; Else, do the usual.
+ (setq ans (call-next-method)))
+ )))
+ (or ans (call-next-method))))
+
+(defmethod ede-project-root ((this ede-cpp-root-project))
+ "Return my root."
+ this)
+
+(defmethod ede-project-root-directory ((this ede-cpp-root-project))
+ "Return my root."
+ (file-name-directory (oref this file)))
+
+;;; C/CPP SPECIFIC CODE
+;;
+;; The following code is specific to setting up header files,
+;; include lists, and Preprocessor symbol tables.
+
+(defmethod ede-cpp-root-header-file-p ((proj ede-cpp-root-project) name)
+ "Non nil if in PROJ the filename NAME is a header."
+ (save-match-data
+ (string-match (oref proj header-match-regexp) name)))
+
+(defmethod ede-cpp-root-translate-file ((proj ede-cpp-root-project) filename)
+ "For PROJ, translate a user specified FILENAME.
+This is for project include paths and spp source files."
+ ;; Step one: Root of this project.
+ (let ((dir (file-name-directory (oref proj file))))
+
+ ;; Step two: Analyze first char, and rehost
+ (if (and (not (string= filename "")) (= (aref filename 0) ?/))
+ ;; Check relative to root of project
+ (setq filename (expand-file-name (substring filename 1)
+ dir))
+ ;; Relative to current directory.
+ (setq filename (expand-file-name filename)))
+
+ filename))
+
+(defmethod ede-set-project-variables ((project ede-cpp-root-project) &optional
buffer)
+ "Set variables local to PROJECT in BUFFER.
+Also set up the lexical preprocessor map."
+ (call-next-method)
+ (when (and (featurep 'semantic/c) (featurep 'semantic/lex-spp))
+ (setq semantic-lex-spp-project-macro-symbol-obarray
+ (semantic-lex-make-spp-table (oref project spp-table)))
+ ))
+
+(defmethod ede-system-include-path ((this ede-cpp-root-project))
+ "Get the system include path used by project THIS."
+ (oref this system-include-path))
+
+(defmethod ede-preprocessor-map ((this ede-cpp-root-project))
+ "Get the pre-processor map for project THIS."
+ (require 'semantic/db)
+ (let ((spp (oref this spp-table))
+ (root (ede-project-root this))
+ )
+ (mapc
+ (lambda (F)
+ (let* ((expfile (ede-expand-filename root F))
+ (table (when expfile
+ (semanticdb-file-table-object expfile)))
+ )
+ (when (not table)
+ (message "Cannot find file %s in project." F))
+ (when (and table (semanticdb-needs-refresh-p table))
+ (semanticdb-refresh-table table))
+ (setq spp (append spp (oref table lexical-table)))))
+ (oref this spp-files))
+ spp))
+
+(defmethod ede-system-include-path ((this ede-cpp-root-target))
+ "Get the system include path used by project THIS."
+ (ede-system-include-path (ede-target-parent this)))
+
+(defmethod ede-preprocessor-map ((this ede-cpp-root-target))
+ "Get the pre-processor map for project THIS."
+ (ede-preprocessor-map (ede-target-parent this)))
+
+(provide 'ede/cpp-root)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: ede/loaddefs
+;; generated-autoload-load-name: "ede/cpp-root"
+;; End:
+
+;;; ede/cpp-root.el ends here
Index: cedet/ede/dired.el
===================================================================
RCS file: cedet/ede/dired.el
diff -N cedet/ede/dired.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/dired.el 28 Sep 2009 15:15:06 -0000 1.2
@@ -0,0 +1,109 @@
+;;; ede/dired.el --- EDE extensions to dired.
+
+;;; Copyright (C) 1998, 1999, 2000, 2003 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Version: 0.4
+;; Keywords: project, make
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; This provides a dired interface to EDE, allowing users to modify
+;; their project file by adding files (or whatever) directly from a
+;; dired buffer.
+
+(require 'easymenu)
+(require 'dired)
+(require 'ede)
+
+;;; Code:
+(defvar ede-dired-minor-mode nil
+ "Non-nil when in ede dired minor mode.")
+(make-variable-buffer-local 'ede-dired-minor-mode)
+
+(defvar ede-dired-keymap nil
+ "Keymap used for ede dired minor mode.")
+
+(if ede-dired-keymap
+ nil
+ (setq ede-dired-keymap (make-sparse-keymap))
+ (define-key ede-dired-keymap ".a" 'ede-dired-add-to-target)
+ (define-key ede-dired-keymap ".t" 'ede-new-target)
+ (define-key ede-dired-keymap ".s" 'ede-speedbar)
+ (define-key ede-dired-keymap ".C" 'ede-compile-project)
+ (define-key ede-dired-keymap ".d" 'ede-make-dist)
+
+ (easy-menu-define
+ ede-dired-menu ede-dired-keymap "EDE Dired Minor Mode Menu"
+ '("Project"
+ [ "Add files to target" ede-dired-add-to-target (ede-current-project) ]
+ ( "Build" :filter ede-build-forms-menu)
+ "-"
+ [ "Create Project" ede-new (not (ede-current-project)) ]
+ [ "Create Target" ede-new-target (ede-current-project) ]
+ "-"
+ ( "Customize Project" :filter ede-customize-forms-menu )
+ [ "View Project Tree" ede-speedbar (ede-current-project) ]
+ ))
+ )
+
+(defun ede-dired-minor-mode (&optional arg)
+ "A minor mode that should only be activated in DIRED buffers.
+If ARG is nil, toggle, if it is a positive number, force on, if
+negative, force off."
+ (interactive "P")
+ (if (not (or (eq major-mode 'dired-mode)
+ (eq major-mode 'vc-dired-mode)))
+ (error "Not in DIRED mode"))
+ (setq ede-dired-minor-mode
+ (not (or (and (null arg) ede-dired-minor-mode)
+ (<= (prefix-numeric-value arg) 0))))
+ (if (and (not (ede-directory-project-p default-directory))
+ (not (interactive-p)))
+ (setq ede-dired-minor-mode nil))
+ )
+
+(defun ede-dired-add-to-target (target)
+ "Add a file, or all marked files into a TARGET."
+ (interactive (list
+ (let ((ede-object (ede-current-project)))
+ (ede-invoke-method 'project-interactive-select-target
+ "Add files to Target: "))))
+ (let ((files (dired-get-marked-files t)))
+ (while files
+ (project-add-file target (car files))
+ ;; Find the buffer for this files, and set it's ede-object
+ (if (get-file-buffer (car files))
+ (save-excursion
+ (set-buffer (get-file-buffer (car files)))
+ (setq ede-object nil)
+ (setq ede-object (ede-buffer-object (current-buffer)))))
+ ;; Increment.
+ (setq files (cdr files)))))
+
+;; Minor mode management.
+(add-to-list 'minor-mode-alist '(ede-dired-minor-mode " EDE"))
+(let ((a (assoc 'ede-dired-minor-mode minor-mode-map-alist)))
+ (if a
+ (setcdr a ede-dired-keymap)
+ (add-to-list 'minor-mode-map-alist (cons 'ede-dired-minor-mode
+ ede-dired-keymap))))
+
+(provide 'ede/dired)
+
+;;; ede/dired.el ends here
Index: cedet/ede/emacs.el
===================================================================
RCS file: cedet/ede/emacs.el
diff -N cedet/ede/emacs.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/emacs.el 28 Sep 2009 15:15:06 -0000 1.2
@@ -0,0 +1,257 @@
+;;; ede/emacs.el --- Special project for Emacs
+
+;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Provide a special project type just for Emacs, cause Emacs is special.
+;;
+;; Identifies an Emacs project automatically.
+;; Speedy ede-expand-filename based on extension.
+;; Pre-populates the preprocessor map from lisp.h
+;;
+;; ToDo :
+;; * Add "build" options.
+;; * Add texinfo lookup options.
+;; * Add website
+
+(require 'ede)
+(declare-function semanticdb-file-table-object "semantic/db")
+(declare-function semanticdb-needs-refresh-p "semantic/db")
+(declare-function semanticdb-refresh-table "semantic/db")
+
+;;; Code:
+(defvar ede-emacs-project-list nil
+ "List of projects created by option `ede-emacs-project'.")
+
+(defun ede-emacs-file-existing (dir)
+ "Find a Emacs project in the list of Emacs projects.
+DIR is the directory to search from."
+ (let ((projs ede-emacs-project-list)
+ (ans nil))
+ (while (and projs (not ans))
+ (let ((root (ede-project-root-directory (car projs))))
+ (when (string-match (concat "^" (regexp-quote root)) dir)
+ (setq ans (car projs))))
+ (setq projs (cdr projs)))
+ ans))
+
+;;;###autoload
+(defun ede-emacs-project-root (&optional dir)
+ "Get the root directory for DIR."
+ (when (not dir) (setq dir default-directory))
+ (let ((case-fold-search t)
+ (proj (ede-emacs-file-existing dir)))
+ (if proj
+ (ede-up-directory (file-name-directory
+ (oref proj :file)))
+ ;; No pre-existing project. Lets take a wild-guess if we have
+ ;; an Emacs project here.
+ (when (string-match "emacs[^/]*" dir)
+ (let ((base (substring dir 0 (match-end 0))))
+ (when (file-exists-p (expand-file-name "src/emacs.c" base))
+ base))))))
+
+(defun ede-emacs-version (dir)
+ "Find the Emacs version for the Emacs src in DIR."
+ (let ((buff (get-buffer-create " *emacs-query*")))
+ (save-excursion
+ (set-buffer buff)
+ (erase-buffer)
+ (setq default-directory (file-name-as-directory dir))
+ (call-process "egrep" nil buff nil "-n" "-e" "^version=" "Makefile")
+ (goto-char (point-min))
+ (re-search-forward "version=\\([0-9.]+\\)")
+ (prog1
+ (match-string 1)
+ (kill-buffer buff)
+ ))))
+
+(defclass ede-emacs-project (ede-project eieio-instance-tracker)
+ ((tracking-symbol :initform 'ede-emacs-project-list)
+ )
+ "Project Type for the Emacs source code."
+ :method-invocation-order :depth-first)
+
+(defun ede-emacs-load (dir &optional rootproj)
+ "Return an Emacs Project object if there is a match.
+Return nil if there isn't one.
+Argument DIR is the directory it is created for.
+ROOTPROJ is nil, since there is only one project."
+ (or (ede-emacs-file-existing dir)
+ ;; Doesn't already exist, so lets make one.
+ (ede-emacs-project "Emacs"
+ :name (concat "Emacs" (ede-emacs-version dir))
+ :directory dir
+ :file (expand-file-name "src/emacs.c"
+ dir))
+ (ede-add-project-to-global-list this)
+ )
+ )
+
+(defclass ede-emacs-target-c (ede-target)
+ ()
+ "EDE Emacs Project target for C code.
+All directories need at least one target.")
+
+(defclass ede-emacs-target-el (ede-target)
+ ()
+ "EDE Emacs Project target for Emacs Lisp code.
+All directories need at least one target.")
+
+(defclass ede-emacs-target-misc (ede-target)
+ ()
+ "EDE Emacs Project target for Misc files.
+All directories need at least one target.")
+
+(defmethod initialize-instance ((this ede-emacs-project)
+ &rest fields)
+ "Make sure the :file is fully expanded."
+ (call-next-method)
+ (unless (slot-boundp this 'targets)
+ (oset this :targets nil)))
+
+;;; File Stuff
+;;
+(defmethod ede-project-root-directory ((this ede-emacs-project)
+ &optional file)
+ "Return the root for THIS Emacs project with file."
+ (ede-up-directory (file-name-directory (oref this file))))
+
+(defmethod ede-project-root ((this ede-emacs-project))
+ "Return my root."
+ this)
+
+(defmethod ede-find-subproject-for-directory ((proj ede-emacs-project)
+ dir)
+ "Return PROJ, for handling all subdirs below DIR."
+ proj)
+
+;;; TARGET MANAGEMENT
+;;
+(defun ede-emacs-find-matching-target (class dir targets)
+ "Find a target that is a CLASS and is in DIR in the list of TARGETS."
+ (let ((match nil))
+ (dolist (T targets)
+ (when (and (object-of-class-p T class)
+ (string= (oref T :path) dir))
+ (setq match T)
+ ))
+ match))
+
+(defmethod ede-find-target ((proj ede-emacs-project) buffer)
+ "Find an EDE target in PROJ for BUFFER.
+If one doesn't exist, create a new one for this directory."
+ (let* ((ext (file-name-extension (buffer-file-name buffer)))
+ (cls (cond ((not ext)
+ 'ede-emacs-target-misc)
+ ((string-match "c\\|h" ext)
+ 'ede-emacs-target-c)
+ ((string-match "elc?" ext)
+ 'ede-emacs-target-el)
+ (t 'ede-emacs-target-misc)))
+ (targets (oref proj targets))
+ (dir default-directory)
+ (ans (ede-emacs-find-matching-target cls dir targets))
+ )
+ (when (not ans)
+ (setq ans (make-instance
+ cls
+ :name (file-name-nondirectory
+ (directory-file-name dir))
+ :path dir
+ :source nil))
+ (object-add-to-list proj :targets ans)
+ )
+ ans))
+
+;;; UTILITIES SUPPORT.
+;;
+(defmethod ede-preprocessor-map ((this ede-emacs-target-c))
+ "Get the pre-processor map for Emacs C code.
+All files need the macros from lisp.h!"
+ (require 'semantic/db)
+ (let* ((proj (ede-target-parent this))
+ (root (ede-project-root proj))
+ (table (semanticdb-file-table-object
+ (ede-expand-filename root "lisp.h")))
+ filemap
+ )
+ (when table
+ (when (semanticdb-needs-refresh-p table)
+ (semanticdb-refresh-table table))
+ (setq filemap (append filemap (oref table lexical-table)))
+ )
+ filemap
+ ))
+
+(defun ede-emacs-find-in-directories (name base dirs)
+ "Find NAME is BASE directory sublist of DIRS."
+ (let ((ans nil))
+ (while (and dirs (not ans))
+ (let* ((D (car dirs))
+ (ed (expand-file-name D base))
+ (ef (expand-file-name name ed)))
+ (if (file-exists-p ef)
+ (setq ans ef)
+ ;; Not in this dir? How about subdirs?
+ (let ((dirfile (directory-files ed t))
+ (moredirs nil)
+ )
+ ;; Get all the subdirs.
+ (dolist (DF dirfile)
+ (when (and (file-directory-p DF)
+ (not (string-match "\\.$" DF)))
+ (push DF moredirs)))
+ ;; Try again.
+ (setq ans (ede-emacs-find-in-directories name ed moredirs))
+ ))
+ (setq dirs (cdr dirs))))
+ ans))
+
+(defmethod ede-expand-filename-impl ((proj ede-emacs-project) name)
+ "Within this project PROJ, find the file NAME.
+Knows about how the Emacs source tree is organized."
+ (let* ((ext (file-name-extension name))
+ (root (ede-project-root proj))
+ (dir (ede-project-root-directory root))
+ (dirs (cond
+ ((not ext) nil)
+ ((string-match "h\\|c" ext)
+ '("src" "lib-src" "lwlib"))
+ ((string-match "elc?" ext)
+ '("lisp"))
+ ((string-match "texi" ext)
+ '("doc"))
+ (t nil)))
+ )
+ (if (not dirs) (call-next-method)
+ (ede-emacs-find-in-directories name dir dirs))
+ ))
+
+(provide 'ede/emacs)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: ede/loaddefs
+;; generated-autoload-load-name: "ede/emacs"
+;; End:
+
+;;; ede/emacs.el ends here
Index: cedet/ede/files.el
===================================================================
RCS file: cedet/ede/files.el
diff -N cedet/ede/files.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/files.el 28 Sep 2009 15:15:06 -0000 1.2
@@ -0,0 +1,516 @@
+;;; ede/files.el --- Associate projects with files and directories.
+
+;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Directory and File scanning and matching functions.
+;;
+;; Basic Model:
+;;
+;; A directory belongs to a project if a ede-project-autoload structure
+;; matches your directory.
+;;
+;; A toplevel project is one where there is no active project above
+;; it. Finding the toplevel project involves going up a directory
+;; till no ede-project-autoload structure matches.
+;;
+
+(require 'ede)
+
+(declare-function ede-locate-file-in-hash "ede/locate")
+(declare-function ede-locate-add-file-to-hash "ede/locate")
+(declare-function ede-locate-file-in-project "ede/locate")
+
+(defvar ede--disable-inode nil
+ "Set to 't' to simulate systems w/out inode support.")
+
+;;; Code:
+;;;###autoload
+(defun ede-find-file (file)
+ "Find FILE in project. FILE can be specified without a directory.
+There is no completion at the prompt. FILE is searched for within
+the current EDE project."
+ (interactive "sFile: ")
+ (let ((fname (ede-expand-filename (ede-current-project) file))
+ )
+ (unless fname
+ (error "Could not find %s in %s"
+ file
+ (ede-project-root-directory (ede-current-project))))
+ (find-file fname)))
+
+;;; Placeholders for ROOT directory scanning on base objects
+;;
+(defmethod ede-project-root ((this ede-project-placeholder))
+ "If a project knows it's root, return it here.
+Allows for one-project-object-for-a-tree type systems."
+ (oref this rootproject))
+
+(defmethod ede-project-root-directory ((this ede-project-placeholder)
+ &optional file)
+ "If a project knows it's root, return it here.
+Allows for one-project-object-for-a-tree type systems.
+Optional FILE is the file to test. It is ignored in preference
+of the anchor file for the project."
+ (file-name-directory (expand-file-name (oref this file))))
+
+
+(defmethod ede-project-root ((this ede-project-autoload))
+ "If a project knows it's root, return it here.
+Allows for one-project-object-for-a-tree type systems."
+ nil)
+
+(defmethod ede-project-root-directory ((this ede-project-autoload)
+ &optional file)
+ "If a project knows it's root, return it here.
+Allows for one-project-object-for-a-tree type systems.
+Optional FILE is the file to test. If there is no FILE, use
+the current buffer."
+ (when (not file)
+ (setq file default-directory))
+ (when (slot-boundp this :proj-root)
+ (let ((rootfcn (oref this proj-root)))
+ (when rootfcn
+ (condition-case nil
+ (funcall rootfcn file)
+ (error
+ (funcall rootfcn)))
+ ))))
+
+(defmethod ede--project-inode ((proj ede-project-placeholder))
+ "Get the inode of the directory project PROJ is in."
+ (if (slot-boundp proj 'dirinode)
+ (oref proj dirinode)
+ (oset proj dirinode (ede--inode-for-dir (oref proj :directory)))))
+
+(defmethod ede-find-subproject-for-directory ((proj ede-project-placeholder)
+ dir)
+ "Find a subproject of PROJ that corresponds to DIR."
+ (if ede--disable-inode
+ (let ((ans nil))
+ ;; Try to find the right project w/out inodes.
+ (ede-map-subprojects
+ proj
+ (lambda (SP)
+ (when (not ans)
+ (if (string= (file-truename dir) (oref SP :directory))
+ (setq ans SP)
+ (ede-find-subproject-for-directory SP dir)))))
+ ans)
+ ;; We can use inodes, so lets try it.
+ (let ((ans nil)
+ (inode (ede--inode-for-dir dir)))
+ (ede-map-subprojects
+ proj
+ (lambda (SP)
+ (when (not ans)
+ (if (equal (ede--project-inode SP) inode)
+ (setq ans SP)
+ (ede-find-subproject-for-directory SP dir)))))
+ ans)))
+
+;;; DIRECTORY IN OPEN PROJECT
+;;
+;; These routines match some directory name to one of the many pre-existing
+;; open projects. This should avoid hitting the disk, or asking lots of
questions
+;; if used throughout the other routines.
+(defvar ede-inode-directory-hash (make-hash-table
+ ;; Note on test. Can we compare inodes or
something?
+ :test 'equal)
+ "A hash of directory names and inodes.")
+
+(defun ede--put-inode-dir-hash (dir inode)
+ "Add to the EDE project hash DIR associated with INODE."
+ (when (fboundp 'puthash)
+ (puthash dir inode ede-inode-directory-hash)
+ inode))
+
+(defun ede--get-inode-dir-hash (dir)
+ "Get the EDE project hash DIR associated with INODE."
+ (when (fboundp 'gethash)
+ (gethash dir ede-inode-directory-hash)
+ ))
+
+(defun ede--inode-for-dir (dir)
+ "Return the inode for the directory DIR."
+ (let ((hashnode (ede--get-inode-dir-hash (expand-file-name dir))))
+ (or hashnode
+ (if ede--disable-inode
+ (ede--put-inode-dir-hash dir 0)
+ (let ((fattr (file-attributes dir)))
+ (ede--put-inode-dir-hash dir (nth 10 fattr))
+ )))))
+
+(defun ede-directory-get-open-project (dir &optional rootreturn)
+ "Return an already open project that is managing DIR.
+Optional ROOTRETURN specifies a symbol to set to the root project.
+If DIR is the root project, then it is the same."
+ (let* ((inode (ede--inode-for-dir dir))
+ (ft (file-name-as-directory (expand-file-name dir)))
+ (proj (ede--inode-get-toplevel-open-project inode))
+ (ans nil))
+ ;; Try file based search.
+ (when (not proj)
+ (setq proj (ede-directory-get-toplevel-open-project ft)))
+ ;; Default answer is this project
+ (setq ans proj)
+ ;; Save.
+ (when rootreturn (set rootreturn proj))
+ ;; Find subprojects.
+ (when (and proj (or ede--disable-inode
+ (not (equal inode (ede--project-inode proj)))))
+ (setq ans (ede-find-subproject-for-directory proj ft)))
+ ans))
+
+(defun ede--inode-get-toplevel-open-project (inode)
+ "Return an already open toplevel project that is managing INODE.
+Does not check subprojects."
+ (when (or (and (numberp inode) (/= inode 0))
+ (consp inode))
+ (let ((all ede-projects)
+ (found nil)
+ )
+ (while (and all (not found))
+ (when (equal inode (ede--project-inode (car all)))
+ (setq found (car all)))
+ (setq all (cdr all)))
+ found)))
+
+(defun ede-directory-get-toplevel-open-project (dir)
+ "Return an already open toplevel project that is managing DIR."
+ (let ((ft (file-name-as-directory (expand-file-name dir)))
+ (all ede-projects)
+ (ans nil))
+ (while (and all (not ans))
+ ;; Do the check.
+ (let ((pd (oref (car all) :directory))
+ )
+ (cond
+ ;; Exact text match.
+ ((string= pd ft)
+ (setq ans (car all)))
+ ;; Some sub-directory
+ ((string-match (concat "^" (regexp-quote pd)) ft)
+ (setq ans (car all)))
+ ;; Exact inode match. Useful with symlinks or complex automounters.
+ ((let ((pin (ede--project-inode (car all)))
+ (inode (ede--inode-for-dir dir)))
+ (and (not (eql pin 0)) (equal pin inode)))
+ (setq ans (car all)))
+ ;; Subdir via truename - slower by far, but faster than a traditional
lookup.
+ ((let ((ftn (file-truename ft))
+ (ptd (file-truename (oref (car all) :directory))))
+ (string-match (concat "^" (regexp-quote ptd)) ftn))
+ (setq ans (car all)))
+ ))
+ (setq all (cdr all)))
+ ans))
+
+;;; DIRECTORY-PROJECT-P
+;;
+;; For a fresh buffer, or for a path w/ no open buffer, use this
+;; routine to determine if there is a known project type here.
+(defvar ede-project-directory-hash (make-hash-table
+ ;; Note on test. Can we compare inodes or
something?
+ :test 'equal)
+ "A hash of directory names and associated EDE objects.")
+
+(defun ede-project-directory-remove-hash (dir)
+ "Reset the directory hash for DIR.
+Do this whenever a new project is created, as opposed to loaded."
+ ;; TODO - Use maphash, and delete by regexp, not by dir searching!
+
+ (when (fboundp 'remhash)
+ (remhash (file-name-as-directory dir) ede-project-directory-hash)
+ ;; Look for all subdirs of D, and remove them.
+ (let ((match (concat "^" (regexp-quote dir))))
+ (maphash (lambda (K O)
+ (when (string-match match K)
+ (remhash K ede-project-directory-hash)))
+ ede-project-directory-hash))
+ ))
+
+(defun ede-directory-project-from-hash (dir)
+ "If there is an already loaded project for DIR, return it from the hash."
+ (when (fboundp 'gethash)
+ (gethash dir ede-project-directory-hash nil)))
+
+(defun ede-directory-project-add-description-to-hash (dir desc)
+ "Add to the EDE project hash DIR associated with DESC."
+ (when (fboundp 'puthash)
+ (puthash dir desc ede-project-directory-hash)
+ desc))
+
+(defun ede-directory-project-p (dir &optional force)
+ "Return a project description object if DIR has a project.
+Optional argument FORCE means to ignore a hash-hit of 'nomatch.
+This depends on an up to date `ede-project-class-files' variable."
+ (let* ((dirtest (expand-file-name dir))
+ (match (ede-directory-project-from-hash dirtest)))
+ (cond
+ ((and (eq match 'nomatch) (not force))
+ nil)
+ ((and match (not (eq match 'nomatch)))
+ match)
+ (t
+ (let ((types ede-project-class-files)
+ (ret nil))
+ ;; Loop over all types, loading in the first type that we find.
+ (while (and types (not ret))
+ (if (ede-dir-to-projectfile (car types) dirtest)
+ (progn
+ ;; We found one! Require it now since we will need it.
+ (require (oref (car types) file))
+ (setq ret (car types))))
+ (setq types (cdr types)))
+ (ede-directory-project-add-description-to-hash dirtest (or ret
'nomatch))
+ ret)))))
+
+;;; TOPLEVEL
+;;
+;; These utilities will identify the "toplevel" of a project.
+;;
+(defun ede-toplevel-project-or-nil (dir)
+ "Starting with DIR, find the toplevel project directory, or return nil.
+nil is returned if the current directory is not a part ofa project."
+ (let* ((ans (ede-directory-get-toplevel-open-project dir)))
+ (if ans
+ (oref ans :directory)
+ (if (ede-directory-project-p dir)
+ (ede-toplevel-project dir)
+ nil))))
+
+(defun ede-toplevel-project (dir)
+ "Starting with DIR, find the toplevel project directory."
+ (if (and (string= dir default-directory)
+ ede-object-root-project)
+ ;; Try the local buffer cache first.
+ (oref ede-object-root-project :directory)
+ ;; Otherwise do it the hard way.
+ (let* ((thisdir (ede-directory-project-p dir))
+ (ans (ede-directory-get-toplevel-open-project dir)))
+ (if (and ans ;; We have an answer
+ (or (not thisdir) ;; this dir isn't setup
+ (and (object-of-class-p ;; Same as class for this dir?
+ ans (oref thisdir :class-sym)))
+ ))
+ (oref ans :directory)
+ (let* ((toppath (expand-file-name dir))
+ (newpath toppath)
+ (proj (ede-directory-project-p dir))
+ (ans nil))
+ (if proj
+ ;; If we already have a project, ask it what the root is.
+ (setq ans (ede-project-root-directory proj)))
+
+ ;; If PROJ didn't know, or there is no PROJ, then
+
+ ;; Loop up to the topmost project, and then load that single
+ ;; project, and it's sub projects. When we are done, identify the
+ ;; sub-project object belonging to file.
+ (while (and (not ans) newpath proj)
+ (setq toppath newpath
+ newpath (ede-up-directory toppath))
+ (when newpath
+ (setq proj (ede-directory-project-p newpath)))
+
+ (when proj
+ ;; We can home someone in the middle knows too.
+ (setq ans (ede-project-root-directory proj)))
+ )
+ (or ans toppath))))))
+
+;;; TOPLEVEL PROJECT
+;;
+;; The toplevel project is a way to identify the EDE structure that belongs
+;; to the top of a project.
+
+(defun ede-toplevel (&optional subproj)
+ "Return the ede project which is the root of the current project.
+Optional argument SUBPROJ indicates a subproject to start from
+instead of the current project."
+ (or ede-object-root-project
+ (let* ((cp (or subproj (ede-current-project)))
+ )
+ (or (and cp (ede-project-root cp))
+ (progn
+ (while (ede-parent-project cp)
+ (setq cp (ede-parent-project cp)))
+ cp)))))
+
+;;; DIRECTORY CONVERSION STUFF
+;;
+(defmethod ede-convert-path ((this ede-project) path)
+ "Convert path in a standard way for a given project.
+Default to making it project relative.
+Argument THIS is the project to convert PATH to."
+ (let ((pp (ede-project-root-directory this))
+ (fp (expand-file-name path)))
+ (if (string-match (regexp-quote pp) fp)
+ (substring fp (match-end 0))
+ (let ((pptf (file-truename pp))
+ (fptf (file-truename fp)))
+ (if (string-match (regexp-quote pptf) fptf)
+ (substring fptf (match-end 0))
+ (error "Cannot convert relativize path %s" fp))))))
+
+(defmethod ede-convert-path ((this ede-target) path)
+ "Convert path in a standard way for a given project.
+Default to making it project relative.
+Argument THIS is the project to convert PATH to."
+ (let ((proj (ede-target-parent this)))
+ (if proj
+ (let ((p (ede-convert-path proj path))
+ (lp (or (oref this path) "")))
+ ;; Our target THIS may have path information.
+ ;; strip this out of the conversion.
+ (if (string-match (concat "^" (regexp-quote lp)) p)
+ (substring p (length lp))
+ p))
+ (error "Parentless target %s" this))))
+
+;;; FILENAME EXPANSION
+;;
+(defun ede-get-locator-object (proj)
+ "Get the locator object for project PROJ.
+Get it from the toplevel project. If it doesn't have one, make one."
+ ;; Make sure we have a location object available for
+ ;; caching values, and for locating things more robustly.
+ (let ((top (ede-toplevel proj)))
+ (when (not (slot-boundp top 'locate-obj))
+ (ede-enable-locate-on-project this))
+ (oref top locate-obj)
+ ))
+
+(defmethod ede-expand-filename ((this ede-project) filename &optional force)
+ "Return a fully qualified file name based on project THIS.
+FILENAME should be just a filename which occurs in a directory controlled
+by this project.
+Optional argument FORCE forces the default filename to be provided even if it
+doesn't exist.
+If FORCE equals 'newfile, then the cache is ignored."
+ (require 'ede/locate)
+ (let* ((loc (ede-get-locator-object this))
+ (ha (ede-locate-file-in-hash loc filename))
+ (ans nil)
+ )
+ ;; NOTE: This function uses a locator object, which keeps a hash
+ ;; table of files it has found in the past. The hash table is
+ ;; used to make commonly found file very fast to location. Some
+ ;; complex routines, such as smart completion asks this question
+ ;; many times, so doing this speeds things up, especially on NFS
+ ;; or other remote file systems.
+
+ ;; As such, special care is needed to use the hash, and also obey
+ ;; the FORCE option, which is needed when trying to identify some
+ ;; new file that needs to be created, such as a Makefile.
+ (cond
+ ;; We have a hash-table match, AND that match wasn't the 'nomatch
+ ;; flag, we can return it.
+ ((and ha (not (eq ha 'nomatch)))
+ (setq ans ha))
+ ;; If we had a match, and it WAS no match, then we need to look
+ ;; at the force-option to see what to do. Since ans is already
+ ;; nil, then we do nothing.
+ ((and (eq ha 'nomatch) (not (eq force 'newfile)))
+ nil)
+ ;; We had no hash table match, so we have to look up this file
+ ;; using the usual EDE file expansion rules.
+ (t
+ (let ((calc (ede-expand-filename-impl this filename)))
+ (if calc
+ (progn
+ (ede-locate-add-file-to-hash loc filename calc)
+ (setq ans calc))
+ ;; If we failed to calculate something, we
+ ;; should add it to the hash, but ONLY if we are not
+ ;; going to FORCE the file into existance.
+ (when (not force)
+ (ede-locate-add-file-to-hash loc filename 'nomatch))))
+ ))
+ ;; Now that all options have been queried, if the FORCE option is
+ ;; true, but ANS is still nil, then we can make up a file name.
+
+ ;; Is it forced?
+ (when (and force (not ans))
+ (let ((dir (ede-project-root-directory this)))
+ (setq ans (expand-file-name filename dir))))
+
+ ans))
+
+(defmethod ede-expand-filename-impl ((this ede-project) filename &optional
force)
+ "Return a fully qualified file name based on project THIS.
+FILENAME should be just a filename which occurs in a directory controlled
+by this project.
+Optional argument FORCE forces the default filename to be provided even if it
+doesn't exist."
+ (let ((loc (ede-get-locator-object this))
+ (path (ede-project-root-directory this))
+ (proj (oref this subproj))
+ (found nil))
+ ;; find it Locally.
+ (setq found
+ (cond ((file-exists-p (expand-file-name filename path))
+ (expand-file-name filename path))
+ ((file-exists-p (expand-file-name (concat "include/" filename)
path))
+ (expand-file-name (concat "include/" filename) path))
+ (t
+ (while (and (not found) proj)
+ (setq found (when (car proj)
+ (ede-expand-filename (car proj) filename))
+ proj (cdr proj)))
+ found)))
+ ;; Use an external locate tool.
+ (when (not found)
+ (require 'ede/locate)
+ (setq found (car (ede-locate-file-in-project loc filename))))
+ ;; Return it
+ found))
+
+(defmethod ede-expand-filename ((this ede-target) filename &optional force)
+ "Return a fully qualified file name based on target THIS.
+FILENAME should a a filename which occurs in a directory in which THIS works.
+Optional argument FORCE forces the default filename to be provided even if it
+doesn't exist."
+ (ede-expand-filename (ede-target-parent this) filename force))
+
+;;; UTILITIES
+;;
+
+(defun ede-up-directory (dir)
+ "Return a dir that is up one directory.
+Argument DIR is the directory to trim upwards."
+ (let* ((fad (directory-file-name dir))
+ (fnd (file-name-directory fad)))
+ (if (string= dir fnd) ; This will catch the old string-match against
+ ; c:/ for DOS like systems.
+ nil
+ fnd)))
+
+(provide 'ede/files)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: ede/loaddefs
+;; generated-autoload-load-name: "ede/files"
+;; End:
+
+;;; ede/files.el ends here
Index: cedet/ede/linux.el
===================================================================
RCS file: cedet/ede/linux.el
diff -N cedet/ede/linux.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/linux.el 28 Sep 2009 15:15:06 -0000 1.2
@@ -0,0 +1,237 @@
+;;; ede/linux.el --- Special project for Linux
+
+;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Provide a special project type just for Linux, cause Linux is special.
+;;
+;; Identifies a Linux project automatically.
+;; Speedy ede-expand-filename based on extension.
+;; Pre-populates the preprocessor map from lisp.h
+;;
+;; ToDo :
+;; * Add "build" options.
+;; * Add texinfo lookup options.
+;; * Add website
+
+(require 'ede)
+(declare-function semanticdb-file-table-object "semantic/db")
+(declare-function semanticdb-needs-refresh-p "semantic/db")
+(declare-function semanticdb-refresh-table "semantic/db")
+
+;;; Code:
+(defvar ede-linux-project-list nil
+ "List of projects created by option `ede-linux-project'.")
+
+(defun ede-linux-file-existing (dir)
+ "Find a Linux project in the list of Linux projects.
+DIR is the directory to search from."
+ (let ((projs ede-linux-project-list)
+ (ans nil))
+ (while (and projs (not ans))
+ (let ((root (ede-project-root-directory (car projs))))
+ (when (string-match (concat "^" (regexp-quote root)) dir)
+ (setq ans (car projs))))
+ (setq projs (cdr projs)))
+ ans))
+
+;;;###autoload
+(defun ede-linux-project-root (&optional dir)
+ "Get the root directory for DIR."
+ (when (not dir) (setq dir default-directory))
+ (let ((case-fold-search t)
+ (proj (ede-linux-file-existing dir)))
+ (if proj
+ (ede-up-directory (file-name-directory
+ (oref proj :file)))
+ ;; No pre-existing project. Lets take a wild-guess if we have
+ ;; an Linux project here.
+ (when (string-match "linux[^/]*" dir)
+ (let ((base (substring dir 0 (match-end 0))))
+ (when (file-exists-p (expand-file-name "scripts/ver_linux" base))
+ base))))))
+
+(defun ede-linux-version (dir)
+ "Find the Linux version for the Linux src in DIR."
+ (let ((buff (get-buffer-create " *linux-query*")))
+ (save-excursion
+ (set-buffer buff)
+ (erase-buffer)
+ (setq default-directory (file-name-as-directory dir))
+ (call-process "head" nil buff nil "-n" "3" "Makefile")
+ (goto-char (point-min))
+ (let (major minor sub)
+ (re-search-forward "^VERSION *= *\\([0-9.]+\\)")
+ (setq major (match-string 1))
+ (re-search-forward "^PATCHLEVEL *= *\\([0-9.]+\\)")
+ (setq minor (match-string 1))
+ (re-search-forward "^SUBLEVEL *= *\\([0-9.]+\\)")
+ (setq sub (match-string 1))
+ (prog1
+ (concat major "." minor "." sub)
+ (kill-buffer buff)
+ )))))
+
+(defclass ede-linux-project (ede-project eieio-instance-tracker)
+ ((tracking-symbol :initform 'ede-linux-project-list)
+ )
+ "Project Type for the Linux source code."
+ :method-invocation-order :depth-first)
+
+(defun ede-linux-load (dir &optional rootproj)
+ "Return an Linux Project object if there is a match.
+Return nil if there isn't one.
+Argument DIR is the directory it is created for.
+ROOTPROJ is nil, since there is only one project."
+ (or (ede-linux-file-existing dir)
+ ;; Doesn't already exist, so lets make one.
+ (ede-linux-project "Linux"
+ :name (concat "Linux" (ede-linux-version dir))
+ :directory dir
+ :file (expand-file-name "scripts/ver_linux"
+ dir))
+ (ede-add-project-to-global-list this)
+ )
+ )
+
+(defclass ede-linux-target-c (ede-target)
+ ()
+ "EDE Linux Project target for C code.
+All directories need at least one target.")
+
+(defclass ede-linux-target-misc (ede-target)
+ ()
+ "EDE Linux Project target for Misc files.
+All directories need at least one target.")
+
+(defmethod initialize-instance ((this ede-linux-project)
+ &rest fields)
+ "Make sure the :file is fully expanded."
+ (call-next-method)
+ (unless (slot-boundp this 'targets)
+ (oset this :targets nil)))
+
+;;; File Stuff
+;;
+(defmethod ede-project-root-directory ((this ede-linux-project)
+ &optional file)
+ "Return the root for THIS Linux project with file."
+ (ede-up-directory (file-name-directory (oref this file))))
+
+(defmethod ede-project-root ((this ede-linux-project))
+ "Return my root."
+ this)
+
+(defmethod ede-find-subproject-for-directory ((proj ede-linux-project)
+ dir)
+ "Return PROJ, for handling all subdirs below DIR."
+ proj)
+
+;;; TARGET MANAGEMENT
+;;
+(defun ede-linux-find-matching-target (class dir targets)
+ "Find a target that is a CLASS and is in DIR in the list of TARGETS."
+ (let ((match nil))
+ (dolist (T targets)
+ (when (and (object-of-class-p T class)
+ (string= (oref T :path) dir))
+ (setq match T)
+ ))
+ match))
+
+(defmethod ede-find-target ((proj ede-linux-project) buffer)
+ "Find an EDE target in PROJ for BUFFER.
+If one doesn't exist, create a new one for this directory."
+ (let* ((ext (file-name-extension (buffer-file-name buffer)))
+ (cls (cond ((not ext)
+ 'ede-linux-target-misc)
+ ((string-match "c\\|h" ext)
+ 'ede-linux-target-c)
+ (t 'ede-linux-target-misc)))
+ (targets (oref proj targets))
+ (dir default-directory)
+ (ans (ede-linux-find-matching-target cls dir targets))
+ )
+ (when (not ans)
+ (setq ans (make-instance
+ cls
+ :name (file-name-nondirectory
+ (directory-file-name dir))
+ :path dir
+ :source nil))
+ (object-add-to-list proj :targets ans)
+ )
+ ans))
+
+;;; UTILITIES SUPPORT.
+;;
+(defmethod ede-preprocessor-map ((this ede-linux-target-c))
+ "Get the pre-processor map for Linux C code.
+All files need the macros from lisp.h!"
+ (require 'semantic/db)
+ (let* ((proj (ede-target-parent this))
+ (root (ede-project-root proj))
+ (versionfile (ede-expand-filename root "include/linux/version.h"))
+ (table (when (and versionfile (file-exists-p versionfile))
+ (semanticdb-file-table-object versionfile)))
+ (filemap '( ("__KERNEL__" . "")
+ ))
+ )
+ (when table
+ (when (semanticdb-needs-refresh-p table)
+ (semanticdb-refresh-table table))
+ (setq filemap (append filemap (oref table lexical-table)))
+ )
+ filemap
+ ))
+
+(defun ede-linux-file-exists-name (name root subdir)
+ "Return a file name if NAME exists under ROOT with SUBDIR in between."
+ (let ((F (expand-file-name name (expand-file-name subdir root))))
+ (when (file-exists-p F) F)))
+
+(defmethod ede-expand-filename-impl ((proj ede-linux-project) name)
+ "Within this project PROJ, find the file NAME.
+Knows about how the Linux source tree is organized."
+ (let* ((ext (file-name-extension name))
+ (root (ede-project-root proj))
+ (dir (ede-project-root-directory root))
+ (F (cond
+ ((not ext) nil)
+ ((string-match "h" ext)
+ (or (ede-linux-file-exists-name name dir "")
+ (ede-linux-file-exists-name name dir "include"))
+ )
+ ((string-match "txt" ext)
+ (ede-linux-file-exists-name name dir "Documentation"))
+ (t nil)))
+ )
+ (or F (call-next-method))))
+
+(provide 'ede/linux)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: ede/loaddefs
+;; generated-autoload-load-name: "ede/linux"
+;; End:
+
+;;; ede/linux.el ends here
Index: cedet/ede/locate.el
===================================================================
RCS file: cedet/ede/locate.el
diff -N cedet/ede/locate.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/locate.el 28 Sep 2009 15:15:06 -0000 1.2
@@ -0,0 +1,328 @@
+;;; ede/locate.el --- Locate support
+
+;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Support for various LOCATE type functions.
+;;
+;; A key feature of EDE is `ede-expand-filename', which allows a
+;; project to expand a filename reference in one file to some actual
+;; filename.
+;;
+;; In that way, you may #include <foo.h>, and without knowing how to
+;; read a Makefile, find it in <root>/include/foo.h.
+;;
+;; Some projects are regular, such as the Emacs project. Some
+;; projects are completely controlled by EDE, such sh the Project.ede
+;; based projects.
+;;
+;; For other projects, haveing a "quick hack" to support these location
+;; routines is handy.
+;;
+;; The baseclass `ede-locate-base' provides the abstract interface to
+;; finding files in a project.
+;;
+;; New location routines will subclass `ede-locate-base'.
+;;
+;; How to use:
+;;
+;; Configure `ede-locate-setup-options' to add the types of locate
+;; features you have available. EDE will then enable the correct one
+;; when it is available.
+
+(require 'ede)
+(eval-when-compile (require 'data-debug)
+ (require 'eieio-datadebug)
+ (require 'cedet-global)
+ (require 'cedet-idutils)
+ (require 'cedet-cscope))
+
+(require 'locate)
+
+;;; Code:
+(defcustom ede-locate-setup-options
+ '(ede-locate-base)
+ "List of locate objects to try out by default.
+Listed in order of preference. If the first item cannot be used in
+a particular project, then the next one is tried.
+It is always assumed that `ede-locate-base' is at end of the list."
+ :group 'ede
+ :type '(repeat
+ (choice (const :tag "None" ede-locate-base)
+ (const :tag "locate" ede-locate-locate)
+ (const :tag "GNU Global" ede-locate-global)
+ (const :tag "ID Utils" ede-locate-idutils)
+ (const :tag "CScope" ede-locate-cscope)))
+ )
+
+;;;###autoload
+(defun ede-enable-locate-on-project (&optional project)
+ "Enable an EDE locate feature on PROJECT.
+Attempt to guess which project locate style to use
+based on `ede-locate-setup-options'."
+ (interactive)
+ (let* ((proj (or project (ede-toplevel)))
+ (root (ede-project-root-directory proj))
+ (opts ede-locate-setup-options)
+ (ans nil))
+ (while (and opts (not ans))
+ (when (ede-locate-ok-in-project (car opts) root)
+ ;; If interactive, check with the user.
+ (when (or (not (interactive-p))
+ (y-or-n-p (format "Set project locator to %s? " (car opts))))
+ (setq ans (car opts))))
+ (setq opts (cdr opts)))
+ ;; No match? Always create the baseclass for the hashing tool.
+ (when (not ans)
+ (when (interactive-p)
+ (message "Setting locator to ede-locate-base"))
+ (setq ans 'ede-locate-base))
+ (oset proj locate-obj (make-instance ans "Loc" :root root))
+ (when (interactive-p)
+ (message "Satting locator to %s." ans))
+ ))
+
+;;; LOCATE BASECLASS
+;;
+;; The baseclass for all location style queries.
+(defclass ede-locate-base ()
+ ((root :initarg :root
+ :documentation
+ "The root of these locat searches.")
+ (file :documentation
+ "The last file search for with EDE locate.")
+ (lastanswer :documentation
+ "The last answer provided by the locator.")
+ (hash :documentation
+ "Hash table of previously found files.")
+ )
+ "Baseclass for LOCATE feature in EDE.")
+
+(defmethod initialize-instance ((loc ede-locate-base) &rest fields)
+ "Make sure we have a hash table."
+ ;; Basic setup.
+ (call-next-method)
+ ;; Make sure we have a hash table.
+ (oset loc hash (make-hash-table :test 'equal))
+ )
+
+(defmethod ede-locate-ok-in-project :static ((loc ede-locate-base)
+ root)
+ "Is it ok to use this project type under ROOT."
+ t)
+
+(defmethod ede-locate-file-in-hash ((loc ede-locate-base)
+ filestring)
+ "For LOC, is the file FILESTRING in our hashtable?"
+ (gethash filestring (oref loc hash)))
+
+(defmethod ede-locate-add-file-to-hash ((loc ede-locate-base)
+ filestring fullfilename)
+ "For LOC, add FILESTR to the hash with FULLFILENAME."
+ (puthash filestring fullfilename (oref loc hash)))
+
+(defmethod ede-locate-file-in-project ((loc ede-locate-base)
+ filesubstring
+ )
+ "Locate with LOC occurances of FILESUBSTRING.
+Searches are done under the current root of the EDE project
+that crated this ede locat object."
+ (let ((ans (ede-locate-file-in-project-impl loc filesubstring))
+ )
+ (oset loc file filesubstring)
+ (oset loc lastanswer ans)
+ ans))
+
+(defmethod ede-locate-file-in-project-impl ((loc ede-locate-base)
+ filesubstring
+ )
+ "Locate with LOC occurances of FILESUBSTRING.
+Searches are done under the current root of the EDE project
+that crated this ede locat object."
+ nil
+ )
+
+;;; LOCATE
+;;
+;; Using the standard unix "locate" command.
+;; Since locate is system wide, we need to hack the search
+;; to restrict it to within just this project.
+
+(defclass ede-locate-locate (ede-locate-base)
+ ()
+ "EDE Locator using the locate command.
+Configure the Emacs `locate-program' variable to also
+configure the use of EDE locate.")
+
+(defmethod ede-locate-ok-in-project :static ((loc ede-locate-locate)
+ root)
+ "Is it ok to use this project type under ROOT."
+ (or (featurep 'locate) (locate-library "locate"))
+ )
+
+(defmethod ede-locate-file-in-project-impl ((loc ede-locate-locate)
+ filesubstring)
+ "Locate with LOC occurances of FILESUBSTRING under PROJECTROOT.
+Searches are done under the current root of the EDE project
+that crated this ede locat object."
+ ;; We want something like:
+ ;; /my/project/root*/filesubstring.c
+ (let* ((searchstr (concat (directory-file-name (oref loc root))
+ "*/" filesubstring))
+ (b (get-buffer-create "*LOCATE*"))
+ (cd default-directory)
+ )
+ (save-excursion
+ (set-buffer b)
+ (setq default-directory cd)
+ (erase-buffer))
+ (apply 'call-process locate-command
+ nil b nil
+ searchstr nil)
+ (save-excursion
+ (set-buffer b)
+ (split-string (buffer-string) "\n" t))
+ )
+ )
+
+;;; GLOBAL
+;;
+(defclass ede-locate-global (ede-locate-base)
+ ()
+ "EDE Locator using GNU Global.
+Configure EDE's use of GNU Global through the cedet-global.el
+variable `cedet-global-command'.")
+
+(defmethod initialize-instance ((loc ede-locate-global)
+ &rest slots)
+ "Make sure that we can use GNU Global."
+ (require 'cedet-global)
+ ;; Get ourselves initialized.
+ (call-next-method)
+ ;; Do the checks.
+ (cedet-gnu-global-version-check)
+ (let* ((default-directory (oref loc root))
+ (root (cedet-gnu-global-root)))
+ (when (not root)
+ (error "Cannot use GNU Global in %s"
+ (oref loc root))))
+ )
+
+(defmethod ede-locate-ok-in-project :static ((loc ede-locate-global)
+ root)
+ "Is it ok to use this project type under ROOT."
+ (require 'cedet-global)
+ (cedet-gnu-global-version-check)
+ (let* ((default-directory root)
+ (newroot (cedet-gnu-global-root)))
+ newroot))
+
+(defmethod ede-locate-file-in-project-impl ((loc ede-locate-global)
+ filesubstring)
+ "Locate with LOC occurances of FILESUBSTRING under PROJECTROOT.
+Searches are done under the current root of the EDE project
+that crated this ede locat object."
+ (require 'cedet-global)
+ (let ((default-directory (oref loc root)))
+ (cedet-gnu-global-expand-filename filesubstring)))
+
+;;; IDUTILS
+;;
+(defclass ede-locate-idutils (ede-locate-base)
+ ()
+ "EDE Locator using IDUtils.
+Configure EDE's use of IDUtils through the cedet-idutils.el
+file name searching variable `cedet-idutils-file-command'.")
+
+(defmethod initialize-instance ((loc ede-locate-idutils)
+ &rest slots)
+ "Make sure that we can use IDUtils."
+ ;; Get ourselves initialized.
+ (call-next-method)
+ ;; Do the checks.
+ (require 'cedet-idutils)
+ (cedet-idutils-version-check)
+ (when (not (cedet-idutils-support-for-directory (oref loc root)))
+ (error "Cannot use IDUtils in %s"
+ (oref loc root)))
+ )
+
+(defmethod ede-locate-ok-in-project :static ((loc ede-locate-idutils)
+ root)
+ "Is it ok to use this project type under ROOT."
+ (require 'cedet-idutils)
+ (cedet-idutils-version-check)
+ (when (cedet-idutils-support-for-directory root)
+ root))
+
+(defmethod ede-locate-file-in-project-impl ((loc ede-locate-idutils)
+ filesubstring)
+ "Locate with LOC occurances of FILESUBSTRING under PROJECTROOT.
+Searches are done under the current root of the EDE project
+that crated this ede locat object."
+ (require 'cedet-idutils)
+ (let ((default-directory (oref loc root)))
+ (cedet-idutils-expand-filename filesubstring)))
+
+;;; CSCOPE
+;;
+(defclass ede-locate-cscope (ede-locate-base)
+ ()
+ "EDE Locator using Cscope.
+Configure EDE's use of Cscope through the cedet-cscope.el
+file name searching variable `cedet-cscope-file-command'.")
+
+(defmethod initialize-instance ((loc ede-locate-cscope)
+ &rest slots)
+ "Make sure that we can use Cscope."
+ ;; Get ourselves initialized.
+ (call-next-method)
+ ;; Do the checks.
+ (cedet-cscope-version-check)
+ (when (not (cedet-cscope-support-for-directory (oref loc root)))
+ (error "Cannot use Cscope in %s"
+ (oref loc root)))
+ )
+
+(defmethod ede-locate-ok-in-project :static ((loc ede-locate-cscope)
+ root)
+ "Is it ok to use this project type under ROOT."
+ (cedet-cscope-version-check)
+ (when (cedet-cscope-support-for-directory root)
+ root))
+
+(defmethod ede-locate-file-in-project-impl ((loc ede-locate-cscope)
+ filesubstring)
+ "Locate with LOC occurances of FILESUBSTRING under PROJECTROOT.
+Searches are done under the current root of the EDE project
+that crated this ede locat object."
+ (let ((default-directory (oref loc root)))
+ (cedet-cscope-expand-filename filesubstring)))
+
+(provide 'ede/locate)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: ede/loaddefs
+;; generated-autoload-load-name: "ede/locate"
+;; End:
+
+;;; ede/locate.el ends here
Index: cedet/ede/make.el
===================================================================
RCS file: cedet/ede/make.el
diff -N cedet/ede/make.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/make.el 28 Sep 2009 15:15:06 -0000 1.2
@@ -0,0 +1,110 @@
+;;; ede/make.el --- General information about "make"
+
+;;; Copyright (C) 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; This file needs to choose the version of "make" it wants to use.
+;; Whenever an executable "gmake" is available, we prefer that since
+;; it usually means GNU Make. If it doesn't exist, use "make".
+;;
+;; Run tests on make --version to be sure it is GNU make so that
+;; logical error messages can be provided.
+
+;;; Code:
+
+(declare-function inversion-check-version "inversion")
+
+(if (fboundp 'locate-file)
+ (defsubst ede--find-executable (exec)
+ "Return an expanded file name for a program EXEC on the exec path."
+ (locate-file exec exec-path))
+
+ ;; Else, older version of Emacs.
+
+ (defsubst ede--find-executable (exec)
+ "Return an expanded file name for a program EXEC on the exec path."
+ (let ((p exec-path)
+ (found nil))
+ (while (and p (not found))
+ (let ((f (expand-file-name exec (car p))))
+ (if (file-exists-p f)
+ (setq found f)))
+ (setq p (cdr p)))
+ found))
+ )
+
+(defvar ede-make-min-version "3.0"
+ "Minimum version of GNU make required.")
+
+(defcustom ede-make-command (cond ((ede--find-executable "gmake")
+ "gmake")
+ (t "make")) ;; What to do?
+ "The MAKE command to use for EDE when compiling.
+The makefile generated by EDE for C files uses syntax that depends on GNU Make,
+so this should be set to something that can execute GNU Make files."
+ :group 'ede
+ :type 'string)
+
+;;;###autoload
+(defun ede-make-check-version (&optional noerror)
+ "Check the version of GNU Make installed.
+The check passes if the MAKE version is no high enough, or if it
+is not GNU make.
+If NOERROR is non-nil, return t for success, nil for failure.
+If NOERROR is nil, then throw an error on failure. Return t otherwise."
+ (interactive)
+ (let ((b (get-buffer-create "*EDE Make Version*"))
+ (cd default-directory)
+ (rev nil)
+ (ans nil)
+ )
+ (save-excursion
+ ;; Setup, and execute make.
+ (set-buffer b)
+ (setq default-directory cd)
+ (erase-buffer)
+ (call-process ede-make-command nil b nil
+ "--version")
+ ;; Check the buffer for the string
+ (goto-char (point-min))
+ (when (looking-at "GNU Make\\(?: version\\)? \\([0-9][^,]+\\),")
+ (setq rev (match-string 1))
+ (require 'inversion)
+ (setq ans (not (inversion-check-version rev nil ede-make-min-version))))
+
+ ;; Answer reporting.
+ (when (and (interactive-p) ans)
+ (message "GNU Make version %s. Good enough for CEDET." rev))
+
+ (when (and (not noerror) (not ans))
+ (error "EDE requires GNU Make version %s or later. Configure
`ede-make-command' to fix"
+ ede-make-min-version))
+ ans)))
+
+(provide 'ede/make)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: ede/loaddefs
+;; generated-autoload-load-name: "ede/make"
+;; End:
+
+;;; ede/make.el ends here
Index: cedet/ede/makefile-edit.el
===================================================================
RCS file: cedet/ede/makefile-edit.el
diff -N cedet/ede/makefile-edit.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/makefile-edit.el 28 Sep 2009 15:15:06 -0000 1.2
@@ -0,0 +1,129 @@
+;;; makefile-edit.el --- Makefile editing/scanning commands.
+
+;;; Copyright (C) 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Utilities for editing a Makefile for EDE Makefile management commands.
+;;
+;; Derived from project-am.el.
+;;
+;; Makefile editing and scanning commands
+;;
+;; Formatting of a makefile
+;;
+;; 1) Creating an automakefile, stick in a top level comment about
+;; being created by emacs
+;; 2) Leave order of variable contents alone, except for SOURCE
+;; SOURCE always keep in the order of .c, .h, the other stuff.
+
+;;; Things to do
+;; makefile-fill-paragraph -- refill a macro w/ backslashes
+;; makefile-insert-macro -- insert "foo = "
+
+
+;;; Code:
+
+(defun makefile-beginning-of-command ()
+ "Move the the beginning of the current command."
+ (interactive)
+ (if (save-excursion
+ (forward-line -1)
+ (makefile-line-continued-p))
+ (forward-line -1))
+ (beginning-of-line)
+ (if (not (makefile-line-continued-p))
+ nil
+ (while (and (makefile-line-continued-p)
+ (not (bobp)))
+ (forward-line -1))
+ (forward-line 1)))
+
+(defun makefile-end-of-command ()
+ "Move the the beginning of the current command."
+ (interactive)
+ (end-of-line)
+ (while (and (makefile-line-continued-p)
+ (not (eobp)))
+ (forward-line 1)
+ (end-of-line)))
+
+(defun makefile-line-continued-p ()
+ "Return non-nil if the current line ends in continuation."
+ (save-excursion
+ (end-of-line)
+ (= (preceding-char) ?\\)))
+
+;;; Programatic editing of a Makefile
+;;
+(defun makefile-move-to-macro (macro &optional next)
+ "Move to the definition of MACRO. Return t if found.
+If NEXT is non-nil, move to the next occurance of MACRO."
+ (let ((oldpt (point)))
+ (when (not next) (goto-char (point-min)))
+ (if (re-search-forward (concat "^\\s-*" macro "\\s-*[+:?]?=") nil t)
+ t
+ (goto-char oldpt)
+ nil)))
+
+(defun makefile-navigate-macro (stop-before)
+ "In a list of files, move forward until STOP-BEFORE is reached.
+STOP-BEFORE is a regular expression matching a file name."
+ (save-excursion
+ (makefile-beginning-of-command)
+ (let ((e (save-excursion
+ (makefile-end-of-command)
+ (point))))
+ (if (re-search-forward stop-before nil t)
+ (goto-char (match-beginning 0))
+ (goto-char e)))))
+
+(defun makefile-macro-file-list (macro)
+ "Return a list of all files in MACRO."
+ (save-excursion
+ (goto-char (point-min))
+ (let ((lst nil))
+ (while (makefile-move-to-macro macro t)
+ (let ((e (save-excursion
+ (makefile-end-of-command)
+ (point))))
+ (while (re-search-forward
"\\s-**\\([-a-zA-Z0-9./address@hidden(){}]+\\)\\s-*" e t)
+ (let ((var nil)(varexp nil)
+ (match (buffer-substring-no-properties
+ (match-beginning 1)
+ (match-end 1))))
+ (if (not (setq var (makefile-extract-varname-from-text match)))
+ (setq lst (cons match lst))
+ (setq varexp (makefile-macro-file-list var))
+ (dolist (V varexp)
+ (setq lst (cons V lst))))))))
+ (nreverse lst))))
+
+(defun makefile-extract-varname-from-text (text)
+ "Extract the variable name from TEXT if it is a variable reference.
+Return nil if it isn't a variable."
+ (save-match-data
+ (when (string-match "\\$\\s(\\([A-Za-z0-9_]+\\)\\s)" text)
+ (match-string 1 text))))
+
+
+(provide 'ede/makefile-edit)
+
+;;; ede/makefile-edit.el ends here
Index: cedet/ede/pconf.el
===================================================================
RCS file: cedet/ede/pconf.el
diff -N cedet/ede/pconf.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/pconf.el 28 Sep 2009 15:15:06 -0000 1.2
@@ -0,0 +1,188 @@
+;;; ede/pconf.el --- configure.ac maintenance for EDE
+
+;;; Copyright (C) 1998, 1999, 2000, 2005, 2008, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: project
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Code generator for autoconf configure.ac, and support files.
+
+(require 'ede/proj)
+(require 'ede/autoconf-edit)
+(defvar compilation-in-progress)
+
+(defvar ede-pconf-create-file-query 'ask
+ "Controls if queries are made while creating project files.
+A value of 'ask means to always ask the user before creating
+a file, such as AUTHORS. A value of 'never means don't ask, and
+don't do it. A value of nil means to just do it.")
+
+;;; Code:
+(defmethod ede-proj-configure-file ((this ede-proj-project))
+ "The configure.ac script used by project THIS."
+ (ede-expand-filename (ede-toplevel this) "configure.ac" t))
+
+(defmethod ede-proj-configure-test-required-file ((this ede-proj-project) file)
+ "For project THIS, test that the file FILE exists, or create it."
+ (when (not (ede-expand-filename (ede-toplevel this) file))
+ (save-excursion
+ (find-file (ede-expand-filename (ede-toplevel this) file t))
+ (cond ((string= file "AUTHORS")
+ (insert (user-full-name) " <" (user-login-name) ">"))
+ ((string= file "NEWS")
+ (insert "NEWS file for " (ede-name this)))
+ (t (insert "\n")))
+ (save-buffer)
+ (when
+ (and (eq ede-pconf-create-file-query 'ask)
+ (not (eq ede-pconf-create-file-query 'never))
+ (not (y-or-n-p
+ (format "I had to create the %s file for you. Ok? "
file)))
+ (error "Quit"))))))
+
+
+(defmethod ede-proj-configure-synchronize ((this ede-proj-project))
+ "Synchronize what we know about project THIS into configure.ac."
+ (let ((b (find-file-noselect (ede-proj-configure-file this)))
+ ;;(td (file-name-directory (ede-proj-configure-file this)))
+ (targs (oref this targets))
+ (postcmd "")
+ (add-missing nil))
+ ;; First, make sure we have a file.
+ (if (not (file-exists-p (ede-proj-configure-file this)))
+ (autoconf-new-program b (oref this name) "Project.ede"))
+ (set-buffer b)
+ ;; Next, verify all targets of all subobjects.
+ (autoconf-set-version (oref this version))
+ (let ((top-level-project-local this))
+ (autoconf-set-output
+ (ede-map-all-subprojects
+ this
+ (lambda (sp)
+ ;; NOTE: don't put in ./Makefile - configure complains.
+ (let ((dir (file-name-as-directory
+ (directory-file-name
+ (ede-subproject-relative-path sp
top-level-project-local)))))
+ (when (string= dir "./") (setq dir ""))
+ ;; Use concat, because expand-file-name removes the relativeness.
+ (concat dir "Makefile") )))))
+ ;;
+ ;; NOTE TO SELF. TURN THIS INTO THE OFFICIAL LIST
+ ;;
+ (ede-proj-dist-makefile this)
+ ;; Loop over all targets to clean and then add themselves in.
+ (ede-map-all-subprojects
+ this
+ (lambda (sp)
+ (ede-map-targets sp 'ede-proj-flush-autoconf)))
+ (ede-map-all-subprojects
+ this
+ (lambda (sp)
+ (ede-map-targets this 'ede-proj-tweak-autoconf)))
+ ;; Now save
+ (save-buffer)
+ ;; Verify aclocal
+ (setq postcmd "aclocal;")
+ ;; Always add missing files as needed.
+ (setq postcmd (concat postcmd "automake --add-missing;"))
+
+ ;; Always do autoreconf
+ (setq postcmd (concat postcmd "autoreconf;"))
+ ;; Verify a bunch of files that are required by automake.
+ (ede-proj-configure-test-required-file this "AUTHORS")
+ (ede-proj-configure-test-required-file this "NEWS")
+ (ede-proj-configure-test-required-file this "README")
+ (ede-proj-configure-test-required-file this "ChangeLog")
+ ;; Let specific targets get missing files.
+ (mapc 'ede-proj-configure-create-missing targs)
+ ;; Verify that we have a make system.
+ (if (or (not (ede-expand-filename (ede-toplevel this) "Makefile"))
+ ;; Now is this one of our old Makefiles?
+ (save-excursion
+ (set-buffer (find-file-noselect
+ (ede-expand-filename (ede-toplevel this)
+ "Makefile" t) t))
+ (goto-char (point-min))
+ ;; Here is the unique piece for our makefiles.
+ (re-search-forward "For use with: make" nil t)))
+ (setq postcmd (concat postcmd "./configure;")))
+ (if (not (string= "" postcmd))
+ (progn
+ (compile postcmd)
+
+ (while compilation-in-progress
+ (accept-process-output)
+ (sit-for 1))
+
+ (save-excursion
+ (set-buffer "*compilation*")
+ (goto-char (point-max))
+
+ (when (not (string= mode-line-process ":exit [0]"))
+ (error "Configure failed!"))
+
+ ;; The Makefile is now recreated by configure?
+ (let ((b (get-file-buffer
+ (ede-expand-filename (ede-toplevel this)
+ "Makefile" 'newfile))))
+ ;; This makes sure that if Makefile was loaded, and old,
+ ;; that it gets flushed so we don't keep rebuilding
+ ;; the autoconf system.
+ (if b (kill-buffer b))))
+
+ ))))
+
+(defmethod ede-proj-configure-recreate ((this ede-proj-project))
+ "Delete project THISes configure script and start over."
+ (if (not (ede-proj-configure-file this))
+ (error "Could not determine configure.ac for %S" (object-name this)))
+ (let ((b (get-file-buffer (ede-proj-configure-file this))))
+ ;; Destroy all evidence of the old configure.ac
+ (delete-file (ede-proj-configure-file this))
+ (if b (kill-buffer b)))
+ (ede-proj-configure-synchronize this))
+
+(defmethod ede-proj-tweak-autoconf ((this ede-proj-target))
+ "Tweak the configure file (current buffer) to accomodate THIS."
+ ;; Check the compilers belonging to THIS, and call the autoconf
+ ;; setup for those compilers.
+ (mapc 'ede-proj-tweak-autoconf (ede-proj-compilers this))
+ (mapc 'ede-proj-tweak-autoconf (ede-proj-linkers this))
+ )
+
+(defmethod ede-proj-flush-autoconf ((this ede-proj-target))
+ "Flush the configure file (current buffer) to accomodate THIS.
+By flushing, remove any cruft that may be in the file. Subsequent
+calls to `ede-proj-tweak-autoconf' can restore items removed by flush."
+ nil)
+
+(defmethod ede-proj-configure-add-missing ((this ede-proj-target))
+ "Query if any files needed by THIS provided by automake are missing.
+Results in --add-missing being passed to automake."
+ nil)
+
+(defmethod ede-proj-configure-create-missing ((this ede-proj-target))
+ "Add any missing files for THIS by creating them."
+ nil)
+
+(provide 'ede/pconf)
+
+;;; ede/pconf.el ends here
Index: cedet/ede/pmake.el
===================================================================
RCS file: cedet/ede/pmake.el
diff -N cedet/ede/pmake.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/pmake.el 28 Sep 2009 15:15:06 -0000 1.2
@@ -0,0 +1,663 @@
+;;; ede-pmake.el --- EDE Generic Project Makefile code generator.
+
+;;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+;;; 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: project, make
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Code generator for Makefiles.
+;;
+;; Here is how it should work:
+;; 1) Collect information about the project and targets
+;; 2) Insert header into the Makefile
+;; 3) Insert basic variables (target/source)
+;; 4) Conditional
+;; a) Makefile
+;; 1) Insert support variables (compiler variables, etc)
+;; 2) Insert VERSION and DISTDIR
+;; 3) Specify top build dir if necessary
+;; 4) Specify compile/link commands (c, etc)
+;; 5) Specify dependency files
+;; 6) Specify all: target
+;; 7) Include dependency files
+;; 8) Insert commonized target specify rules
+;; 9) Insert clean: and dist: rules
+;; b) Automake file
+;; 1) Insert distribution source variables for targets
+;; 2) Insert user requested rules
+
+(require 'ede/proj)
+(require 'ede/proj-obj)
+(require 'ede/proj-comp)
+
+(declare-function ede-srecode-setup "ede/srecode")
+(declare-function ede-srecode-insert "ede/srecode")
+
+;;; Code:
+(defmethod ede-proj-makefile-create ((this ede-proj-project) mfilename)
+ "Create a Makefile for all Makefile targets in THIS.
+MFILENAME is the makefile to generate."
+ (require 'ede/srecode)
+ (let ((mt nil)
+ (isdist (string= mfilename (ede-proj-dist-makefile this)))
+ (depth 0)
+ (orig-buffer nil)
+ (buff-to-kill nil)
+ )
+ ;; Find out how deep this project is.
+ (let ((tmp this))
+ (while (setq tmp (ede-parent-project tmp))
+ (setq depth (1+ depth))))
+ ;; Collect the targets that belong in a makefile.
+ (mapc
+ (lambda (obj)
+ (if (and (obj-of-class-p obj 'ede-proj-target-makefile)
+ (string= (oref obj makefile) mfilename))
+ (setq mt (cons obj mt))))
+ (oref this targets))
+ ;; Fix the order so things compile in the right direction.
+ (setq mt (nreverse mt))
+ ;; Add in the header part of the Makefile*
+ (save-excursion
+ (setq orig-buffer (get-file-buffer mfilename))
+ (set-buffer (setq buff-to-kill (find-file-noselect mfilename)))
+ (goto-char (point-min))
+ (if (and
+ (not (eobp))
+ (not (looking-at "# Automatically Generated \\w+ by EDE.")))
+ (if (not (y-or-n-p (format "Really replace %s? " mfilename)))
+ (error "Not replacing Makefile"))
+ (message "Replace EDE Makefile"))
+ (erase-buffer)
+ (ede-srecode-setup)
+ ;; Insert a giant pile of stuff that is common between
+ ;; one of our Makefiles, and a Makefile.in
+ (ede-srecode-insert
+ "file:ede-empty"
+ "MAKETYPE"
+ (with-slots (makefile-type) this
+ (cond ((eq makefile-type 'Makefile) "make")
+ ((eq makefile-type 'Makefile.in) "autoconf")
+ ((eq makefile-type 'Makefile.am) "automake")
+ (t (error ":makefile-type in project invalid")))))
+
+ ;; Just this project's variables
+ (ede-proj-makefile-insert-variables this)
+
+ ;; Space
+ (insert "\n")
+
+ (cond
+ ((eq (oref this makefile-type) 'Makefile)
+ ;; Make sure the user has the right kind of make
+ (ede-make-check-version)
+
+ (let* ((targ (if isdist (oref this targets) mt))
+ (sp (oref this subproj))
+ (df (apply 'append
+ (mapcar (lambda (tg)
+ (ede-proj-makefile-dependency-files tg))
+ targ))))
+ ;; Distribution variables
+ (ede-compiler-begin-unique
+ (mapc 'ede-proj-makefile-insert-variables targ))
+ ;; Only add the distribution stuff in when depth != 0
+ (let ((top (ede-toplevel this))
+ (tmp this)
+ (subdir ""))
+ (insert "VERSION=" (oref top version) "\n"
+ "DISTDIR=$(top)" (oref top name) "-$(VERSION)")
+ (while (ede-parent-project tmp)
+ (setq subdir
+ (concat
+ "/"
+ (file-name-nondirectory
+ (directory-file-name
+ (file-name-directory (oref tmp file))))
+ subdir)
+ tmp (ede-parent-project tmp)))
+ (insert subdir "\n"))
+ ;; Some built in variables for C code
+ (if df
+ (let ((tc depth))
+ (insert "top_builddir = ")
+ (while (/= 0 tc)
+ (setq tc (1- tc))
+ (insert "..")
+ (if (/= tc 0) (insert "/")))
+ (insert "\n")))
+ (insert "\n")
+ ;; Create a variable with all the dependency files to include
+ ;; These methods borrowed from automake.
+ (if (and (oref this automatic-dependencies) df)
+ (progn
+ (insert "DEP_FILES="
+ (mapconcat (lambda (f)
+ (concat ".deps/"
+ (file-name-nondirectory
+ (file-name-sans-extension
+ f)) ".P"))
+ df " "))))
+ ;;
+ ;; Insert ALL Rule
+ ;;
+ (insert "\n\nall:")
+ (mapc (lambda (c)
+ (if (and (slot-exists-p c 'partofall) (oref c partofall))
+ ;; Only insert this rule if it is a part of ALL.
+ (insert " " (ede-proj-makefile-target-name c))))
+ targ)
+ (mapc (lambda (c)
+ (insert " " (ede-name c))
+ )
+ sp)
+ (insert "\n\n")
+ ;;
+ ;; Add in the include files
+ ;;
+ (mapc (lambda (c)
+ (insert "include " c "\n\n"))
+ (oref this include-file))
+ ;; Some C inference rules
+ ;; Dependency rules borrowed from automake.
+ ;;
+ ;; NOTE: This is GNU Make specific.
+ (if (and (oref this automatic-dependencies) df)
+ (insert "DEPS_MAGIC := $(shell mkdir .deps > /dev/null "
+ "2>&1 || :)\n"
+ "-include $(DEP_FILES)\n\n"))
+ ;;
+ ;; General makefile rules stored in the individual targets
+ ;;
+ (ede-compiler-begin-unique
+ (ede-proj-makefile-insert-rules this)
+ (mapc 'ede-proj-makefile-insert-rules targ))
+ ;;
+ ;; phony targets for sub projects
+ ;;
+ (mapc 'ede-proj-makefile-insert-subproj-rules sp)
+ ;;
+ ;; Distribution rules such as CLEAN and DIST
+ ;;
+ (when isdist
+ (ede-proj-makefile-tags this mt)
+ (ede-proj-makefile-insert-dist-rules this)))
+ (save-buffer))
+ ((eq (oref this makefile-type) 'Makefile.in)
+ (error "Makefile.in is not supported"))
+ ((eq (oref this makefile-type) 'Makefile.am)
+ (require 'ede/pconf)
+ ;; Distribution variables
+ (let ((targ (if isdist (oref this targets) mt)))
+ (ede-compiler-begin-unique
+ (mapc 'ede-proj-makefile-insert-automake-pre-variables targ))
+ (ede-compiler-begin-unique
+ (mapc 'ede-proj-makefile-insert-source-variables targ))
+ (ede-compiler-begin-unique
+ (mapc 'ede-proj-makefile-insert-automake-post-variables targ))
+ (ede-compiler-begin-unique
+ (ede-proj-makefile-insert-user-rules this))
+ (insert "\n# End of Makefile.am\n")
+ (save-buffer))
+ )
+ (t (error "Unknown makefile type when generating Makefile")))
+ ;; Put the cursor in a nice place
+ (goto-char (point-min)))
+ ;; If we have an original buffer, then don't kill it.
+ (when (not orig-buffer)
+ (kill-buffer buff-to-kill))
+ ))
+
+;;; VARIABLE insertion
+;;
+(defun ede-pmake-end-of-variable ()
+ "Move to the end of the variable declaration under point."
+ (end-of-line)
+ (while (= (preceding-char) ?\\)
+ (forward-char 1)
+ (end-of-line))
+ )
+
+(defmacro ede-pmake-insert-variable-shared (varname &rest body)
+ "Add VARNAME into the current Makefile.
+Execute BODY in a location where a value can be placed."
+ `(let ((addcr t) (v ,varname))
+ (if (re-search-backward (concat "^" v "\\s-*=") nil t)
+ (progn
+ (ede-pmake-end-of-variable)
+ (if (< (current-column) 40)
+ (if (and (/= (preceding-char) ?=)
+ (/= (preceding-char) ? ))
+ (insert " "))
+ (insert "\\\n "))
+ (setq addcr nil))
+ (insert v "="))
+ ,@body
+ (if addcr (insert "\n"))
+ (goto-char (point-max))))
+(put 'ede-pmake-insert-variable-shared 'lisp-indent-function 1)
+
+;;; SOURCE VARIABLE NAME CONSTRUCTION
+
+(defsubst ede-pmake-varname (obj)
+ "Convert OBJ into a variable name name.
+Change . to _ in the variable name."
+ (let ((name (oref obj name)))
+ (while (string-match "\\." name)
+ (setq name (replace-match "_" nil t name)))
+ name))
+
+(defmethod ede-proj-makefile-sourcevar ((this ede-proj-target))
+ "Return the variable name for THIS's sources."
+ (concat (ede-pmake-varname this) "_YOU_FOUND_A_BUG"))
+
+;;; DEPENDENCY FILE GENERATOR LISTS
+;;
+(defmethod ede-proj-makefile-dependency-files ((this ede-proj-target))
+ "Return a list of source files to convert to dependencies.
+Argument THIS is the target to get sources from."
+ nil)
+
+;;; GENERIC VARIABLES
+;;
+(defmethod ede-proj-makefile-configuration-variables ((this ede-proj-project)
+ configuration)
+ "Return a list of configuration variables from THIS.
+Use CONFIGURATION as the current configuration to query."
+ (cdr (assoc configuration (oref this configuration-variables))))
+
+(defmethod ede-proj-makefile-insert-variables-new ((this ede-proj-project))
+ "Insert variables needed by target THIS.
+
+NOTE: Not yet in use! This is part of an SRecode conversion of
+ EDE that is in progress."
+; (let ((conf-table (ede-proj-makefile-configuration-variables
+; this (oref this configuration-default)))
+; (conf-done nil))
+;
+; (ede-srecode-insert-with-dictionary
+; "declaration:ede-vars"
+;
+; ;; Insert all variables, and augment them with details from
+; ;; the current configuration.
+; (mapc (lambda (c)
+;
+; (let ((ldict (srecode-dictionary-add-section-dictionary
+; dict "VARIABLE"))
+; )
+; (srecode-dictionary-set-value ldict "NAME" (car c))
+; (if (assoc (car c) conf-table)
+; (let ((vdict (srecode-dictionary-add-section-dictionary
+; ldict "VALUE")))
+; (srecode-dictionary-set-value
+; vdict "VAL" (cdr (assoc (car c) conf-table)))
+; (setq conf-done (cons (car c) conf-done))))
+; (let ((vdict (srecode-dictionary-add-section-dictionary
+; ldict "VALUE")))
+; (srecode-dictionary-set-value vdict "VAL" (cdr c))))
+; )
+;
+; (oref this variables))
+;
+; ;; Add in all variables from the configuration not allready covered.
+; (mapc (lambda (c)
+;
+; (if (member (car c) conf-done)
+; nil
+; (let* ((ldict (srecode-dictionary-add-section-dictionary
+; dict "VARIABLE"))
+; (vdict (srecode-dictionary-add-section-dictionary
+; ldict "VALUE"))
+; )
+; (srecode-dictionary-set-value ldict "NAME" (car c))
+; (srecode-dictionary-set-value vdict "VAL" (cdr c))))
+; )
+;
+; conf-table)
+;
+
+ ;; @TODO - finish off this function, and replace the below fcn
+
+; ))
+ )
+
+(defmethod ede-proj-makefile-insert-variables ((this ede-proj-project))
+ "Insert variables needed by target THIS."
+ (let ((conf-table (ede-proj-makefile-configuration-variables
+ this (oref this configuration-default)))
+ (conf-done nil))
+ ;; Insert all variables, and augment them with details from
+ ;; the current configuration.
+ (mapc (lambda (c)
+ (insert (car c) "=")
+ (if (assoc (car c) conf-table)
+ (progn
+ (insert (cdr (assoc (car c) conf-table)) " ")
+ (setq conf-done (cons (car c) conf-done))))
+ (insert (cdr c) "\n"))
+ (oref this variables))
+ ;; Add in all variables from the configuration not allready covered.
+ (mapc (lambda (c)
+ (if (member (car c) conf-done)
+ nil
+ (insert (car c) "=" (cdr c) "\n")))
+ conf-table))
+ (let* ((top "")
+ (tmp this))
+ (while (ede-parent-project tmp)
+ (setq tmp (ede-parent-project tmp)
+ top (concat "../" top)))
+ (insert "\ntop=" top))
+ (insert "\nede_FILES=" (file-name-nondirectory (oref this file)) " "
+ (file-name-nondirectory (ede-proj-dist-makefile this)) "\n"))
+
+(defmethod ede-proj-makefile-insert-source-variables ((this ede-proj-target)
+ &optional
+ moresource)
+ "Insert the source variables needed by THIS.
+Optional argument MORESOURCE is a list of additional sources to add to the
+sources variable."
+ (let ((sv (ede-proj-makefile-sourcevar this)))
+ ;; This variable may be shared between targets
+ (ede-pmake-insert-variable-shared (cond ((listp sv) (car sv))
+ (t sv))
+ (insert (mapconcat (lambda (a) a) (oref this source) " "))
+ (if moresource
+ (insert " \\\n " (mapconcat (lambda (a) a) moresource " ") "")))))
+
+(defmethod ede-proj-makefile-insert-variables ((this ede-proj-target) &optional
+ moresource)
+ "Insert variables needed by target THIS.
+Optional argument MORESOURCE is a list of additional sources to add to the
+sources variable."
+ (ede-proj-makefile-insert-source-variables this moresource)
+ )
+
+(defmethod ede-proj-makefile-configuration-variables ((this
ede-proj-target-makefile)
+ configuration)
+ "Return a list of configuration variables from THIS.
+Use CONFIGURATION as the current configuration to query."
+ (cdr (assoc configuration (oref this configuration-variables))))
+
+(defmethod ede-proj-makefile-insert-variables ((this ede-proj-target-makefile)
+ &optional moresource)
+ "Insert variables needed by target THIS.
+Optional argument MORESOURCE is a list of additional sources to add to the
+sources variable."
+ (call-next-method)
+ (let* ((proj (ede-target-parent this))
+ (conf-table (ede-proj-makefile-configuration-variables
+ this (oref proj configuration-default)))
+ (conf-done nil)
+ )
+ ;; Add in all variables from the configuration not allready covered.
+ (mapc (lambda (c)
+ (if (member (car c) conf-done)
+ nil
+ (insert (car c) "=" (cdr c) "\n")))
+ conf-table))
+ (let ((comp (ede-proj-compilers this))
+ (link (ede-proj-linkers this))
+ (name (ede-proj-makefile-target-name this))
+ (src (oref this source)))
+ (while comp
+ (ede-compiler-only-once (car comp)
+ (ede-proj-makefile-insert-object-variables (car comp) name src)
+ (ede-proj-makefile-insert-variables (car comp)))
+ (setq comp (cdr comp)))
+ (while link
+ (ede-linker-only-once (car link)
+ (ede-proj-makefile-insert-variables (car link)))
+ (setq link (cdr link)))))
+
+(defmethod ede-proj-makefile-insert-automake-pre-variables
+ ((this ede-proj-target))
+ "Insert variables needed by target THIS in Makefile.am before SOURCES."
+ nil)
+
+(defmethod ede-proj-makefile-insert-automake-post-variables
+ ((this ede-proj-target))
+ "Insert variables needed by target THIS in Makefile.am after SOURCES."
+ nil)
+
+;;; GARBAGE PATTERNS
+;;
+(defmethod ede-proj-makefile-garbage-patterns ((this ede-proj-project))
+ "Return a list of patterns that are considered garbage to THIS.
+These are removed with make clean."
+ (let ((mc (ede-map-targets
+ this (lambda (c) (ede-proj-makefile-garbage-patterns c))))
+ (uniq nil))
+ (setq mc (sort (apply 'append mc) 'string<))
+ ;; Filter out duplicates from the targets.
+ (while mc
+ (if (and (car uniq) (string= (car uniq) (car mc)))
+ nil
+ (setq uniq (cons (car mc) uniq)))
+ (setq mc (cdr mc)))
+ (nreverse uniq)))
+
+(defmethod ede-proj-makefile-garbage-patterns ((this ede-proj-target))
+ "Return a list of patterns that are considered garbage to THIS.
+These are removed with make clean."
+ ;; Get the the source object from THIS, and use the specified garbage.
+ (let ((src (ede-target-sourcecode this))
+ (garb nil))
+ (while src
+ (setq garb (append (oref (car src) garbagepattern) garb)
+ src (cdr src)))
+ garb))
+
+
+;;; RULES
+;;
+(defmethod ede-proj-makefile-insert-subproj-rules ((this ede-proj-project))
+ "Insert a rule for the project THIS which should be a subproject."
+ (insert ".PHONY:" (ede-name this))
+ (newline)
+ (insert (ede-name this) ":")
+ (newline)
+ (insert "\t$(MAKE) -C " (directory-file-name (ede-subproject-relative-path
this)))
+ (newline)
+ (newline)
+ )
+
+(defmethod ede-proj-makefile-insert-rules ((this ede-proj-project))
+ "Insert rules needed by THIS target."
+ (mapc 'ede-proj-makefile-insert-rules (oref this inference-rules))
+ )
+
+(defmethod ede-proj-makefile-insert-dist-dependencies ((this ede-proj-project))
+ "Insert any symbols that the DIST rule should depend on.
+Argument THIS is the project that should insert stuff."
+ (mapc 'ede-proj-makefile-insert-dist-dependencies (oref this targets))
+ )
+
+(defmethod ede-proj-makefile-insert-dist-dependencies ((this ede-proj-target))
+ "Insert any symbols that the DIST rule should depend on.
+Argument THIS is the target that should insert stuff."
+ nil)
+
+(defmethod ede-proj-makefile-insert-dist-filepatterns ((this ede-proj-target))
+ "Insert any symbols that the DIST rule should depend on.
+Argument THIS is the target that should insert stuff."
+ (ede-proj-makefile-insert-dist-dependencies this)
+ )
+
+(defmethod ede-proj-makefile-insert-dist-rules ((this ede-proj-project))
+ "Insert distribution rules for THIS in a Makefile, such as CLEAN and DIST."
+ (let ((junk (ede-proj-makefile-garbage-patterns this))
+ tmp)
+ ;; Build CLEAN, DIST, TAG, and other rules here.
+ (if junk
+ (insert "\nclean:\n"
+ "\trm -f "
+ (mapconcat (lambda (c) c) junk " ")
+ "\n\n"))
+ ;; @TODO: ^^^ Clean should also recurse. ^^^
+
+ (insert ".PHONY: dist\n")
+ (insert "\ndist:")
+ (ede-proj-makefile-insert-dist-dependencies this)
+ (insert "\n")
+ (unless (or (ede-subproject-p this)
+ (oref this metasubproject))
+ ;; Only delete if we are the toplevel project.
+ (insert "\trm -rf $(DISTDIR)\n"))
+ (insert "\tmkdir $(DISTDIR)\n") ;We may need a -p, but I think not.
+ (setq tmp (oref this targets))
+ (insert "\tcp")
+ (while tmp
+ (let ((sv (ede-proj-makefile-sourcevar (car tmp))))
+ (if (listp sv)
+ ;; Handle special case variables.
+ (cond ((eq (cdr sv) 'share)
+ ;; This variable may be shared between multiple targets.
+ (if (re-search-backward (concat "\\$(" (car sv) ")")
+ (save-excursion
+ (beginning-of-line)
+ (point))
+ t)
+ ;; If its already in the dist target, then skip it.
+ nil
+ (setq sv (car sv))))
+ (t (setq sv (car sv)))))
+ (if (stringp sv)
+ (insert " $(" sv ")"))
+ (ede-proj-makefile-insert-dist-filepatterns (car tmp))
+ (setq tmp (cdr tmp))))
+ (insert " $(ede_FILES) $(DISTDIR)\n")
+
+ ;; Call our sub projects.
+ (ede-map-subprojects
+ this (lambda (sproj)
+ (let ((rp (directory-file-name (ede-subproject-relative-path
sproj))))
+ (insert "\t$(MAKE) -C " rp " $(MFLAGS) DISTDIR=$(DISTDIR)/" rp
+ " dist"
+ "\n"))))
+
+ ;; Tar up the stuff.
+ (unless (or (ede-subproject-p this)
+ (oref this metasubproject))
+ (insert "\ttar -cvzf $(DISTDIR).tar.gz $(DISTDIR)\n"
+ "\trm -rf $(DISTDIR)\n"))
+
+ ;; Make sure the Makefile is ok.
+ (insert "\n"
+ (file-name-nondirectory (buffer-file-name)) ": "
+ (file-name-nondirectory (oref this file)) "\n"
+;; "$(EMACS) -batch Project.ede -l ede -f ede-proj-regenerate"
+ "address@hidden Makefile is out of date! "
+ "It needs to be regenerated by EDE.\n"
+ "address@hidden If you have not modified Project.ede, you can"
+ " use 'touch' to update the Makefile time stamp.\n"
+ "address@hidden"
+ "\n\n# End of Makefile\n")))
+
+(defmethod ede-proj-makefile-insert-rules ((this ede-proj-target))
+ "Insert rules needed by THIS target."
+ nil)
+
+(defmethod ede-proj-makefile-insert-rules ((this ede-proj-target-makefile))
+ "Insert rules needed by THIS target."
+ (mapc 'ede-proj-makefile-insert-rules (oref this rules))
+ (let ((c (ede-proj-compilers this)))
+ (when c
+ (mapc 'ede-proj-makefile-insert-rules c)
+ (if (oref this phony)
+ (insert ".PHONY: " (ede-proj-makefile-target-name this) "\n"))
+ (insert (ede-proj-makefile-target-name this) ": "
+ (ede-proj-makefile-dependencies this) "\n")
+ (ede-proj-makefile-insert-commands this)
+ )))
+
+(defmethod ede-proj-makefile-insert-commands ((this ede-proj-target-makefile))
+ "Insert the commands needed by target THIS.
+For targets, insert the commands needed by the chosen compiler."
+ (mapc 'ede-proj-makefile-insert-commands (ede-proj-compilers this))
+ (when (object-assoc t :uselinker (ede-proj-compilers this))
+ (mapc 'ede-proj-makefile-insert-commands (ede-proj-linkers this))))
+
+
+(defmethod ede-proj-makefile-insert-user-rules ((this ede-proj-project))
+ "Insert user specified rules needed by THIS target.
+This is different from `ede-proj-makefile-insert-rules' in that this
+function won't create the building rules which are auto created with
+automake."
+ (mapc 'ede-proj-makefile-insert-user-rules (oref this inference-rules)))
+
+(defmethod ede-proj-makefile-insert-user-rules ((this ede-proj-target))
+ "Insert user specified rules needed by THIS target."
+ (mapc 'ede-proj-makefile-insert-rules (oref this rules)))
+
+(defmethod ede-proj-makefile-dependencies ((this ede-proj-target-makefile))
+ "Return a string representing the dependencies for THIS.
+Some compilers only use the first element in the dependencies, others
+have a list of intermediates (object files), and others don't care.
+This allows customization of how these elements appear."
+ (let* ((c (ede-proj-compilers this))
+ (io (eval (cons 'or (mapcar 'ede-compiler-intermediate-objects-p c))))
+ (out nil))
+ (if io
+ (progn
+ (while c
+ (setq out
+ (concat out "$(" (ede-compiler-intermediate-object-variable
+ (car c)
+ (ede-proj-makefile-target-name this)) ")")
+ c (cdr c)))
+ out)
+ (let ((sv (ede-proj-makefile-sourcevar this))
+ (aux (oref this auxsource)))
+ (setq out
+ (if (and (stringp sv) (not (string= sv "")))
+ (concat "$(" sv ")")
+ ""))
+ (while aux
+ (setq out (concat out " " (car aux)))
+ (setq aux (cdr aux)))
+ out))))
+
+;; Tags
+(defmethod ede-proj-makefile-tags ((this ede-proj-project) targets)
+ "Insert into the current location rules to make recursive TAGS files.
+Argument THIS is the project to create tags for.
+Argument TARGETS are the targets we should depend on for TAGS."
+ (insert "tags: ")
+ (let ((tg targets))
+ ;; Loop over all source variables and insert them
+ (while tg
+ (insert "$(" (ede-proj-makefile-sourcevar (car tg)) ") ")
+ (setq tg (cdr tg)))
+ (insert "\n")
+ (if targets
+ (insert "\tetags $^\n"))
+ ;; Now recurse into all subprojects
+ (setq tg (oref this subproj))
+ (while tg
+ (insert "\t$(MAKE) -C " (ede-subproject-relative-path (car tg)) "
$(MFLAGS) address@hidden")
+ (setq tg (cdr tg)))
+ (insert "\n")))
+
+
+(provide 'ede/pmake)
+
+;;; ede/pmake.el ends here
Index: cedet/ede/proj-archive.el
===================================================================
RCS file: cedet/ede/proj-archive.el
diff -N cedet/ede/proj-archive.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/proj-archive.el 28 Sep 2009 15:15:06 -0000 1.2
@@ -0,0 +1,64 @@
+;;; ede/proj-archive.el --- EDE Generic Project archive support
+
+;;; Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: project, make
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Handle object code archives in and EDE Project file.
+
+(require 'ede/pmake)
+(require 'ede/proj-obj)
+
+;;; Code:
+
+(defclass ede-proj-target-makefile-archive
+ (ede-proj-target-makefile-objectcode)
+ ((availablelinkers :initform (ede-archive-linker)))
+ "This target generates an object code archive.")
+
+(defvar ede-archive-linker
+ (ede-linker
+ "ede-archive-linker"
+ :name "ar"
+ :variables '(("AR" . "ar")
+ ("AR_CMD" . "$(AR) cr"))
+ :commands '("$(AR_CMD) address@hidden $^")
+ :autoconf '(("AC_CHECK_PROGS" . "RANLIB, ranlib"))
+ :objectextention "")
+ "Linker object for creating an archive.")
+
+(defmethod ede-proj-makefile-insert-source-variables :BEFORE
+ ((this ede-proj-target-makefile-archive) &optional moresource)
+ "Insert bin_PROGRAMS variables needed by target THIS.
+We aren't acutally inserting SOURCE details, but this is used by the
+Makefile.am generator, so use it to add this important bin program."
+ (ede-pmake-insert-variable-shared
+ (concat "lib" (ede-name this) "_a_LIBRARIES")
+ (insert (concat "lib" (ede-name this) ".a"))))
+
+(defmethod ede-proj-makefile-garbage-patterns
+ ((this ede-proj-target-makefile-archive))
+ "Add archive name to the garbage patterns.
+This makes sure that the archive is removed with 'make clean'."
+ (let ((garb (call-next-method)))
+ (append garb (list (concat "lib" (ede-name this) ".a")))))
+
+(provide 'ede/proj-archive)
+
+;;; ede/proj-archive.el ends here
Index: cedet/ede/proj-aux.el
===================================================================
RCS file: cedet/ede/proj-aux.el
diff -N cedet/ede/proj-aux.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/proj-aux.el 28 Sep 2009 15:15:06 -0000 1.2
@@ -0,0 +1,47 @@
+;;; ede/proj-aux.el --- EDE Generic Project auxilliary file support
+
+;;; Copyright (C) 1998, 1999, 2000, 2007 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: project, make
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Handle auxiliary files (README, FAQ, etc) in and EDE Project file.
+
+(require 'ede/proj)
+(require 'ede/pmake)
+
+;;; Code:
+(defclass ede-proj-target-aux (ede-proj-target)
+ ((sourcetype :initform (ede-aux-source)))
+ "This target consists of aux files such as READMEs and COPYING.")
+
+(defvar ede-aux-source
+ (ede-sourcecode "ede-aux-source-txt"
+ :name "Auxiliary Text"
+ :sourcepattern "^[A-Z]+$\\|\\.txt$")
+ "Miscelaneous fields definition.")
+
+(defmethod ede-proj-makefile-sourcevar ((this ede-proj-target-aux))
+ "Return the variable name for THIS's sources."
+ (concat (ede-pmake-varname this) "_AUX"))
+
+(provide 'ede/proj-aux)
+
+;;; ede/proj-aux.el ends here
Index: cedet/ede/proj-comp.el
===================================================================
RCS file: cedet/ede/proj-comp.el
diff -N cedet/ede/proj-comp.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/proj-comp.el 28 Sep 2009 15:15:06 -0000 1.2
@@ -0,0 +1,346 @@
+;;; ede/proj-comp.el --- EDE Generic Project compiler/rule driver
+
+;;; Copyright (C) 1999, 2000, 2001, 2004, 2005, 2007, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: project, make
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; This software handles the maintenance of compiler and rule definitions
+;; for different object types.
+;;
+;; The `ede-compiler' class lets different types of project objects create
+;; definitions of compilers that can be swapped in and out for compiling
+;; source code. Users can also define new compiler types whenever they
+;; some customized behavior.
+;;
+;; The `ede-makefile-rule' class lets users add customized rules into thier
+;; objects, and also lets different compilers add chaining rules to their
+;; behaviors.
+;;
+;; It is important that all new compiler types be registered once. That
+;; way the chaining rules and variables are inserted into any given Makefile
+;; only once.
+;;
+;; To insert many compiler elements, wrap them in `ede-compiler-begin-unique'
+;; before calling their insert methods.
+;; To write a method that inserts a variable or rule for a compiler
+;; based object, wrap the body of your call in `ede-compiler-only-once'
+
+(require 'ede) ;source object
+(require 'ede/autoconf-edit)
+
+;;; Types:
+(defclass ede-compilation-program (eieio-instance-inheritor)
+ ((name :initarg :name
+ :type string
+ :custom string
+ :documentation "Name of this type of compiler.")
+ (variables :initarg :variables
+ :type list
+ :custom (repeat (cons (string :tag "Variable")
+ (string :tag "Value")))
+ :documentation
+ "Variables needed in the Makefile for this compiler.
+An assoc list where each element is (VARNAME . VALUE) where VARNAME
+is a string, and VALUE is either a string, or a list of strings.
+For example, GCC would define CC=gcc, and emacs would define EMACS=emacs.")
+ (sourcetype :initarg :sourcetype
+ :type list ;; of symbols
+ :documentation
+ "A list of `ede-sourcecode' objects this class will handle.
+This is used to match target objects with the compilers and linkers
+they can use, and which files this object is interested in."
+ :accessor ede-object-sourcecode)
+ (rules :initarg :rules
+ :initform nil
+ :type list
+ :custom (repeat (object :objecttype ede-makefile-rule))
+ :documentation
+ "Auxiliary rules needed for this compiler to run.
+For example, yacc/lex files need additional chain rules, or inferences.")
+ (commands :initarg :commands
+ :type list
+ :custom (repeat string)
+ :documentation
+ "The commands used to execute this compiler.
+The object which uses this compiler will place these commands after
+it's rule definition.")
+ (autoconf :initarg :autoconf
+ :initform nil
+ :type list
+ :custom (repeat string)
+ :documentation
+ "Autoconf function to call if this type of compiler is used.
+When a project is in Automake mode, this defines the autoconf function to
+call to initialize automake to use this compiler.
+For example, there may be multiple C compilers, but they all probably
+use the same autoconf form.")
+ (objectextention :initarg :objectextention
+ :type string
+ :documentation
+ "A string which is the extention used for object files.
+For example, C code uses .o on unix, and Emacs Lisp uses .elc.")
+ )
+ "A program used to compile or link a program via a Makefile.
+Contains everything needed to output code into a Makefile, or autoconf
+file.")
+
+(defclass ede-compiler (ede-compilation-program)
+ ((makedepends :initarg :makedepends
+ :initform nil
+ :type boolean
+ :documentation
+ "Non-nil if this compiler can make dependencies.")
+ (uselinker :initarg :uselinker
+ :initform nil
+ :type boolean
+ :documentation
+ "Non-nil if this compiler creates code that can be linked.
+This requires that the containing target also define a list of available
+linkers that can be used.")
+ )
+ "Definition for a compiler.
+Different types of objects will provide different compilers for
+different situations.")
+
+(defclass ede-linker (ede-compilation-program)
+ ()
+ "Contains information needed to link many generated object files together.")
+
+(defclass ede-makefile-rule ()
+ ((target :initarg :target
+ :initform ""
+ :type string
+ :custom string
+ :documentation "The target pattern.
+A pattern of \"%.o\" is used for inference rules, and would match object files.
+A target of \"foo.o\" explicitly matches the file foo.o.")
+ (dependencies :initarg :dependencies
+ :initform ""
+ :type string
+ :custom string
+ :documentation "Dependencies on this target.
+A pattern of \"%.o\" would match a file of the same prefix as the target
+if that target is also an inference rule pattern.
+A dependency of \"foo.c\" explicitly lists foo.c as a dependency.
+A variable such as $(name_SOURCES) will list all the source files
+belonging to the target name.")
+ (rules :initarg :rules
+ :initform nil
+ :type list
+ :custom (repeat string)
+ :documentation "Scripts to execute.
+These scripst will be executed in sh (Unless the SHELL variable is overriden).
+Do not prefix with TAB.
+Each individual element of this list can be either a string, or
+a lambda function. (The custom element does not yet express that.")
+ (phony :initarg :phony
+ :initform nil
+ :type boolean
+ :custom boolean
+ :documentation "Is this a phony rule?
+Adds this rule to a .PHONY list."))
+ "A single rule for building some target.")
+
+;;; Code:
+(defvar ede-compiler-list nil
+ "The master list of all EDE compilers.")
+
+(defvar ede-linker-list nil
+ "The master list of all EDE compilers.")
+
+(defvar ede-current-build-list nil
+ "List of EDE compilers that have already inserted parts of themselves.
+This is used when creating a Makefile to prevend duplicate variables and
+rules from being created.")
+
+(defmethod initialize-instance :AFTER ((this ede-compiler) &rest fields)
+ "Make sure that all ede compiler objects are cached in
+`ede-compiler-list'."
+ (add-to-list 'ede-compiler-list this))
+
+(defmethod initialize-instance :AFTER ((this ede-linker) &rest fields)
+ "Make sure that all ede compiler objects are cached in
+`ede-linker-list'."
+ (add-to-list 'ede-linker-list this))
+
+(defmacro ede-compiler-begin-unique (&rest body)
+ "Execute BODY, making sure that `ede-current-build-list' is maintained.
+This will prevent rules from creating duplicate variables or rules."
+ `(let ((ede-current-build-list nil))
+ ,@body))
+
+(defmacro ede-compiler-only-once (object &rest body)
+ "Using OBJECT, execute BODY only once per Makefile generation."
+ `(if (not (member ,object ede-current-build-list))
+ (progn
+ (add-to-list 'ede-current-build-list ,object)
+ ,@body)))
+
+(defmacro ede-linker-begin-unique (&rest body)
+ "Execute BODY, making sure that `ede-current-build-list' is maintained.
+This will prevent rules from creating duplicate variables or rules."
+ `(let ((ede-current-build-list nil))
+ ,@body))
+
+(defmacro ede-linker-only-once (object &rest body)
+ "Using OBJECT, execute BODY only once per Makefile generation."
+ `(if (not (member ,object ede-current-build-list))
+ (progn
+ (add-to-list 'ede-current-build-list ,object)
+ ,@body)))
+
+(add-hook 'edebug-setup-hook
+ (lambda ()
+ (def-edebug-spec ede-compiler-begin-unique def-body)
+ (def-edebug-spec ede-compiler-only-once (form def-body))
+ (def-edebug-spec ede-linker-begin-unique def-body)
+ (def-edebug-spec ede-linker-only-once (form def-body))
+ (def-edebug-spec ede-pmake-insert-variable-shared (form def-body))
+ ))
+
+;;; Querys
+(defun ede-proj-find-compiler (compilers sourcetype)
+ "Return a compiler from the list COMPILERS that will compile SOURCETYPE."
+ (while (and compilers
+ (not (member sourcetype (oref (car compilers) sourcetype))))
+ (setq compilers (cdr compilers)))
+ (car-safe compilers))
+
+(defun ede-proj-find-linker (linkers sourcetype)
+ "Return a compiler from the list LINKERS to be used with SOURCETYPE."
+ (while (and linkers
+ (slot-boundp (car linkers) 'sourcetype)
+ (not (member sourcetype (oref (car linkers) sourcetype))))
+ (setq linkers (cdr linkers)))
+ (car-safe linkers))
+
+;;; Methods:
+(defmethod ede-proj-tweak-autoconf ((this ede-compilation-program))
+ "Tweak the configure file (current buffer) to accomodate THIS."
+ (mapcar
+ (lambda (obj)
+ (cond ((stringp obj)
+ (autoconf-insert-new-macro obj))
+ ((consp obj)
+ (autoconf-insert-new-macro (car obj) (cdr obj)))
+ (t (error "Autoconf directives must be a string, or cons cell")))
+ )
+ (oref this autoconf)))
+
+(defmethod ede-proj-flush-autoconf ((this ede-compilation-program))
+ "Flush the configure file (current buffer) to accomodate THIS."
+ nil)
+
+(defmethod ede-proj-makefile-insert-variables ((this ede-compilation-program))
+ "Insert variables needed by the compiler THIS."
+ (if (eieio-instance-inheritor-slot-boundp this 'variables)
+ (with-slots (variables) this
+ (mapcar
+ (lambda (var)
+ (insert (car var) "=")
+ (let ((cd (cdr var)))
+ (if (listp cd)
+ (mapc (lambda (c) (insert " " c)) cd)
+ (insert cd)))
+ (insert "\n"))
+ variables))))
+
+(defmethod ede-compiler-intermediate-objects-p ((this ede-compiler))
+ "Return non-nil if THIS has intermediate object files.
+If this compiler creates code that can be linked together,
+then the object files created by the compiler are considered intermediate."
+ (oref this uselinker))
+
+(defmethod ede-compiler-intermediate-object-variable ((this ede-compiler)
+ targetname)
+ "Return a string based on THIS representing a make object variable.
+TARGETNAME is the name of the target that these objects belong to."
+ (concat targetname "_OBJ"))
+
+(defmethod ede-proj-makefile-insert-object-variables ((this ede-compiler)
+ targetname sourcefiles)
+ "Insert an OBJ variable to specify object code to be generated for THIS.
+The name of the target is TARGETNAME as a string. SOURCEFILES is the list of
+files to be objectified.
+Not all compilers do this."
+ (if (ede-compiler-intermediate-objects-p this)
+ (progn
+ (insert (ede-compiler-intermediate-object-variable this targetname)
+ "=")
+ (let ((src (oref this sourcetype)))
+ (mapc (lambda (s)
+ (let ((ts src))
+ (while (and ts (not (ede-want-file-source-p
+ (symbol-value (car ts)) s)))
+ (setq ts (cdr ts)))
+ ;; Only insert the object if the given file is a major
+ ;; source-code type.
+ (if ts;; a match as a source file.
+ (insert " " (file-name-sans-extension s)
+ (oref this objectextention)))))
+ sourcefiles)
+ (insert "\n")))))
+
+(defmethod ede-proj-makefile-insert-rules ((this ede-compilation-program))
+ "Insert rules needed for THIS compiler object."
+ (ede-compiler-only-once this
+ (mapc 'ede-proj-makefile-insert-rules (oref this rules))))
+
+(defmethod ede-proj-makefile-insert-rules ((this ede-makefile-rule))
+ "Insert rules needed for THIS rule object."
+ (if (oref this phony) (insert ".PHONY: (oref this target)\n"))
+ (insert (oref this target) ": " (oref this dependencies) "\n\t"
+ (mapconcat (lambda (c) c) (oref this rules) "\n\t")
+ "\n\n"))
+
+(defmethod ede-proj-makefile-insert-commands ((this ede-compilation-program))
+ "Insert the commands needed to use compiler THIS.
+The object creating makefile rules must call this method for the
+compiler it decides to use after inserting in the rule."
+ (when (slot-boundp this 'commands)
+ (with-slots (commands) this
+ (mapc
+ (lambda (obj) (insert "\t"
+ (cond ((stringp obj)
+ obj)
+ ((and (listp obj)
+ (eq (car obj) 'lambda))
+ (funcall obj))
+ (t
+ (format "%S" obj)))
+ "\n"))
+ commands))
+ (insert "\n")))
+
+;;; Some details about our new macro
+;;
+(add-hook 'edebug-setup-hook
+ (lambda ()
+ (def-edebug-spec ede-compiler-begin-unique def-body)))
+(put 'ede-compiler-begin-unique 'lisp-indent-function 0)
+(put 'ede-compiler-only-once 'lisp-indent-function 1)
+(put 'ede-linker-begin-unique 'lisp-indent-function 0)
+(put 'ede-linker-only-once 'lisp-indent-function 1)
+
+(provide 'ede/proj-comp)
+
+;;; ede/proj-comp.el ends here
Index: cedet/ede/proj-elisp.el
===================================================================
RCS file: cedet/ede/proj-elisp.el
diff -N cedet/ede/proj-elisp.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/proj-elisp.el 28 Sep 2009 15:15:06 -0000 1.2
@@ -0,0 +1,395 @@
+;;; ede-proj-elisp.el --- EDE Generic Project Emacs Lisp support
+
+;;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+;;; 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: project, make
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Handle Emacs Lisp in an EDE Project file.
+
+(require 'ede/proj)
+(require 'ede/pmake)
+(require 'ede/pconf)
+
+(autoload 'semantic-ede-proj-target-grammar "semantic/ede-grammar")
+
+;;; Code:
+(defclass ede-proj-target-elisp (ede-proj-target-makefile)
+ ((menu :initform nil)
+ (keybindings :initform nil)
+ (phony :initform t)
+ (sourcetype :initform (ede-source-emacs))
+ (availablecompilers :initform (ede-emacs-compiler ede-xemacs-compiler))
+ (aux-packages :initarg :aux-packages
+ :initform nil
+ :type list
+ :custom (repeat string)
+ :documentation "Additional packages needed.
+There should only be one toplevel package per auxiliary tool needed.
+These packages location is found, and added to the compile time
+load path."
+ ))
+ "This target consists of a group of lisp files.
+A lisp target may be one general program with many separate lisp files in it.")
+
+(defvar ede-source-emacs
+ (ede-sourcecode "ede-emacs-source"
+ :name "Emacs Lisp"
+ :sourcepattern "\\.el$"
+ :garbagepattern '("*.elc"))
+ "Emacs Lisp source code definition.")
+
+(defvar ede-emacs-compiler
+ (ede-compiler
+ "ede-emacs-compiler"
+ :name "emacs"
+ :variables '(("EMACS" . "emacs")
+ ("EMACSFLAGS" . "-batch --no-site-file"))
+ :commands
+ '("@echo \"(add-to-list 'load-path nil)\" > address@hidden"
+ "for loadpath in . ${LOADPATH}; do \\"
+ " echo \"(add-to-list 'load-path \\\"$$loadpath\\\")\" >>
address@hidden; \\"
+ "done;"
+ "@echo \"(setq debug-on-error t)\" >> address@hidden"
+ "\"$(EMACS)\" $(EMACSFLAGS) -l address@hidden -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)\" > address@hidden"
+ "for loadpath in . ${LOADPATH}; do \\"
+ " echo \"(add-to-list 'load-path \\\"$$loadpath\\\")\" >>
address@hidden; \\"
+ "done;"
+ "@echo \"(require 'cedet-autogen)\" >> address@hidden"
+ "\"$(EMACS)\" -batch --no-site-file -l address@hidden -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
Index: cedet/ede/proj-info.el
===================================================================
RCS file: cedet/ede/proj-info.el
diff -N cedet/ede/proj-info.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/proj-info.el 28 Sep 2009 15:15:06 -0000 1.2
@@ -0,0 +1,186 @@
+;;; ede-proj-info.el --- EDE Generic Project texinfo support
+
+;;; Copyright (C) 1998, 1999, 2000, 2001, 2004, 2007, 2008, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: project, make
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Handle texinfo in and EDE Project file.
+
+(require 'ede/pmake)
+
+;;; Code:
+(defclass ede-proj-target-makefile-info (ede-proj-target-makefile)
+ ((menu :initform nil)
+ (keybindings :initform nil)
+ (availablecompilers :initform (ede-makeinfo-compiler
+ ede-texi2html-compiler))
+ (sourcetype :initform (ede-makeinfo-source))
+ (mainmenu :initarg :mainmenu
+ :initform ""
+ :type string
+ :custom string
+ :documentation "The main menu resides in this file.
+All other sources should be included independently."))
+ "Target for a single info file.")
+
+(defvar ede-makeinfo-source
+ (ede-sourcecode "ede-makeinfo-source"
+ :name "Texinfo"
+ :sourcepattern "\\.texi?$"
+ :garbagepattern '("*.info*" "*.html"))
+ "Texinfo source code definition.")
+
+(defvar ede-makeinfo-compiler
+ (ede-compiler
+ "ede-makeinfo-compiler"
+ :name "makeinfo"
+ :variables '(("MAKEINFO" . "makeinfo"))
+ :commands '("$(MAKEINFO) $<")
+ :autoconf '(("AC_CHECK_PROG" . "MAKEINFO, makeinfo"))
+ :sourcetype '(ede-makeinfo-source)
+ )
+ "Compile texinfo files into info files.")
+
+(defvar ede-texi2html-compiler
+ (ede-compiler
+ "ede-texi2html-compiler"
+ :name "texi2html"
+ :variables '(("TEXI2HTML" . "makeinfo -html"))
+ :commands '("makeinfo -o $@ $<")
+ :sourcetype '(ede-makeinfo-source)
+ )
+ "Compile texinfo files into html files.")
+
+;;; Makefile generation
+;;
+(defmethod ede-proj-configure-add-missing
+ ((this ede-proj-target-makefile-info))
+ "Query if any files needed by THIS provided by automake are missing.
+Results in --add-missing being passed to automake."
+ (not (ede-expand-filename (ede-toplevel) "texinfo.tex")))
+
+(defmethod ede-proj-makefile-sourcevar ((this ede-proj-target-makefile-info))
+ "Return the variable name for THIS's sources."
+ (concat (ede-pmake-varname this) "_TEXINFOS"))
+
+(defmethod ede-proj-makefile-insert-source-variables
+ ((this ede-proj-target-makefile-info) &optional moresource)
+ "Insert the source variables needed by THIS info target.
+Optional argument MORESOURCE is a list of additional sources to add to the
+sources variable.
+Does the usual for Makefile mode, but splits source into two variables
+when working in Automake mode."
+ (if (not (ede-proj-automake-p))
+ (call-next-method)
+ (let* ((sv (ede-proj-makefile-sourcevar this))
+ (src (copy-sequence (oref this source)))
+ (menu (or (oref this menu) (car src))))
+ (setq src (delq menu src))
+ ;; the info_TEXINFOS variable is probably shared
+ (ede-pmake-insert-variable-shared "info_TEXINFOS"
+ (insert menu))
+ ;; Now insert the rest of the source elsewhere
+ (ede-pmake-insert-variable-shared sv
+ (insert (mapconcat 'identity src " ")))
+ (if moresource
+ (error "Texinfo files should not have moresource")))))
+
+(defun ede-makeinfo-find-info-filename (source)
+ "Find the info filename produced by SOURCE texinfo file."
+ (let ((opened (get-file-buffer source))
+ (buffer (or (get-file-buffer source)
+ (find-file-noselect source nil t)))
+ info)
+ (with-current-buffer buffer
+ (save-excursion
+ (goto-char (point-min))
+ (and (re-search-forward "address@hidden([^.]+\\).info$" nil t)
+ (setq info (match-string 1)))))
+ (unless (eq buffer opened)
+ (kill-buffer buffer))
+ info))
+
+(defmethod ede-proj-makefile-target-name ((this ede-proj-target-makefile-info))
+ "Return the name of the main target for THIS target."
+ ;; The target should be the main-menu file name translated to .info.
+ (let* ((source (if (not (string= (oref this mainmenu) ""))
+ (oref this mainmenu)
+ (car (oref this source))))
+ (info (ede-makeinfo-find-info-filename source)))
+ (concat (or info (file-name-sans-extension source)) ".info")))
+
+(defmethod ede-proj-makefile-insert-dist-dependencies ((this
ede-proj-target-makefile-info))
+ "Insert any symbols that the DIST rule should depend on.
+Texinfo files want to insert generated `.info' files.
+Argument THIS is the target which needs to insert an info file."
+ ;; In some cases, this is ONLY the index file. That should generally
+ ;; be ok.
+ (insert " " (ede-proj-makefile-target-name this))
+ )
+
+(defmethod ede-proj-makefile-insert-dist-filepatterns ((this
ede-proj-target-makefile-info))
+ "Insert any symbols that the DIST rule should depend on.
+Texinfo files want to insert generated `.info' files.
+Argument THIS is the target which needs to insert an info file."
+ ;; In some cases, this is ONLY the index file. That should generally
+ ;; be ok.
+ (insert " " (ede-proj-makefile-target-name this) "*")
+ )
+
+; (let ((n (ede-name this)))
+; (if (string-match "\\.info$" n)
+; n
+; (concat n ".info"))))
+
+(defmethod object-write ((this ede-proj-target-makefile-info))
+ "Before committing any change to THIS, make sure the mainmenu is first."
+ (let ((mm (oref this mainmenu))
+ (s (oref this source))
+ (nl nil))
+ (if (or (string= mm "") (not mm) (string= mm (car s)))
+ nil
+ ;; Make sure that MM is first in the list of items.
+ (setq nl (cons mm (delq mm s)))
+ (oset this source nl)))
+ (call-next-method))
+
+(defmethod ede-documentation ((this ede-proj-target-makefile-info))
+ "Return a list of files that provides documentation.
+Documentation is not for object THIS, but is provided by THIS for other
+files in the project."
+ (let* ((src (oref this source))
+ (proj (ede-target-parent this))
+ (dir (oref proj directory))
+ (out nil)
+ )
+ ;; convert src to full file names.
+ (while src
+ (setq out (cons
+ (expand-file-name (car src) dir)
+ out))
+ (setq src (cdr src)))
+ ;; Return it
+ out))
+
+(provide 'ede/proj-info)
+
+;;; ede/proj-info.el ends here
Index: cedet/ede/proj-misc.el
===================================================================
RCS file: cedet/ede/proj-misc.el
diff -N cedet/ede/proj-misc.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/proj-misc.el 28 Sep 2009 15:15:06 -0000 1.2
@@ -0,0 +1,93 @@
+;;; ede-proj-nusc.el --- EDE Generic Project Emacs Lisp support
+
+;;; Copyright (C) 1998, 1999, 2000, 2001, 2008
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: project, make
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Handle miscelaneous compilable projects in and EDE Project file.
+;; This misc target lets the user link in custom makefiles to an EDE
+;; project.
+
+(require 'ede/pmake)
+(require 'ede/proj-comp)
+
+;;; Code:
+(defclass ede-proj-target-makefile-miscelaneous (ede-proj-target-makefile)
+ ((sourcetype :initform (ede-misc-source))
+ (availablecompilers :initform (ede-misc-compile))
+ (submakefile :initarg :submakefile
+ :initform ""
+ :type string
+ :custom string
+ :documentation
+ "Miscellaneous sources which have a specialized makefile.
+The sub-makefile is used to build this target.")
+ )
+ "Miscelaneous target type.
+A user-written makefile is used to build this target.
+All listed sources are included in the distribution.")
+
+(defvar ede-misc-source
+ (ede-sourcecode "ede-misc-source"
+ :name "Miscelaneous"
+ :sourcepattern ".*")
+ "Miscelaneous fiels definition.")
+
+(defvar ede-misc-compile
+ (ede-compiler "ede-misc-compile"
+ :name "Sub Makefile"
+ :commands
+ '(
+ )
+ :autoconf nil
+ :sourcetype '(ede-misc-source)
+ )
+ "Compile code via a sub-makefile.")
+
+(defmethod ede-proj-makefile-sourcevar ((this
ede-proj-target-makefile-miscelaneous))
+ "Return the variable name for THIS's sources."
+ (concat (ede-pmake-varname this) "_MISC"))
+
+(defmethod ede-proj-makefile-dependency-files
+ ((this ede-proj-target-makefile-miscelaneous))
+ "Return a list of files which THIS target depends on."
+ (with-slots (submakefile) this
+ (cond ((string= submakefile "")
+ nil)
+ ((not submakefile)
+ nil)
+ (t (list submakefile)))))
+
+(defmethod ede-proj-makefile-insert-rules ((this
ede-proj-target-makefile-miscelaneous))
+ "Create the make rule needed to create an archive for THIS."
+ ;; DO NOT call the next method. We will never have any compilers,
+ ;; or any dependencies, or stuff like this. This rull will lets us
+ ;; deal with it in a nice way.
+ (insert (ede-name this) ": ")
+ (with-slots (submakefile) this
+ (if (string= submakefile "")
+ (insert "address@hidden")
+ (insert submakefile "\n" "\t$(MAKE) -f " submakefile "\n\n"))))
+
+(provide 'ede/proj-misc)
+
+;;; ede/proj-misc.el ends here
Index: cedet/ede/proj-obj.el
===================================================================
RCS file: cedet/ede/proj-obj.el
diff -N cedet/ede/proj-obj.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/proj-obj.el 28 Sep 2009 15:15:06 -0000 1.2
@@ -0,0 +1,281 @@
+;;; ede/proj-obj.el --- EDE Generic Project Object code generation support
+
+;;; Copyright (C) 1998, 1999, 2000, 2005, 2008, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: project, make
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Handles a supperclass of target types which create object code in
+;; and EDE Project file.
+
+(require 'ede/proj)
+(declare-function ede-pmake-varname "ede/pmake")
+
+(defvar ede-proj-objectcode-dodependencies nil
+ "Flag specifies to do automatic dependencies.")
+
+;;; Code:
+(defclass ede-proj-target-makefile-objectcode (ede-proj-target-makefile)
+ (;; Give this a new default
+ (configuration-variables :initform ("debug" . (("CFLAGS" . "-g")
+ ("LDFLAGS" . "-g"))))
+ ;; @TODO - add an include path.
+ (availablecompilers :initform (ede-gcc-compiler
+ ede-g++-compiler
+ ede-gfortran-compiler
+ ede-gfortran-module-compiler
+ ;; More C and C++ compilers, plus
+ ;; fortran or pascal can be added here
+ ))
+ (availablelinkers :initform (ede-g++-linker
+ ;; Add more linker thingies here.
+ ede-ld-linker
+ ede-gfortran-linker
+ ))
+ (sourcetype :initform (ede-source-c
+ ede-source-c++
+ ede-source-f77
+ ede-source-f90
+ ;; ede-source-other
+ ;; This object should take everything that
+ ;; gets compiled into objects like fortran
+ ;; and pascal.
+ ))
+ )
+ "Abstract class for Makefile based object code generating targets.
+Belonging to this group assumes you could make a .o from an element source
+file.")
+
+(defclass ede-object-compiler (ede-compiler)
+ ((uselinker :initform t)
+ (dependencyvar :initarg :dependencyvar
+ :type list
+ :custom (cons (string :tag "Variable")
+ (string :tag "Value"))
+ :documentation
+ "A variable dedicated to dependency generation."))
+ "Ede compiler class for source which must compiler, and link.")
+
+;;; C/C++ Compilers and Linkers
+;;
+(defvar ede-source-c
+ (ede-sourcecode "ede-source-c"
+ :name "C"
+ :sourcepattern "\\.c$"
+ :auxsourcepattern "\\.h$"
+ :garbagepattern '("*.o" "*.obj" ".deps/*.P" ".lo"))
+ "C source code definition.")
+
+(defvar ede-gcc-compiler
+ (ede-object-compiler
+ "ede-c-compiler-gcc"
+ :name "gcc"
+ :dependencyvar '("C_DEPENDENCIES" . "-Wp,-MD,.deps/$(*F).P")
+ :variables '(("CC" . "gcc")
+ ("C_COMPILE" .
+ "$(CC) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)"))
+ :rules (list (ede-makefile-rule
+ "c-inference-rule"
+ :target "%.o"
+ :dependencies "%.c"
+ :rules '("@echo '$(C_COMPILE) -c $<'; \\"
+ "$(C_COMPILE) $(C_DEPENDENCIES) -o $@ -c $<"
+ )
+ ))
+ :autoconf '("AC_PROG_CC" "AC_PROG_GCC_TRADITIONAL")
+ :sourcetype '(ede-source-c)
+ :objectextention ".o"
+ :makedepends t
+ :uselinker t)
+ "Compiler for C sourcecode.")
+
+(defvar ede-source-c++
+ (ede-sourcecode "ede-source-c++"
+ :name "C++"
+ :sourcepattern "\\.\\(cpp\\|cc\\|cxx\\)$"
+ :auxsourcepattern "\\.\\(hpp\\|hh?\\|hxx\\)$"
+ :garbagepattern '("*.o" "*.obj" ".deps/*.P" ".lo"))
+ "C++ source code definition.")
+
+(defvar ede-g++-compiler
+ (ede-object-compiler
+ "ede-c-compiler-g++"
+ :name "g++"
+ :dependencyvar '("CXX_DEPENDENCIES" . "-Wp,-MD,.deps/$(*F).P")
+ :variables '(("CXX" "g++")
+ ("CXX_COMPILE" .
+ "$(CXX) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)")
+ )
+ :rules (list (ede-makefile-rule
+ "c++-inference-rule"
+ :target "%.o"
+ :dependencies "%.cpp"
+ :rules '("@echo '$(CXX_COMPILE) -c $<'; \\"
+ "$(CXX_COMPILE) $(CXX_DEPENDENCIES) -o $@ -c $<"
+ )
+ ))
+ :autoconf '("AC_PROG_CXX")
+ :sourcetype '(ede-source-c++)
+ :objectextention ".o"
+ :makedepends t
+ :uselinker t)
+ "Compiler for C sourcecode.")
+
+(defvar ede-g++-linker
+ (ede-linker
+ "ede-g++-linker"
+ :name "g++"
+ ;; Only use this linker when c++ exists.
+ :sourcetype '(ede-source-c++)
+ :variables '(("CXX_LINK" .
+ "$(CXX) $(CFLAGS) $(LDFLAGS) -L. -o $@")
+ )
+ :commands '("$(CXX_LINK) $^")
+ :autoconf '("AC_PROG_CXX")
+ :objectextention "")
+ "Linker needed for c++ programs.")
+
+;;; Fortran Compiler/Linker
+;;
+;; Contributed by David Engster
+(defvar ede-source-f90
+ (ede-sourcecode "ede-source-f90"
+ :name "Fortran 90/95"
+ :sourcepattern "\\.[fF]9[05]$"
+ :auxsourcepattern "\\.incf$"
+ :garbagepattern '("*.o" "*.mod" ".deps/*.P"))
+ "Fortran 90/95 source code definition.")
+
+(defvar ede-source-f77
+ (ede-sourcecode "ede-source-f77"
+ :name "Fortran 77"
+ :sourcepattern "\\.\\([fF]\\|for\\)$"
+ :auxsourcepattern "\\.incf$"
+ :garbagepattern '("*.o" ".deps/*.P"))
+ "Fortran 77 source code definition.")
+
+(defvar ede-gfortran-compiler
+ (ede-object-compiler
+ "ede-f90-compiler-gfortran"
+ :name "gfortran"
+ :dependencyvar '("F90_DEPENDENCIES" . "-Wp,-MD,.deps/$(*F).P")
+ :variables '(("F90" . "gfortran")
+ ("F90_COMPILE" .
+ "$(F90) $(DEFS) $(INCLUDES) $(F90FLAGS)"))
+ :rules (list (ede-makefile-rule
+ "f90-inference-rule"
+ :target "%.o"
+ :dependencies "%.f90"
+ :rules '("@echo '$(F90_COMPILE) -c $<'; \\"
+ "$(F90_COMPILE) $(F90_DEPENDENCIES) -o $@ -c $<"
+ )
+ ))
+ :sourcetype '(ede-source-f90 ede-source-f77)
+ :objectextention ".o"
+ :makedepends t
+ :uselinker t)
+ "Compiler for Fortran sourcecode.")
+
+(defvar ede-gfortran-module-compiler
+ (clone ede-gfortran-compiler
+ "ede-f90-module-compiler-gfortran"
+ :name "gfortranmod"
+ :sourcetype '(ede-source-f90)
+ :commands '("$(F90_COMPILE) -c $^")
+ :objectextention ".mod"
+ :uselinker nil)
+ "Compiler for Fortran 90/95 modules.")
+
+
+(defvar ede-gfortran-linker
+ (ede-linker
+ "ede-gfortran-linker"
+ :name "gfortran"
+ :sourcetype '(ede-source-f90 ede-source-f77)
+ :variables '(("F90_LINK" .
+ "$(F90) $(CFLAGS) $(LDFLAGS) -L. -o $@")
+ )
+ :commands '("$(F90_LINK) $^")
+ :objectextention "")
+ "Linker needed for Fortran programs.")
+
+;;; Generic Linker
+;;
+(defvar ede-ld-linker
+ (ede-linker
+ "ede-ld-linker"
+ :name "ld"
+ :variables '(("LD" . "ld")
+ ("LD_LINK" .
+ "$(LD) $(LDFLAGS) -L. -o $@")
+ )
+ :commands '("$(LD_LINK) $^")
+ :objectextention "")
+ "Linker needed for c++ programs.")
+
+;;; The EDE object compiler
+;;
+(defmethod ede-proj-makefile-insert-variables ((this ede-object-compiler))
+ "Insert variables needed by the compiler THIS."
+ (call-next-method)
+ (if (eieio-instance-inheritor-slot-boundp this 'dependencyvar)
+ (with-slots (dependencyvar) this
+ (insert (car dependencyvar) "=")
+ (let ((cd (cdr dependencyvar)))
+ (if (listp cd)
+ (mapc (lambda (c) (insert " " c)) cd)
+ (insert cd))
+ (insert "\n")))))
+
+;;; EDE Object target type methods
+;;
+(defmethod ede-proj-makefile-sourcevar
+ ((this ede-proj-target-makefile-objectcode))
+ "Return the variable name for THIS's sources."
+ (require 'ede/pmake)
+ (concat (ede-pmake-varname this) "_SOURCES"))
+
+(defmethod ede-proj-makefile-dependency-files
+ ((this ede-proj-target-makefile-objectcode))
+ "Return a list of source files to convert to dependencies.
+Argument THIS is the target to get sources from."
+ (append (oref this source) (oref this auxsource)))
+
+(defmethod ede-proj-makefile-insert-variables ((this
ede-proj-target-makefile-objectcode)
+ &optional moresource)
+ "Insert variables needed by target THIS.
+Optional argument MORESOURCE is not used."
+ (let ((ede-proj-objectcode-dodependencies
+ (oref (ede-target-parent this) automatic-dependencies)))
+ (call-next-method)))
+
+(defmethod ede-buffer-header-file((this ede-proj-target-makefile-objectcode)
+ buffer)
+ "There are no default header files."
+ (or (call-next-method)
+ ;; Ok, nothing obvious. Try looking in ourselves.
+ (let ((h (oref this auxsource)))
+ ;; Add more logic here when the problem is better understood.
+ (car-safe h))))
+
+(provide 'ede/proj-obj)
+
+;;; ede/proj-obj.el ends here
Index: cedet/ede/proj-prog.el
===================================================================
RCS file: cedet/ede/proj-prog.el
diff -N cedet/ede/proj-prog.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/proj-prog.el 28 Sep 2009 15:15:06 -0000 1.2
@@ -0,0 +1,113 @@
+;;; ede-proj-prog.el --- EDE Generic Project program support
+
+;;; Copyright (C) 1998, 1999, 2000, 2001, 2005, 2008
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: project, make
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Handle building programs from object files in and EDE Project file.
+
+(require 'ede/pmake)
+(require 'ede/proj-obj)
+
+;;; Code:
+(defclass ede-proj-target-makefile-program
+ (ede-proj-target-makefile-objectcode)
+ ((ldlibs :initarg :ldlibs
+ :initform nil
+ :type list
+ :custom (repeat (string :tag "Library"))
+ :documentation
+ "Libraries, such as \"m\" or \"Xt\" which this program depends on.
+The linker flag \"-l\" is automatically prepended. Do not include a \"lib\"
+prefix, or a \".so\" suffix.
+
+Note: Currently only used for Automake projects."
+ )
+ (ldflags :initarg :ldflags
+ :initform nil
+ :type list
+ :custom (repeat (string :tag "Link Flag"))
+ :documentation
+ "Additional flags to add when linking this target.
+Use ldlibs to add addition libraries. Use this to specify specific
+options to the linker.
+
+Note: Not currently used. This bug needs to be fixed.")
+ )
+ "This target is an executable program.")
+
+(defmethod ede-proj-makefile-insert-automake-pre-variables
+ ((this ede-proj-target-makefile-program))
+ "Insert bin_PROGRAMS variables needed by target THIS."
+ (ede-pmake-insert-variable-shared "bin_PROGRAMS"
+ (insert (ede-name this)))
+ (call-next-method))
+
+(defmethod ede-proj-makefile-insert-automake-post-variables
+ ((this ede-proj-target-makefile-program))
+ "Insert bin_PROGRAMS variables needed by target THIS."
+ (ede-pmake-insert-variable-shared
+ (concat (ede-name this) "_LDADD")
+ (mapc (lambda (c) (insert " -l" c)) (oref this ldlibs)))
+ ;; For other targets THIS depends on
+ ;;
+ ;; NOTE: FIX THIS
+ ;;
+ ;;(ede-pmake-insert-variable-shared
+ ;; (concat (ede-name this) "_DEPENDENCIES")
+ ;; (mapcar (lambda (d) (insert d)) (oref this FOOOOOOOO)))
+ (call-next-method))
+
+(defmethod ede-proj-makefile-insert-rules ((this
ede-proj-target-makefile-program))
+ "Insert rules needed by THIS target."
+ (let ((ede-proj-compiler-object-linkflags
+ (mapconcat 'identity (oref this ldflags) " ")))
+ (with-slots (ldlibs) this
+ (if ldlibs
+ (setq ede-proj-compiler-object-linkflags
+ (concat ede-proj-compiler-object-linkflags
+ " -l"
+ (mapconcat 'identity ldlibs " -l")))))
+ (call-next-method)))
+
+(defmethod project-debug-target ((obj ede-proj-target-makefile-program))
+ "Debug a program target OBJ."
+ (let ((tb (get-buffer-create " *padt*"))
+ (dd (if (not (string= (oref obj path) ""))
+ (oref obj path)
+ default-directory))
+ (cmd nil))
+ (unwind-protect
+ (progn
+ (set-buffer tb)
+ (setq default-directory dd)
+ (setq cmd (read-from-minibuffer
+ "Run (like this): "
+ (concat (symbol-name ede-debug-program-function)
+ " " (ede-target-name obj))))
+ (funcall ede-debug-program-function cmd))
+ (kill-buffer tb))))
+
+
+(provide 'ede/proj-prog)
+
+;;; ede/proj-prog.el ends here
Index: cedet/ede/proj-scheme.el
===================================================================
RCS file: cedet/ede/proj-scheme.el
diff -N cedet/ede/proj-scheme.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/proj-scheme.el 28 Sep 2009 15:15:06 -0000 1.2
@@ -0,0 +1,49 @@
+;;; ede/proj-scheme.el --- EDE Generic Project scheme (guile) support
+
+;;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: project, make, scheme
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Handle scheme (Guile) in and EDE Project file.
+;; This is a specialized do nothing class.
+
+(require 'ede/proj)
+(require 'ede/autoconf-edit)
+
+;;; Code:
+(defclass ede-proj-target-scheme (ede-proj-target)
+ ((menu :initform nil)
+ (keybindings :initform nil)
+ (interpreter :initarg :interpreter
+ :initform "guile"
+ :type string
+ :custom string
+ :documentation "The preferred interpreter for this code.")
+ )
+ "This target consists of scheme files.")
+
+(defmethod ede-proj-tweak-autoconf ((this ede-proj-target-scheme))
+ "Tweak the configure file (current buffer) to accomodate THIS."
+ (autoconf-insert-new-macro "AM_INIT_GUILE_MODULE"))
+
+(provide 'ede/proj-scheme)
+
+;;; ede/proj-scheme.el ends here
Index: cedet/ede/proj-shared.el
===================================================================
RCS file: cedet/ede/proj-shared.el
diff -N cedet/ede/proj-shared.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/proj-shared.el 28 Sep 2009 15:15:06 -0000 1.2
@@ -0,0 +1,164 @@
+;;; ede-proj-shared.el --- EDE Generic Project shared library support
+
+;;; Copyright (C) 1998, 1999, 2000, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: project, make
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Handle shared object libraries in and EDE Project file.
+;; Tries to deal with libtool and non-libtool situations.
+
+(require 'ede/pmake)
+(require 'ede/proj-prog)
+
+;;; THIS NEEDS WORK. SEE ede-proj-obj.
+
+;;; Code:
+(defclass ede-proj-target-makefile-shared-object
+ (ede-proj-target-makefile-program)
+ ((availablecompilers :initform (ede-gcc-shared-compiler
+ ede-gcc-libtool-shared-compiler
+ ede-g++-shared-compiler
+ ede-g++-libtool-shared-compiler
+ ))
+ (ldflags :custom (repeat (string :tag "Libtool flag"))
+ :documentation
+ "Additional flags to add when linking this shared library.
+Use ldlibs to add addition libraries.")
+ )
+ "This target generates a shared library.")
+
+(defvar ede-gcc-shared-compiler
+ (clone ede-gcc-compiler
+ "ede-c-shared-compiler"
+ :name "gcc -shared"
+ :variables '(("CC_SHARED" . "gcc")
+ ("C_SHARED_COMPILE" .
+ "$(CC_SHARED) -shared $(DEFS) $(INCLUDES) $(CPPFLAGS)
$(CFLAGS)"))
+; :linkvariables '(("C_SHARED_LINK" .
+; "$(CC_SHARED) -shared $(CFLAGS) $(LDFLAGS) -L. -o $@
$^")
+; )
+; :commands '("$(C_SHARED_LINK) %s")
+ ;; @TODO - addative modification of autoconf.
+ :autoconf '("AC_PROG_LIBTOOL")
+ )
+ "Compiler for C sourcecode.")
+
+(defvar ede-gcc-libtool-shared-compiler
+ (clone ede-gcc-shared-compiler
+ "ede-c-shared-compiler-libtool"
+ :name "libtool"
+ :variables '(("LIBTOOL" . "$(SHELL) libtool")
+ ("LTCOMPILE" . "$(LIBTOOL) --mode=compile $(CC) $(DEFS)
$(INCLUDES) $(CPPFLAGS) $(CFLAGS)")
+ ("LTLINK" . "$(LIBTOOL) --mode=link $(CC) $(CFLAGS)
$(LDFLAGS) -L. -o $@")
+ )
+ :commands '("$(LTLINK) $^"
+ )
+ :autoconf '("AC_PROG_LIBTOOL")
+ )
+ "Compiler for C sourcecode.")
+
+(defvar ede-g++-shared-compiler
+ (clone ede-g++-compiler
+ "ede-c++-shared-compiler"
+ :name "gcc -shared"
+ :variables '(("CXX_SHARED" . "g++")
+ ("CXX_SHARED_COMPILE" .
+ "$(CXX_SHARED) -shared $(DEFS) $(INCLUDES) $(CPPFLAGS)
$(CFLAGS)"))
+ ;; @TODO - addative modification of autoconf.
+ :autoconf '("AC_PROG_LIBTOOL")
+ )
+ "Compiler for C sourcecode.")
+
+(defvar ede-g++-libtool-shared-compiler
+ (clone ede-g++-shared-compiler
+ "ede-c++-shared-compiler-libtool"
+ :name "libtool"
+ :variables '(("CXX" "g++")
+ ("LIBTOOL" . "$(SHELL) libtool")
+ ("LTCOMPILE" . "$(LIBTOOL) --mode=compile $(CXX) $(DEFS)
$(INCLUDES) $(CPPFLAGS) $(CFLAGS)")
+ ("LTLINK" . "$(LIBTOOL) --mode=link $(CXX) $(CFLAGS)
$(LDFLAGS) -L. -o $@")
+ )
+ :commands '("$(LTLINK) $^"
+ )
+ :autoconf '("AC_PROG_LIBTOOL")
+ )
+ "Compiler for C sourcecode.")
+
+;;; @TODO - C++ versions of the above.
+
+(when nil
+
+
+ (insert;; These C to O rules create dependencies
+ "%.o: %.c\n"
+ "address@hidden '$(COMPILE) -c $<'; \\\n"
+ "\t$(COMPILE)"
+ (if (oref this automatic-dependencies)
+ " -Wp,-MD,.deps/$(*F).P"
+ "")
+ " -c $<\n\n")
+ (if have-libtool
+ (insert;; These C to shared o rules create pic code.
+ "%.lo: %.c\n"
+ "address@hidden '$(LTCOMPILE) -c $<'; \\\n"
+ "\t$(LTCOMPILE) -Wp,-MD,.deps/$(*F).p -c $<\n"
+ "address@hidden -e 's/^\([^:]*\)\.o:/\1.lo \1.o:/' \\\n"
+ "\t < .deps/$(*F).p > .deps/$(*F).P\n"
+ "address@hidden -f .deps/$(*F).p\n\n"))
+ )
+
+(defmethod ede-proj-configure-add-missing
+ ((this ede-proj-target-makefile-shared-object))
+ "Query if any files needed by THIS provided by automake are missing.
+Results in --add-missing being passed to automake."
+ (not (and (ede-expand-filename (ede-toplevel) "ltconfig")
+ (ede-expand-filename (ede-toplevel) "ltmain.sh"))))
+
+(defmethod ede-proj-makefile-insert-automake-pre-variables
+ ((this ede-proj-target-makefile-shared-object))
+ "Insert bin_PROGRAMS variables needed by target THIS.
+We aren't acutally inserting SOURCE details, but this is used by the
+Makefile.am generator, so use it to add this important bin program."
+ (ede-pmake-insert-variable-shared "lib_LTLIBRARIES"
+ (insert (concat "lib" (ede-name this) ".la"))))
+
+(defmethod ede-proj-makefile-insert-automake-post-variables
+ ((this ede-proj-target-makefile-shared-object))
+ "Insert bin_PROGRAMS variables needed by target THIS.
+We need to override -program which has an LDADD element."
+ nil)
+
+(defmethod ede-proj-makefile-target-name ((this
ede-proj-target-makefile-shared-object))
+ "Return the name of the main target for THIS target."
+ ;; We need some platform gunk to make the .so change to .sl, or .a,
+ ;; depending on the platform we are going to compile against.
+ (concat "lib" (ede-name this) ".so"))
+
+(defmethod ede-proj-makefile-sourcevar ((this
ede-proj-target-makefile-shared-object))
+ "Return the variable name for THIS's sources."
+ (if (eq (oref (ede-target-parent this) makefile-type) 'Makefile.am)
+ (concat "lib" (oref this name) "_la_SOURCES")
+ (call-next-method)))
+
+
+(provide 'ede/proj-shared)
+
+;;; ede/proj-shared.el ends here
Index: cedet/ede/proj.el
===================================================================
RCS file: cedet/ede/proj.el
diff -N cedet/ede/proj.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/proj.el 28 Sep 2009 15:15:06 -0000 1.2
@@ -0,0 +1,675 @@
+;;; ede/proj.el --- EDE Generic Project file driver
+
+;;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2007, 2008, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: project, make
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; EDE defines a method for managing a project. EDE-PROJ aims to be a
+;; generic project file format based on the EIEIO object stream
+;; methods. Changes in the project structure will require Makefile
+;; rebuild. The targets provided in ede-proj can be augmented with
+;; additional target types inherited directly from `ede-proj-target'.
+
+;; (eval-and-compile '(require 'ede))
+(require 'ede/proj-comp)
+(require 'ede/make)
+
+(declare-function ede-proj-makefile-create "ede/pmake")
+(declare-function ede-proj-configure-synchronize "ede/pconf")
+
+(autoload 'ede-proj-target-aux "ede/proj-aux"
+ "Target class for a group of lisp files." nil nil)
+(autoload 'ede-proj-target-elisp "ede/proj-elisp"
+ "Target class for a group of lisp files." nil nil)
+(autoload 'ede-proj-target-elisp-autoloads "ede/proj-elisp"
+ "Target class for generating autoload files." nil nil)
+(autoload 'ede-proj-target-scheme "ede/proj-scheme"
+ "Target class for a group of lisp files." nil nil)
+(autoload 'ede-proj-target-makefile-miscelaneous "ede/proj-misc"
+ "Target class for a group of miscelaneous w/ a special makefile." nil nil)
+(autoload 'ede-proj-target-makefile-program "ede/proj-prog"
+ "Target class for building a program." nil nil)
+(autoload 'ede-proj-target-makefile-archive "ede/proj-archive"
+ "Target class for building an archive of object code." nil nil)
+(autoload 'ede-proj-target-makefile-shared-object "ede/proj-shared"
+ "Target class for building a shared object." nil nil)
+(autoload 'ede-proj-target-makefile-info "ede/proj-info"
+ "Target class for info files." nil nil)
+
+;;; Class Definitions:
+(defclass ede-proj-target (ede-target)
+ ((auxsource :initarg :auxsource
+ :initform nil
+ :type list
+ :custom (repeat (string :tag "File"))
+ :label "Auxiliary Source Files"
+ :group (default source)
+ :documentation "Auxilliary source files included in this target.
+Each of these is considered equivalent to a source file, but it is not
+distributed, and each should have a corresponding rule to build it.")
+ (dirty :initform nil
+ :type boolean
+ :documentation "Non-nil when generated files needs updating.")
+ (compiler :initarg :compiler
+ :initform nil
+ :type (or null symbol)
+ :custom (choice (const :tag "None" nil)
+ :slotofchoices availablecompilers)
+ :label "Compiler for building sources"
+ :group make
+ :documentation
+ "The compiler to be used to compile this object.
+This should be a symbol, which contains the object defining the compiler.
+This enables save/restore to do so by name, permitting the sharing
+of these compiler resources, and global customization thereof.")
+ (linker :initarg :linker
+ :initform nil
+ :type (or null symbol)
+ :custom (choice (const :tag "None" nil)
+ :slotofchoices availablelinkers)
+ :label "Linker for combining intermediate object files."
+ :group make
+ :documentation
+ "The linker to be used to link compiled sources for this object.
+This should be a symbol, which contains the object defining the linker.
+This enables save/restore to do so by name, permitting the sharing
+of these linker resources, and global customization thereof.")
+ ;; Class allocated slots
+ (phony :allocation :class
+ :initform nil
+ :type boolean
+ :documentation
+ "A phony target is one where the build target does not relate to a
file.
+Such targets are always built, but make knows how to deal with them..")
+ (availablecompilers :allocation :class
+ :initform nil
+ :type (or null list)
+ :documentation
+ "A list of `ede-compiler' objects.
+These are the compilers the user can choose from when setting the
+`compiler' slot.")
+ (availablelinkers :allocation :class
+ :initform nil
+ :type (or null list)
+ :documentation
+ "A list of `ede-linker' objects.
+These are the linkers the user can choose from when setting the
+`linker' slot.")
+ )
+ "Abstract class for ede-proj targets.")
+
+(defclass ede-proj-target-makefile (ede-proj-target)
+ ((makefile :initarg :makefile
+ :initform "Makefile"
+ :type string
+ :custom string
+ :label "Parent Makefile"
+ :group make
+ :documentation "File name of generated Makefile.")
+ (partofall :initarg :partofall
+ :initform t
+ :type boolean
+ :custom boolean
+ :label "Part of `all:' target"
+ :group make
+ :documentation
+ "Non nil means the rule created is part of the all target.
+Setting this to nil creates the rule to build this item, but does not
+include it in the ALL`all:' rule.")
+ (configuration-variables
+ :initarg :configuration-variables
+ :initform nil
+ :type list
+ :custom (repeat (cons (string :tag "Configuration")
+ (repeat
+ (cons (string :tag "Name")
+ (string :tag "Value")))))
+ :label "Environment Variables for configurations"
+ :group make
+ :documentation "Makefile variables appended to use in different
configurations.
+These variables are used in the makefile when a configuration becomes active.
+Target variables are always renamed such as foo_CFLAGS, then included into
+commands where the variable would usually appear.")
+ (rules :initarg :rules
+ :initform nil
+ :type list
+ :custom (repeat (object :objecttype ede-makefile-rule))
+ :label "Additional Rules"
+ :group (make)
+ :documentation
+ "Arbitrary rules and dependencies needed to make this target.
+It is safe to leave this blank.")
+ )
+ "Abstract class for Makefile based targets.")
+
+(defvar ede-proj-target-alist
+ '(("program" . ede-proj-target-makefile-program)
+ ("archive" . ede-proj-target-makefile-archive)
+ ("sharedobject" . ede-proj-target-makefile-shared-object)
+ ("emacs lisp" . ede-proj-target-elisp)
+ ("emacs lisp autoloads" . ede-proj-target-elisp-autoloads)
+ ("info" . ede-proj-target-makefile-info)
+ ("auxiliary" . ede-proj-target-aux)
+ ("scheme" . ede-proj-target-scheme)
+ ("miscellaneous" . ede-proj-target-makefile-miscelaneous)
+ )
+ "Alist of names to class types for available project target classes.")
+
+(defun ede-proj-register-target (name class)
+ "Register a new target class with NAME and class symbol CLASS.
+This enables the creation of your target type."
+ (let ((a (assoc name ede-proj-target-alist)))
+ (if a
+ (setcdr a class)
+ (setq ede-proj-target-alist
+ (cons (cons name class) ede-proj-target-alist)))))
+
+(defclass ede-proj-project (ede-project)
+ ((makefile-type :initarg :makefile-type
+ :initform Makefile
+ :type symbol
+ :custom (choice (const Makefile)
+ ;(const Makefile.in)
+ (const Makefile.am)
+ ;(const cook)
+ )
+ :documentation "The type of Makefile to generate.
+Can be one of 'Makefile, 'Makefile.in, or 'Makefile.am.
+If this value is NOT 'Makefile, then that overrides the :makefile slot
+in targets.")
+ (variables :initarg :variables
+ :initform nil
+ :type list
+ :custom (repeat (cons (string :tag "Name")
+ (string :tag "Value")))
+ :group (settings)
+ :documentation "Variables to set in this Makefile.")
+ (configuration-variables
+ :initarg :configuration-variables
+ :initform ("debug" (("DEBUG" . "1")))
+ :type list
+ :custom (repeat (cons (string :tag "Configuration")
+ (repeat
+ (cons (string :tag "Name")
+ (string :tag "Value")))))
+ :group (settings)
+ :documentation "Makefile variables to use in different configurations.
+These variables are used in the makefile when a configuration becomes active.")
+ (inference-rules :initarg :inference-rules
+ :initform nil
+ :custom (repeat
+ (object :objecttype ede-makefile-rule))
+ :documentation "Inference rules to add to the makefile.")
+ (include-file :initarg :include-file
+ :initform nil
+ :custom (repeat
+ (string :tag "Include File"))
+ :documentation "Additional files to include.
+These files can contain additional rules, variables, and customizations.")
+ (automatic-dependencies
+ :initarg :automatic-dependencies
+ :initform t
+ :type boolean
+ :custom boolean
+ :group (default settings)
+ :documentation
+ "Non-nil to do implement automatic dependencies in the Makefile.")
+ (menu :initform
+ (
+ [ "Regenerate Makefiles" ede-proj-regenerate t ]
+ [ "Upload Distribution" ede-upload-distribution t ]
+ )
+ )
+ (metasubproject
+ :initarg :metasubproject
+ :initform nil
+ :type boolean
+ :custom boolean
+ :group (default settings)
+ :documentation
+ "Non-nil if this is a metasubproject.
+Usually, a subproject is determined by a parent project. If multiple top level
+projects are grouped into a large project not maintained by EDE, then you need
+to set this to non-nil. The only effect is that the `dist' rule will then
avoid
+making a tar file.")
+ )
+ "The EDE-PROJ project definition class.")
+
+;;; Code:
+(defun ede-proj-load (project &optional rootproj)
+ "Load a project file from PROJECT directory.
+If optional ROOTPROJ is provided then ROOTPROJ is the root project
+for the tree being read in. If ROOTPROJ is nil, then assume that
+the PROJECT being read in is the root project."
+ (save-excursion
+ (let ((ret nil)
+ (subdirs (directory-files project nil "[^.].*" nil)))
+ (set-buffer (get-buffer-create " *tmp proj read*"))
+ (unwind-protect
+ (progn
+ (insert-file-contents (concat project "Project.ede")
+ nil nil nil t)
+ (goto-char (point-min))
+ (setq ret (read (current-buffer)))
+ (if (not (eq (car ret) 'ede-proj-project))
+ (error "Corrupt project file"))
+ (setq ret (eval ret))
+ (oset ret file (concat project "Project.ede"))
+ (oset ret directory project)
+ (oset ret rootproject rootproj)
+ )
+ (kill-buffer " *tmp proj read*"))
+ (while subdirs
+ (let ((sd (file-name-as-directory
+ (expand-file-name (car subdirs) project))))
+ (if (and (file-directory-p sd)
+ (ede-directory-project-p sd))
+ (oset ret subproj
+ (cons (ede-proj-load sd (or rootproj ret))
+ (oref ret subproj))))
+ (setq subdirs (cdr subdirs))))
+ ret)))
+
+(defun ede-proj-save (&optional project)
+ "Write out object PROJECT into its file."
+ (save-excursion
+ (if (not project) (setq project (ede-current-project)))
+ (let ((b (set-buffer (get-buffer-create " *tmp proj write*")))
+ (cfn (oref project file))
+ (cdir (oref project directory)))
+ (unwind-protect
+ (save-excursion
+ (erase-buffer)
+ (let ((standard-output (current-buffer)))
+ (oset project file (file-name-nondirectory cfn))
+ (slot-makeunbound project :directory)
+ (object-write project ";; EDE project file."))
+ (write-file cfn nil)
+ )
+ ;; Restore the :file on exit.
+ (oset project file cfn)
+ (oset project directory cdir)
+ (kill-buffer b)))))
+
+(defmethod ede-commit-local-variables ((proj ede-proj-project))
+ "Commit change to local variables in PROJ."
+ (ede-proj-save proj))
+
+(defmethod eieio-done-customizing ((proj ede-proj-project))
+ "Call this when a user finishes customizing this object.
+Argument PROJ is the project to save."
+ (call-next-method)
+ (ede-proj-save proj))
+
+(defmethod eieio-done-customizing ((target ede-proj-target))
+ "Call this when a user finishes customizing this object.
+Argument TARGET is the project we are completing customization on."
+ (call-next-method)
+ (ede-proj-save (ede-current-project)))
+
+(defmethod ede-commit-project ((proj ede-proj-project))
+ "Commit any change to PROJ to its file."
+ (ede-proj-save proj))
+
+(defmethod ede-buffer-mine ((this ede-proj-project) buffer)
+ "Return t if object THIS lays claim to the file in BUFFER."
+ (let ((f (ede-convert-path this (buffer-file-name buffer))))
+ (or (string= (file-name-nondirectory (oref this file)) f)
+ (string= (ede-proj-dist-makefile this) f)
+ (string-match "Makefile\\(\\.\\(in\\|am\\)\\)?$" f)
+ (string-match "config\\(ure\\.in\\|\\.stutus\\)?$" f)
+ )))
+
+(defmethod ede-buffer-mine ((this ede-proj-target) buffer)
+ "Return t if object THIS lays claim to the file in BUFFER."
+ (or (call-next-method)
+ (ede-target-buffer-in-sourcelist this buffer (oref this auxsource))))
+
+
+;;; EDE command functions
+;;
+(defvar ede-proj-target-history nil
+ "History when querying for a target type.")
+
+(defmethod project-new-target ((this ede-proj-project)
+ &optional name type autoadd)
+ "Create a new target in THIS based on the current buffer."
+ (let* ((name (or name (read-string "Name: " "")))
+ (type (or type
+ (completing-read "Type: " ede-proj-target-alist
+ nil t nil '(ede-proj-target-history . 1))))
+ (ot nil)
+ (src (if (and (buffer-file-name)
+ (if (and autoadd (stringp autoadd))
+ (string= autoadd "y")
+ (y-or-n-p (format "Add %s to %s? " (buffer-name)
name))))
+ (buffer-file-name)))
+ (fcn (cdr (assoc type ede-proj-target-alist)))
+ )
+
+ (when (not fcn)
+ (error "Unknown target type %s for EDE Project." type))
+
+ (setq ot (funcall fcn name :name name
+ :path (ede-convert-path this default-directory)
+ :source (if src
+ (list (file-name-nondirectory src))
+ nil)))
+ ;; If we added it, set the local buffer's object.
+ (if src (progn
+ (setq ede-object ot)
+ (ede-apply-object-keymap)))
+ ;; Add it to the project object
+ ;;(oset this targets (cons ot (oref this targets)))
+ ;; New form: Add to the end using fancy eieio function.
+ ;; @todone - Some targets probably want to be in the front.
+ ;; How to do that?
+ ;; @ans - See elisp autoloads for answer
+ (object-add-to-list this 'targets ot t)
+ ;; And save
+ (ede-proj-save this)))
+
+(defmethod project-new-target-custom ((this ede-proj-project))
+ "Create a new target in THIS for custom."
+ (let* ((name (read-string "Name: " ""))
+ (type (completing-read "Type: " ede-proj-target-alist
+ nil t nil '(ede-proj-target-history . 1))))
+ (funcall (cdr (assoc type ede-proj-target-alist)) name :name name
+ :path (ede-convert-path this default-directory)
+ :source nil)))
+
+(defmethod project-delete-target ((this ede-proj-target))
+ "Delete the current target THIS from it's parent project."
+ (let ((p (ede-current-project))
+ (ts (oref this source)))
+ ;; Loop across all sources. If it exists in a buffer,
+ ;; clear it's object.
+ (while ts
+ (let* ((default-directory (oref this path))
+ (b (get-file-buffer (car ts))))
+ (if b
+ (save-excursion
+ (set-buffer b)
+ (if (eq ede-object this)
+ (progn
+ (setq ede-object nil)
+ (ede-apply-object-keymap))))))
+ (setq ts (cdr ts)))
+ ;; Remove THIS from it's parent.
+ ;; The two vectors should be pointer equivalent.
+ (oset p targets (delq this (oref p targets)))
+ (ede-proj-save (ede-current-project))))
+
+(defmethod project-add-file ((this ede-proj-target) file)
+ "Add to target THIS the current buffer represented as FILE."
+ (let ((file (ede-convert-path this file))
+ (src (ede-target-sourcecode this)))
+ (while (and src (not (ede-want-file-p (car src) file)))
+ (setq src (cdr src)))
+ (when src
+ (setq src (car src))
+ (cond ((ede-want-file-source-p this file)
+ (object-add-to-list this 'source file t))
+ ((ede-want-file-auxiliary-p this file)
+ (object-add-to-list this 'auxsource file t))
+ (t (error "`project-add-file(ede-target)' source mismatch error")))
+ (ede-proj-save))))
+
+(defmethod project-remove-file ((target ede-proj-target) file)
+ "For TARGET, remove FILE.
+FILE must be massaged by `ede-convert-path'."
+ ;; Speedy delete should be safe.
+ (object-remove-from-list target 'source (ede-convert-path target file))
+ (object-remove-from-list target 'auxsource (ede-convert-path target file))
+ (ede-proj-save))
+
+(defmethod project-update-version ((this ede-proj-project))
+ "The :version of project THIS has changed."
+ (ede-proj-save))
+
+(defmethod project-make-dist ((this ede-proj-project))
+ "Build a distribution for the project based on THIS target."
+ ;; I'm a lazy bum, so I'll make a makefile for doing this sort
+ ;; of thing, and rely only on that small section of code.
+ (let ((pm (ede-proj-dist-makefile this))
+ (df (project-dist-files this)))
+ (if (and (file-exists-p (car df))
+ (not (y-or-n-p "Dist file already exists. Rebuild? ")))
+ (error "Try `ede-update-version' before making a distribution"))
+ (ede-proj-setup-buildenvironment this)
+ (if (string= pm "Makefile.am") (setq pm "Makefile"))
+ (compile (concat ede-make-command " -f " pm " dist"))
+ ))
+
+(defmethod project-dist-files ((this ede-proj-project))
+ "Return a list of files that constitutes a distribution of THIS project."
+ (list
+ ;; Note to self, keep this first for the above fn to check against.
+ (concat (oref this name) "-" (oref this version) ".tar.gz")
+ ))
+
+(defmethod project-compile-project ((proj ede-proj-project) &optional command)
+ "Compile the entire current project PROJ.
+Argument COMMAND is the command to use when compiling."
+ (let ((pm (ede-proj-dist-makefile proj))
+ (default-directory (file-name-directory (oref proj file))))
+ (ede-proj-setup-buildenvironment proj)
+ (if (string= pm "Makefile.am") (setq pm "Makefile"))
+ (compile (concat ede-make-command" -f " pm " all"))))
+
+;;; Target type specific compilations/debug
+;;
+(defmethod project-compile-target ((obj ede-proj-target) &optional command)
+ "Compile the current target OBJ.
+Argument COMMAND is the command to use for compiling the target."
+ (project-compile-project (ede-current-project) command))
+
+(defmethod project-compile-target ((obj ede-proj-target-makefile)
+ &optional command)
+ "Compile the current target program OBJ.
+Optional argument COMMAND is the s the alternate command to use."
+ (ede-proj-setup-buildenvironment (ede-current-project))
+ (compile (concat ede-make-command " -f " (oref obj makefile) " "
+ (ede-proj-makefile-target-name obj))))
+
+(defmethod project-debug-target ((obj ede-proj-target))
+ "Run the current project target OBJ in a debugger."
+ (error "Debug-target not supported by %s" (object-name obj)))
+
+(defmethod ede-proj-makefile-target-name ((this ede-proj-target))
+ "Return the name of the main target for THIS target."
+ (ede-name this))
+
+;;; Compiler and source code generators
+;;
+(defmethod ede-want-file-auxiliary-p ((this ede-target) file)
+ "Return non-nil if THIS target wants FILE."
+ ;; By default, all targets reference the source object, and let it decide.
+ (let ((src (ede-target-sourcecode this)))
+ (while (and src (not (ede-want-file-auxiliary-p (car src) file)))
+ (setq src (cdr src)))
+ src))
+
+(defmethod ede-proj-compilers ((obj ede-proj-target))
+ "List of compilers being used by OBJ.
+If the `compiler' slot is empty, concoct one on a first match found
+basis for any given type from the `availablecompilers' slot.
+Otherwise, return the `compiler' slot.
+Converts all symbols into the objects to be used."
+ (when (slot-exists-p obj 'compiler)
+ (let ((comp (oref obj compiler)))
+ (if comp
+ ;; Now that we have a pre-set compilers to use, convert tye symbols
+ ;; into objects for ease of use
+ (if (listp comp)
+ (setq comp (mapcar 'symbol-value comp))
+ (setq comp (list (symbol-value comp))))
+ (let* ((acomp (oref obj availablecompilers))
+ (avail (mapcar 'symbol-value acomp))
+ (st (oref obj sourcetype))
+ (sources (oref obj source)))
+ ;; COMP is not specified, so generate a list from the available
+ ;; compilers list.
+ (while st
+ (if (ede-want-any-source-files-p (symbol-value (car st)) sources)
+ (let ((c (ede-proj-find-compiler avail (car st))))
+ (if c (setq comp (cons c comp)))))
+ (setq st (cdr st)))))
+ ;; Return the disovered compilers
+ comp)))
+
+(defmethod ede-proj-linkers ((obj ede-proj-target))
+ "List of linkers being used by OBJ.
+If the `linker' slot is empty, concoct one on a first match found
+basis for any given type from the `availablelinkers' slot.
+Otherwise, return the `linker' slot.
+Converts all symbols into the objects to be used."
+ (when (slot-exists-p obj 'linker)
+ (let ((link (oref obj linker)))
+ (if link
+ ;; Now that we have a pre-set linkers to use, convert type symbols
+ ;; into objects for ease of use
+ (if (symbolp link)
+ (setq link (list (symbol-value link)))
+ (error ":linker is not a symbol. Howd you do that?"))
+ (let* ((alink (oref obj availablelinkers))
+ (avail (mapcar 'symbol-value alink))
+ (st (oref obj sourcetype))
+ (sources (oref obj source)))
+ ;; LINKER is not specified, so generate a list from the available
+ ;; compilers list.
+ (while st
+ (if (ede-want-any-source-files-p (symbol-value (car st)) sources)
+ (let ((c (ede-proj-find-linker avail (car st))))
+ (if c (setq link (cons c link)))))
+ (setq st (cdr st)))
+ (unless link
+ ;; No linker stands out! Loop over our linkers and pull out
+ ;; the first that has no source type requirement.
+ (while (and avail (not (eieio-instance-inheritor-slot-boundp (car
avail) 'sourcetype)))
+ (setq avail (cdr avail)))
+ (setq link (cdr avail)))))
+ ;; Return the disovered linkers
+ link)))
+
+
+;;; Target type specific autogenerating gobbldegook.
+;;
+
+(defun ede-proj-makefile-type (&optional proj)
+ "Makefile type of the current project PROJ."
+ (oref (or proj (ede-current-project)) makefile-type))
+
+(defun ede-proj-automake-p (&optional proj)
+ "Return non-nil if the current project PROJ is automake mode."
+ (eq (ede-proj-makefile-type proj) 'Makefile.am))
+
+(defun ede-proj-autoconf-p (&optional proj)
+ "Return non-nil if the current project PROJ is automake mode."
+ (eq (ede-proj-makefile-type proj) 'Makefile.in))
+
+(defun ede-proj-make-p (&optional proj)
+ "Return non-nil if the current project PROJ is automake mode."
+ (eq (ede-proj-makefile-type proj) 'Makefile))
+
+(defmethod ede-proj-dist-makefile ((this ede-proj-project))
+ "Return the name of the Makefile with the DIST target in it for THIS."
+ (cond ((eq (oref this makefile-type) 'Makefile.am)
+ (concat (file-name-directory (oref this file))
+ "Makefile.am"))
+ ((eq (oref this makefile-type) 'Makefile.in)
+ (concat (file-name-directory (oref this file))
+ "Makefile.in"))
+ ((object-assoc "Makefile" 'makefile (oref this targets))
+ (concat (file-name-directory (oref this file))
+ "Makefile"))
+ (t
+ (let ((targets (oref this targets)))
+ (while (and targets
+ (not (obj-of-class-p
+ (car targets)
+ 'ede-proj-target-makefile)))
+ (setq targets (cdr targets)))
+ (if targets (oref (car targets) makefile)
+ (concat (file-name-directory (oref this file))
+ "Makefile"))))))
+
+(defun ede-proj-regenerate ()
+ "Regenerate Makefiles for and edeproject project."
+ (interactive)
+ (ede-proj-setup-buildenvironment (ede-current-project) t))
+
+(defmethod ede-proj-makefile-create-maybe ((this ede-proj-project) mfilename)
+ "Create a Makefile for all Makefile targets in THIS if needed.
+MFILENAME is the makefile to generate."
+ ;; For now, pass through until dirty is implemented.
+ (require 'ede/pmake)
+ (if (or (not (file-exists-p mfilename))
+ (file-newer-than-file-p (oref this file) mfilename))
+ (ede-proj-makefile-create this mfilename)))
+
+(defmethod ede-proj-setup-buildenvironment ((this ede-proj-project)
+ &optional force)
+ "Setup the build environment for project THIS.
+Handles the Makefile, or a Makefile.am configure.in combination.
+Optional argument FORCE will force items to be regenerated."
+ (if (not force)
+ (ede-proj-makefile-create-maybe this (ede-proj-dist-makefile this))
+ (require 'ede/pmake)
+ (ede-proj-makefile-create this (ede-proj-dist-makefile this)))
+ ;; Rebuild all subprojects
+ (ede-map-subprojects
+ this (lambda (sproj) (ede-proj-setup-buildenvironment sproj force)))
+ ;; Autoconf projects need to do other kinds of initializations.
+ (when (and (ede-proj-automake-p this)
+ (eq this (ede-toplevel this)))
+ (require 'ede/pconf)
+ ;; If the user wants to force this, do it some other way?
+ (ede-proj-configure-synchronize this)
+ ;; Now run automake to fill in the blanks, autoconf, and other
+ ;; auto thingies so that we can just say "make" when done.
+ )
+ )
+
+
+;;; Lower level overloads
+;;
+(defmethod project-rescan ((this ede-proj-project))
+ "Rescan the EDE proj project THIS."
+ (let ((root (or (ede-project-root this) this))
+ )
+ (setq ede-projects (delq root ede-projects))
+ (ede-proj-load (ede-project-root-directory root))
+ ))
+
+(defmethod project-rescan ((this ede-proj-target) readstream)
+ "Rescan target THIS from the read list READSTREAM."
+ (setq readstream (cdr (cdr readstream))) ;; constructor/name
+ (while readstream
+ (let ((tag (car readstream))
+ (val (car (cdr readstream))))
+ (eieio-oset this tag val))
+ (setq readstream (cdr (cdr readstream)))))
+
+(provide 'ede/proj)
+
+;;; ede/proj.el ends here
Index: cedet/ede/project-am.el
===================================================================
RCS file: cedet/ede/project-am.el
diff -N cedet/ede/project-am.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/project-am.el 28 Sep 2009 15:15:06 -0000 1.2
@@ -0,0 +1,994 @@
+;;; project-am.el --- A project management scheme based on automake files.
+
+;;; Copyright (C) 1998, 1999, 2000, 2003, 2005, 2007, 2008, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Version: 0.0.3
+;; Keywords: project, make
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; The GNU Automake tool is the first step towards having a really
+;; good project management system. It provides a simple and concise
+;; look at what is actually in a project, and records it in a simple
+;; fashion.
+;;
+;; project-am uses the structure defined in all good GNU projects with
+;; the Automake file as it's base template, and then maintains that
+;; information during edits, automatically updating the automake file
+;; where appropriate.
+
+
+;; (eval-and-compile
+;; ;; Compatibility for makefile mode.
+;; (condition-case nil
+;; (require 'makefile "make-mode")
+;; (error (require 'make-mode "make-mode")))
+
+;; ;; Requiring the .el files prevents incomplete builds.
+;; (require 'eieio "eieio.el")
+;; (require 'ede "ede.el"))
+
+(require 'make-mode)
+(require 'ede)
+(require 'ede/make)
+(require 'ede/makefile-edit)
+
+(declare-function autoconf-parameters-for-macro "ede/autoconf-edit")
+(eval-when-compile (require 'compile))
+
+;;; Code:
+(defgroup project-am nil
+ "File and tag browser frame."
+ :group 'tools
+ :group 'ede
+ )
+
+(defcustom project-am-compile-project-command nil
+ "*Default command used to compile a project."
+ :group 'project-am
+ :type 'string)
+
+(defcustom project-am-compile-target-command (concat ede-make-command " -k %s")
+ "*Default command used to compile a project."
+ :group 'project-am
+ :type 'string)
+
+(defcustom project-am-debug-target-function 'gdb
+ "*Default Emacs command used to debug a target."
+ :group 'project-am
+ :type 'sexp) ; make this be a list some day
+
+(defconst project-am-type-alist
+ '(("bin" project-am-program "bin_PROGRAMS" t)
+ ("sbin" project-am-program "sbin_PROGRAMS" t)
+ ("noinstbin" project-am-program "noinst_PROGRAMS" t)
+ ("checkbin" project-am-program "check_PROGRAMS" t)
+ ("lib" project-am-lib "lib_LIBS" t)
+ ("libraries" project-am-lib "lib_LIBRARIES" t)
+ ("librariesnoinst" project-am-lib "noinst_LIBRARIES" t)
+ ("pkglibraries" project-am-lib "pkglib_LIBRARIES" t)
+ ("checklibs" project-am-lib "check_LIBRARIES" t)
+ ("ltlibraries" project-am-lib "lib_LTLIBRARIES" t)
+ ("ltlibrariesnoinst" project-am-lib "noinst_LTLIBRARIES" t)
+ ("pkgltlibraries" project-am-lib "pkglib_LTLIBRARIES" t)
+ ("checkltlibs" project-am-lib "check_LTLIBRARIES" t)
+ ("headernoinst" project-am-header-noinst "noinst_HEADERS")
+ ("headerinst" project-am-header-inst "include_HEADERS")
+ ("headerpkg" project-am-header-pkg "pkginclude_HEADERS")
+ ("headerpkg" project-am-header-chk "check_HEADERS")
+ ("texinfo" project-am-texinfo "info_TEXINFOS" t)
+ ("man" project-am-man "man_MANS")
+ ("lisp" project-am-lisp "lisp_LISP")
+ ;; for other global files track EXTRA_
+ ("extrabin" project-am-program "EXTRA_PROGRAMS" t)
+ ("builtsrcs" project-am-built-src "BUILT_SOURCES")
+ ("extradist" project-am-extra-dist "EXTRA_DIST")
+ ;; Custom libraries targets?
+ ;; ("ltlibcustom" project-am-lib ".*?_LTLIBRARIES" t)
+ )
+ "Alist of type names and the type of object to create for them.
+Each entry is of th form:
+ (EMACSNAME CLASS AUToMAKEVAR INDIRECT)
+where EMACSNAME is a name for Emacs to use.
+CLASS is the EDE target class to represent the target.
+AUTOMAKEVAR is the Automake variable to identify. This cannot be a
+ regular expression.
+INDIRECT is optional. If it is non-nil, then the variable in
+question lists other variables that need to be looked up.")
+
+(defclass project-am-target (ede-target)
+ nil
+ "Base target class for everything in project-am.")
+
+(defclass project-am-objectcode (project-am-target)
+ ((source :initarg :source :documentation "List of source files."))
+ "A target which creates object code, like a C program or library.")
+
+(defclass project-am-program (project-am-objectcode)
+ ((ldadd :initarg :ldadd :documentation "Additional LD args."
+ :initform nil))
+ "A top level program to build")
+
+(defclass project-am-header (project-am-target)
+ ()
+ "A group of misc source files, such as headers.")
+
+(defclass project-am-header-noinst (project-am-header)
+ ()
+ "A group of header files that are not installed.")
+
+(defclass project-am-header-inst (project-am-header)
+ ()
+ "A group of header files that are not installed.")
+
+(defclass project-am-header-pkg (project-am-header)
+ ()
+ "A group of header files that are not installed.")
+
+(defclass project-am-header-chk (project-am-header)
+ ()
+ "A group of header files that are not installed.")
+
+(defclass project-am-lib (project-am-objectcode)
+ nil
+ "A top level library to build")
+
+(defclass project-am-lisp (project-am-target)
+ ()
+ "A group of Emacs Lisp programs to byte compile.")
+
+(defclass project-am-texinfo (project-am-target)
+ ((include :initarg :include
+ :initform nil
+ :documentation "Additional texinfo included in this one."))
+ "A top level texinfo file to build.")
+
+(defclass project-am-man (project-am-target)
+ nil
+ "A top level man file to build.")
+
+;; For generic files tracker like EXTRA_DIST
+(defclass project-am-built-src (project-am-target)
+ ()
+ "A group of Emacs Lisp programs to byte compile.")
+
+(defclass project-am-extra-dist (project-am-target)
+ ()
+ "A group of Emacs Lisp programs to byte compile.")
+
+(defclass project-am-makefile (ede-project)
+ ((targets :initarg :targets
+ :initform nil
+ :documentation "Top level targets in this makefile.")
+ (configureoutputfiles
+ :initform nil
+ :documentation
+ "List of files output from configure system.")
+ )
+ "Encode one makefile.")
+
+;;; Code:
+(defmethod project-add-file ((ot project-am-target))
+ "Add the current buffer into a project.
+OT is the object target. DIR is the directory to start in."
+ (let* ((target (if ede-object (error "Already assocated w/ a target")
+ (let ((amf (project-am-load default-directory)))
+ (if (not amf) (error "No project file"))
+ (completing-read "Target: "
+ (object-assoc-list 'name
+ (oref amf targets))
+ nil t))))
+ ;; The input target might be new. See if we can find it.
+ (amf (ede-load-project-file (oref ot path)))
+ (ot (object-assoc target 'name (oref amf targets)))
+ (ofn (file-name-nondirectory (buffer-file-name))))
+ (if (not ot)
+ (setq ot
+ (project-new-target
+ target (project-am-preferred-target-type (buffer-file-name)))))
+ (ede-with-projectfile ot
+ (makefile-move-to-macro (project-am-macro ot))
+ (ede-maybe-checkout)
+ (makefile-end-of-command)
+ (insert " " ofn)
+ (makefile-fill-paragraph nil)
+ (project-rescan ot)
+ (save-buffer))
+ (setq ede-object ot)))
+
+(defmethod project-remove-file ((ot project-am-target) fnnd)
+ "Remove the current buffer from any project targets."
+ (ede-with-projectfile ot
+ (makefile-move-to-macro (project-am-macro ot))
+ (if (and buffer-read-only vc-mode
+ (y-or-n-p "Checkout Makefile.am from VC? "))
+ (vc-toggle-read-only t))
+ (ede-maybe-checkout)
+ (makefile-navigate-macro (concat " *" (regexp-quote (ede-name fnnd))))
+ (replace-match "" t t nil 0)
+ (makefile-fill-paragraph nil)
+ (project-rescan ot)
+ (save-buffer))
+ (setq ede-object nil))
+
+(defmethod project-edit-file-target ((obj project-am-target))
+ "Edit the target associated w/ this file."
+ (find-file (concat (oref obj path) "Makefile.am"))
+ (goto-char (point-min))
+ (makefile-move-to-macro (project-am-macro obj))
+ (if (= (point-min) (point))
+ (re-search-forward (ede-target-name obj))))
+
+(defmethod project-new-target ((proj project-am-makefile)
+ &optional name type)
+ "Create a new target named NAME.
+Argument TYPE is the type of target to insert. This is a string
+matching something in `project-am-type-alist' or type class symbol.
+Despite the fact that this is a method, it depends on the current
+buffer being in order to provide a smart default target type."
+ (let* ((name (or name (read-string "Name: " "")))
+ (type (or type
+ (completing-read "Type: "
+ project-am-type-alist
+ nil t
+ (cond ((eq major-mode 'texinfo-mode)
+ "texinfo")
+ ((eq major-mode 'nroff-mode)
+ "man")
+ ((eq major-mode 'emacs-lisp-mode)
+ "lisp")
+ (t "bin")))))
+ (ntype (assoc type project-am-type-alist))
+ (ot nil))
+ (setq ot (apply (car (cdr ntype)) name :name name
+ :path (expand-file-name default-directory) nil))
+ (if (not ot) (error "Error creating target object %S" ntype))
+ (ede-with-projectfile ot
+ (goto-char (point-min))
+ (ede-maybe-checkout)
+ (makefile-next-dependency)
+ (if (= (point) (point-min))
+ (goto-char (point-max))
+ (beginning-of-line)
+ (insert "\n")
+ (forward-char -1))
+ ;; Add the new target sources macro (if needed)
+ (if (project-am-macro ot)
+ (makefile-insert-macro (project-am-macro ot)))
+ ;; Add to the list of objects.
+ (goto-char (point-min))
+ (makefile-move-to-macro (car (cdr (cdr ntype))))
+ (if (= (point) (point-min))
+ (progn
+ (if (re-search-forward makefile-macroassign-regex nil t)
+ (progn (forward-line -1)
+ (end-of-line)
+ (insert "\n"))
+ ;; If the above search fails, thats ok. We'd just want to be at
+ ;; point-min anyway.
+ )
+ (makefile-insert-macro (car (cdr (cdr ntype))))))
+ (makefile-end-of-command)
+ (insert " " (ede-target-name ot))
+ (save-buffer)
+ ;; Rescan the object in this makefile.
+ (project-rescan ede-object))))
+
+;(defun project-am-rescan-toplevel ()
+; "Rescan all projects in which the current buffer resides."
+; (interactive)
+; (let* ((tlof (project-am-find-topmost-level default-directory))
+; (tlo (project-am-load tlof))
+; (ede-deep-rescan t)) ; scan deep in this case.
+; ;; tlo is the top level object for whatever file we are in
+; ;; or nil. If we have an object, call the rescan method.
+; (if tlo (project-am-rescan tlo))))
+
+;;
+;; NOTE TO SELF
+;;
+;; This should be handled at the EDE level, calling a method of the
+;; top most project.
+;;
+(defmethod project-compile-project ((obj project-am-target) &optional command)
+ "Compile the entire current project.
+Argument COMMAND is the command to use when compiling."
+ (require 'compile)
+ (if (not command)
+ (setq
+ command
+ ;; This interactive statement was taken from compile, and I'll
+ ;; use the same command history too.
+ (progn
+ (if (not project-am-compile-project-command)
+ (setq project-am-compile-project-command compile-command))
+ (if (or compilation-read-command current-prefix-arg)
+ (read-from-minibuffer "Project compile command: "
+ ;; hardcode make -k
+ ;; This is compile project after all.
+ project-am-compile-project-command
+ nil nil '(compile-history . 1))
+ project-am-compile-project-command))))
+ ;; When compile a project, we might be in a subdirectory,
+ ;; so we have to make sure we move all the way to the top.
+ (let* ((default-directory (project-am-find-topmost-level default-directory)))
+ (compile command)))
+
+(defmethod project-compile-project ((obj project-am-makefile)
+ &optional command)
+ "Compile the entire current project.
+Argument COMMAND is the command to use when compiling."
+ (require 'compile)
+ (if (not command)
+ (setq
+ command
+ ;; This interactive statement was taken from compile, and I'll
+ ;; use the same command history too.
+ (progn
+ (if (not project-am-compile-project-command)
+ (setq project-am-compile-project-command compile-command))
+ (if (or compilation-read-command current-prefix-arg)
+ (read-from-minibuffer "Project compile command: "
+ ;; hardcode make -k
+ ;; This is compile project after all.
+ project-am-compile-project-command
+ nil nil '(compile-history . 1))
+ project-am-compile-project-command))))
+ ;; When compile a project, we might be in a subdirectory,
+ ;; so we have to make sure we move all the way to the top.
+ (let* ((default-directory (project-am-find-topmost-level default-directory)))
+ (compile command)))
+
+(defmethod project-compile-target ((obj project-am-target) &optional command)
+ "Compile the current target.
+Argument COMMAND is the command to use for compiling the target."
+ (require 'compile)
+ (if (not project-am-compile-project-command)
+ (setq project-am-compile-project-command compile-command))
+ (if (not command)
+ (setq
+ command
+ (if compilation-read-command
+ (read-from-minibuffer "Project compile command: "
+ ;; hardcode make -k
+ ;; This is compile project after all.
+ (if ede-object
+ (format
+ project-am-compile-target-command
+ (project-compile-target-command
+ ede-object))
+ project-am-compile-target-command)
+ nil nil
+ '(compile-history . 1))
+ (if ede-object
+ project-am-compile-project-command
+ (format
+ project-am-compile-target-command
+ (project-compile-target-command ede-object))))))
+ ;; We better be in the right place when compiling a specific target.
+ (compile command))
+
+(defmethod project-debug-target ((obj project-am-objectcode))
+ "Run the current project target in a debugger."
+ (let ((tb (get-buffer-create " *padt*"))
+ (dd (oref obj path))
+ (cmd nil))
+ (unwind-protect
+ (progn
+ (set-buffer tb)
+ (setq default-directory dd)
+ (setq cmd (read-from-minibuffer
+ "Run (like this): "
+ (concat (symbol-name project-am-debug-target-function)
+ " " (ede-target-name obj))))
+ (funcall project-am-debug-target-function cmd))
+ (kill-buffer tb))))
+
+(defmethod project-make-dist ((this project-am-target))
+ "Run the current project in the debugger."
+ (require 'compile)
+ (if (not project-am-compile-project-command)
+ (setq project-am-compile-project-command compile-command))
+ (project-compile-project this (concat project-am-compile-project-command
+ " dist")))
+
+;;; Project loading and saving
+;;
+(defun project-am-load (project &optional rootproj)
+ "Read an automakefile PROJECT into our data structure.
+Make sure that the tree down to our makefile is complete so that there
+is cohesion in the project. Return the project file (or sub-project).
+If a given set of projects has already been loaded, then do nothing
+but return the project for the directory given.
+Optional ROOTPROJ is the root EDE project."
+ ;; @TODO - rationalize this to the newer EDE way of doing things.
+ (setq project (expand-file-name project))
+ (let* ((ede-constructing t)
+ (fn (project-am-find-topmost-level (file-name-as-directory project)))
+ (amo nil)
+ (trimmed (if (string-match (regexp-quote fn)
+ project)
+ (replace-match "" t t project)
+ ""))
+ (subdir nil))
+ (setq amo (object-assoc (expand-file-name "Makefile.am" fn)
+ 'file ede-projects))
+ (if amo
+ (error "Synchronous error in ede/project-am objects")
+ (let ((project-am-constructing t))
+ (setq amo (project-am-load-makefile fn))))
+ (if (not amo)
+ nil
+ ;; Now scan down from amo, and find the current directory
+ ;; from the PROJECT file.
+ (while (< 0 (length trimmed))
+ (if (string-match "\\([a-zA-Z0-9.-]+\\)/" trimmed)
+ (setq subdir (match-string 0 trimmed)
+ trimmed (replace-match "" t t trimmed))
+ (error "Error scanning down path for project"))
+ (setq amo (project-am-subtree
+ amo
+ (expand-file-name "Makefile.am"
+ (expand-file-name subdir fn)))
+ fn (expand-file-name subdir fn)))
+ amo)
+ ))
+
+(defun project-am-find-topmost-level (dir)
+ "Find the topmost automakefile starting with DIR."
+ (let ((newdir dir))
+ (while (or (file-exists-p (concat newdir "Makefile.am"))
+ (file-exists-p (concat newdir "configure.ac"))
+ (file-exists-p (concat newdir "configure.in"))
+ )
+ (setq dir newdir newdir
+ (file-name-directory (directory-file-name newdir))))
+ (expand-file-name dir)))
+
+(defmacro project-am-with-makefile-current (dir &rest forms)
+ "Set the Makefile.am in DIR to be the current buffer.
+Run FORMS while the makefile is current.
+Kill the makefile if it was not loaded before the load."
+ `(let* ((fn (expand-file-name "Makefile.am" ,dir))
+ (fb nil)
+ (kb (get-file-buffer fn)))
+ (if (not (file-exists-p fn))
+ nil
+ (save-excursion
+ (if kb (setq fb kb)
+ ;; We need to find-file this thing, but don't use
+ ;; any semantic features.
+ (let ((semantic-init-hook nil))
+ (setq fb (find-file-noselect fn)))
+ )
+ (set-buffer fb)
+ (prog1 ,@forms
+ (if (not kb) (kill-buffer (current-buffer))))))))
+(put 'project-am-with-makefile-current 'lisp-indent-function 1)
+
+(add-hook 'edebug-setup-hook
+ (lambda ()
+ (def-edebug-spec project-am-with-makefile-current
+ (form def-body))))
+
+
+(defun project-am-load-makefile (path)
+ "Convert PATH into a project Makefile, and return its project object.
+It does not check for existing project objects. Use `project-am-load'."
+ (project-am-with-makefile-current path
+ (if (and ede-object (project-am-makefile-p ede-object))
+ ede-object
+ (let* ((pi (project-am-package-info path))
+ (pn (or (nth 0 pi) (project-am-last-dir fn)))
+ (ver (or (nth 1 pi) "0.0"))
+ (bug (nth 2 pi))
+ (cof (nth 3 pi))
+ (ampf (project-am-makefile
+ pn :name pn
+ :version ver
+ :mailinglist (or bug "")
+ :file fn)))
+ (oset ampf :directory (file-name-directory fn))
+ (oset ampf configureoutputfiles cof)
+ (make-local-variable 'ede-object)
+ (setq ede-object ampf)
+ ;; Move the rescan after we set ede-object to prevent recursion
+ (project-rescan ampf)
+ ampf))))
+
+;;; Methods:
+(defmethod ede-find-target ((amf project-am-makefile) buffer)
+ "Fetch the target belonging to BUFFER."
+ (or (call-next-method)
+ (let ((targ (oref amf targets))
+ (sobj (oref amf subproj))
+ (obj nil))
+ (while (and targ (not obj))
+ (if (ede-buffer-mine (car targ) buffer)
+ (setq obj (car targ)))
+ (setq targ (cdr targ)))
+ (while (and sobj (not obj))
+ (setq obj (project-am-buffer-object (car sobj) buffer)
+ sobj (cdr sobj)))
+ obj)))
+
+(defmethod project-targets-for-file ((proj project-am-makefile))
+ "Return a list of targets the project PROJ."
+ (oref proj targets))
+
+(defun project-am-scan-for-targets (currproj dir)
+ "Scan the current Makefile.am for targets.
+CURRPROJ is the current project being scanned.
+DIR is the directory to apply to new targets."
+ (let* ((otargets (oref currproj targets))
+ (ntargets nil)
+ (tmp nil)
+ )
+ (mapc
+ ;; Map all the different types
+ (lambda (typecar)
+ (let ((macro (nth 2 typecar))
+ (class (nth 1 typecar))
+ (indirect (nth 3 typecar))
+ ;(name (car typecar))
+ )
+ (if indirect
+ ;; Map all the found objects
+ (mapc (lambda (lstcar)
+ (setq tmp (object-assoc lstcar 'name otargets))
+ (when (not tmp)
+ (setq tmp (apply class lstcar :name lstcar
+ :path dir nil)))
+ (project-rescan tmp)
+ (setq ntargets (cons tmp ntargets)))
+ (makefile-macro-file-list macro))
+ ;; Non-indirect will have a target whos sources
+ ;; are actual files, not names of other targets.
+ (let ((files (makefile-macro-file-list macro)))
+ (when files
+ (setq tmp (object-assoc macro 'name otargets))
+ (when (not tmp)
+ (setq tmp (apply class macro :name macro
+ :path dir nil)))
+ (project-rescan tmp)
+ (setq ntargets (cons tmp ntargets))
+ ))
+ )
+ ))
+ project-am-type-alist)
+ ntargets))
+
+(defmethod project-rescan ((this project-am-makefile))
+ "Rescan the makefile for all targets and sub targets."
+ (project-am-with-makefile-current (file-name-directory (oref this file))
+ ;;(message "Scanning %s..." (oref this file))
+ (let* ((pi (project-am-package-info (oref this directory)))
+ (pn (nth 0 pi))
+ (pv (nth 1 pi))
+ (bug (nth 2 pi))
+ (cof (nth 3 pi))
+ (osubproj (oref this subproj))
+ (csubproj (or
+ ;; If DIST_SUBDIRS doesn't exist, then go for the
+ ;; static list of SUBDIRS. The DIST version should
+ ;; contain SUBDIRS plus extra stuff.
+ (makefile-macro-file-list "DIST_SUBDIRS")
+ (makefile-macro-file-list "SUBDIRS")))
+ (csubprojexpanded nil)
+ (nsubproj nil)
+ ;; Targets are excluded here because they require
+ ;; special attention.
+ (dir (expand-file-name default-directory))
+ (tmp nil)
+ (ntargets (project-am-scan-for-targets this dir))
+ )
+
+ (and pn (string= (directory-file-name
+ (oref this directory))
+ (directory-file-name
+ (project-am-find-topmost-level
+ (oref this directory))))
+ (oset this name pn)
+ (and pv (oset this version pv))
+ (and bug (oset this mailinglist bug))
+ (oset this configureoutputfiles cof))
+
+; ;; LISP is different. Here there is only one kind of lisp (that I know
of
+; ;; anyway) so it doesn't get mapped when it is found.
+; (if (makefile-move-to-macro "lisp_LISP")
+; (let ((tmp (project-am-lisp "lisp"
+; :name "lisp"
+; :path dir)))
+; (project-rescan tmp)
+; (setq ntargets (cons tmp ntargets))))
+;
+ ;; Now that we have this new list, chuck the old targets
+ ;; and replace it with the new list of targets I just created.
+ (oset this targets (nreverse ntargets))
+ ;; We still have a list of targets. For all buffers, make sure
+ ;; their object still exists!
+
+ ;; FIGURE THIS OUT
+
+ (mapc (lambda (sp)
+ (let ((var (makefile-extract-varname-from-text sp))
+ )
+ (if (not var)
+ (setq csubprojexpanded (cons sp csubprojexpanded))
+ ;; If it is a variable, expand that variable, and keep going.
+ (let ((varexp (makefile-macro-file-list var)))
+ (dolist (V varexp)
+ (setq csubprojexpanded (cons V csubprojexpanded)))))
+ ))
+ csubproj)
+
+ ;; Ok, now lets look at all our sub-projects.
+ (mapc (lambda (sp)
+ (let* ((subdir (file-name-as-directory
+ (expand-file-name
+ sp (file-name-directory (oref this :file)))))
+ (submake (expand-file-name
+ "Makefile.am"
+ subdir)))
+ (if (string= submake (oref this :file))
+ nil ;; don't recurse.. please!
+
+ ;; For each project id found, see if we need to recycle,
+ ;; and if we do not, then make a new one. Check the deep
+ ;; rescan value for behavior patterns.
+ (setq tmp (object-assoc
+ submake
+ 'file osubproj))
+ (if (not tmp)
+ (setq tmp
+ (condition-case nil
+ ;; In case of problem, ignore it.
+ (project-am-load-makefile subdir)
+ (error nil)))
+ ;; If we have tmp, then rescan it only if deep mode.
+ (if ede-deep-rescan
+ (project-rescan tmp)))
+ ;; Tac tmp onto our list of things to keep, but only
+ ;; if tmp was found.
+ (when tmp
+ ;;(message "Adding %S" (object-print tmp))
+ (setq nsubproj (cons tmp nsubproj)))))
+ )
+ (nreverse csubprojexpanded))
+ (oset this subproj nsubproj)
+ ;; All elements should be updated now.
+ )))
+
+
+(defmethod project-rescan ((this project-am-program))
+ "Rescan object THIS."
+ (oset this :source (makefile-macro-file-list (project-am-macro this)))
+ (oset this :ldadd (makefile-macro-file-list
+ (concat (oref this :name) "_LDADD"))))
+
+(defmethod project-rescan ((this project-am-lib))
+ "Rescan object THIS."
+ (oset this :source (makefile-macro-file-list (project-am-macro this))))
+
+(defmethod project-rescan ((this project-am-texinfo))
+ "Rescan object THIS."
+ (oset this :include (makefile-macro-file-list (project-am-macro this))))
+
+(defmethod project-rescan ((this project-am-man))
+ "Rescan object THIS."
+ (oset this :source (makefile-macro-file-list (project-am-macro this))))
+
+(defmethod project-rescan ((this project-am-lisp))
+ "Rescan the lisp sources."
+ (oset this :source (makefile-macro-file-list (project-am-macro this))))
+
+(defmethod project-rescan ((this project-am-header))
+ "Rescan the Header sources for object THIS."
+ (oset this :source (makefile-macro-file-list (project-am-macro this))))
+
+(defmethod project-rescan ((this project-am-built-src))
+ "Rescan built sources for object THIS."
+ (oset this :source (makefile-macro-file-list "BUILT_SOURCES")))
+
+(defmethod project-rescan ((this project-am-extra-dist))
+ "Rescan object THIS."
+ (oset this :source (makefile-macro-file-list "EXTRA_DIST")))
+ ;; NOTE: The below calls 'file' then checks that it is some sort of
+ ;; text file. The file command may not be available on all platforms
+ ;; and some files may not exist yet. (ie - auto-generated)
+
+ ;;(mapc
+ ;; (lambda (f)
+ ;; ;; prevent garbage to be parsed, could we use :aux ?
+ ;; (if (and (not (member f (oref this :source)))
+ ;; (string-match-p "ASCII\\|text"
+ ;; (shell-command-to-string
+ ;; (concat "file " f))))
+ ;; (oset this :source (cons f (oref this :source)))))
+ ;; (makefile-macro-file-list "EXTRA_DIST")))
+
+(defmethod project-am-macro ((this project-am-objectcode))
+ "Return the default macro to 'edit' for this object type."
+ (concat (subst-char-in-string ?- ?_ (oref this :name)) "_SOURCES"))
+
+(defmethod project-am-macro ((this project-am-header-noinst))
+ "Return the default macro to 'edit' for this object."
+ "noinst_HEADERS")
+
+(defmethod project-am-macro ((this project-am-header-inst))
+ "Return the default macro to 'edit' for this object."
+ "include_HEADERS")
+
+(defmethod project-am-macro ((this project-am-header-pkg))
+ "Return the default macro to 'edit' for this object."
+ "pkginclude_HEADERS")
+
+(defmethod project-am-macro ((this project-am-header-chk))
+ "Return the default macro to 'edit' for this object."
+ "check_HEADERS")
+
+(defmethod project-am-macro ((this project-am-texinfo))
+ "Return the default macro to 'edit' for this object type."
+ (concat (file-name-sans-extension (oref this :name)) "_TEXINFOS"))
+
+(defmethod project-am-macro ((this project-am-man))
+ "Return the default macro to 'edit' for this object type."
+ (oref this :name))
+
+(defmethod project-am-macro ((this project-am-lisp))
+ "Return the default macro to 'edit' for this object."
+ "lisp_LISP")
+
+(defun project-am-buffer-object (amf buffer)
+ "Return an object starting with AMF associated with BUFFER.
+nil means that this buffer belongs to no-one."
+ (if (not amf)
+ nil
+ (if (ede-buffer-mine amf buffer)
+ amf
+ (let ((targ (oref amf targets))
+ (sobj (oref amf subproj))
+ (obj nil))
+ (while (and targ (not obj))
+ (if (ede-buffer-mine (car targ) buffer)
+ (setq obj (car targ)))
+ (setq targ (cdr targ)))
+ (while (and sobj (not obj))
+ (setq obj (project-am-buffer-object (car sobj) buffer)
+ sobj (cdr sobj)))
+ obj))))
+
+(defmethod ede-buffer-mine ((this project-am-makefile) buffer)
+ "Return t if object THIS lays claim to the file in BUFFER."
+ (let ((efn (expand-file-name (buffer-file-name buffer))))
+ (or (string= (oref this :file) efn)
+ (string-match "/configure\\.ac$" efn)
+ (string-match "/configure\\.in$" efn)
+ (string-match "/configure$" efn)
+ ;; Search output files.
+ (let ((ans nil))
+ (dolist (f (oref this configureoutputfiles))
+ (when (string-match (concat (regexp-quote f) "$") efn)
+ (setq ans t)))
+ ans)
+ )))
+
+(defmethod ede-buffer-mine ((this project-am-objectcode) buffer)
+ "Return t if object THIS lays claim to the file in BUFFER."
+ (member (file-name-nondirectory (buffer-file-name buffer))
+ (oref this :source)))
+
+(defmethod ede-buffer-mine ((this project-am-texinfo) buffer)
+ "Return t if object THIS lays claim to the file in BUFFER."
+ (let ((bfn (buffer-file-name buffer)))
+ (or (string= (oref this :name) (file-name-nondirectory bfn))
+ (member (file-name-nondirectory bfn) (oref this :include)))))
+
+(defmethod ede-buffer-mine ((this project-am-man) buffer)
+ "Return t if object THIS lays claim to the file in BUFFER."
+ (string= (oref this :name) (buffer-file-name buffer)))
+
+(defmethod ede-buffer-mine ((this project-am-lisp) buffer)
+ "Return t if object THIS lays claim to the file in BUFFER."
+ (member (file-name-nondirectory (buffer-file-name buffer))
+ (oref this :source)))
+
+(defmethod project-am-subtree ((ampf project-am-makefile) subdir)
+ "Return the sub project in AMPF specified by SUBDIR."
+ (object-assoc (expand-file-name subdir) 'file (oref ampf subproj)))
+
+(defmethod project-compile-target-command ((this project-am-target))
+ "Default target to use when compiling a given target."
+ ;; This is a pretty good default for most.
+ "")
+
+(defmethod project-compile-target-command ((this project-am-objectcode))
+ "Default target to use when compiling an object code target."
+ (oref this :name))
+
+(defmethod project-compile-target-command ((this project-am-texinfo))
+ "Default target t- use when compling a texinfo file."
+ (let ((n (oref this :name)))
+ (if (string-match "\\.texi?\\(nfo\\)?" n)
+ (setq n (replace-match ".info" t t n)))
+ n))
+
+
+;;; Generic useful functions
+
+(defun project-am-last-dir (file)
+ "Return the last part of a directory name.
+Argument FILE is the file to extract the end directory name from."
+ (let* ((s (file-name-directory file))
+ (d (directory-file-name s))
+ )
+ (file-name-nondirectory d))
+ )
+
+(defun project-am-preferred-target-type (file)
+ "For FILE, return the preferred type for that file."
+ (cond ((string-match "\\.texi?\\(nfo\\)$" file)
+ project-am-texinfo)
+ ((string-match "\\.[0-9]$" file)
+ project-am-man)
+ ((string-match "\\.el$" file)
+ project-am-lisp)
+ (t
+ project-am-program)))
+
+(defmethod ede-buffer-header-file((this project-am-objectcode) buffer)
+ "There are no default header files."
+ (or (call-next-method)
+ (let ((s (oref this source))
+ (found nil))
+ (while (and s (not found))
+ ;; Add more logic here if applicable.
+ (if (string-match "\\.\\(h\\|H\\|hh\\|hpp\\)" (car s))
+ (setq found (car s)))
+ (setq s (cdr s)))
+ found)))
+
+(defmethod ede-documentation ((this project-am-texinfo))
+ "Return a list of files that provides documentation.
+Documentation is not for object THIS, but is provided by THIS for other
+files in the project."
+ (let* ((src (append (oref this source)
+ (oref this include)))
+ (proj (ede-target-parent this))
+ (dir (oref proj directory))
+ (out nil))
+ ;; Loop over all entries and expand
+ (while src
+ (setq out (cons
+ (expand-file-name (car src) dir)
+ out))
+ (setq src (cdr src)))
+ ;; return it
+ out))
+
+
+;;; Configure.in queries.
+;;
+(defvar project-am-autoconf-file-options
+ '("configure.in" "configure.ac")
+ "List of possible configure files to look in for project info.")
+
+(defun project-am-autoconf-file (dir)
+ "Return the name of the autoconf file to use in DIR."
+ (let ((ans nil))
+ (dolist (L project-am-autoconf-file-options)
+ (when (file-exists-p (expand-file-name L dir))
+ (setq ans (expand-file-name L dir))))
+ ans))
+
+(defmacro project-am-with-config-current (file &rest forms)
+ "Set the Configure FILE in the top most directory above DIR as current.
+Run FORMS in the configure file.
+Kill the Configure buffer if it was not already in a buffer."
+ `(save-excursion
+ (let ((fb (generate-new-buffer ,file)))
+ (set-buffer fb)
+ (erase-buffer)
+ (insert-file-contents ,file)
+ (prog1 ,@forms
+ (kill-buffer fb)))))
+
+(put 'project-am-with-config-current 'lisp-indent-function 1)
+
+(add-hook 'edebug-setup-hook
+ (lambda ()
+ (def-edebug-spec project-am-with-config-current
+ (form def-body))))
+
+(defmacro project-am-extract-shell-variable (var)
+ "Extract the value of the shell variable VAR from a shell script."
+ (save-excursion
+ (goto-char (point-min))
+ (when (re-search-forward (concat "^" (regexp-quote var) "\\s-*=\\s-*")
+ nil t)
+ (buffer-substring-no-properties (point) (point-at-eol)))))
+
+(defun project-am-extract-package-info (dir)
+ "Extract the package information for directory DIR."
+ (let ((conf-in (project-am-autoconf-file dir))
+ (conf-sh (expand-file-name "configure" dir))
+ (name (file-name-nondirectory
+ (directory-file-name dir)))
+ (ver "1.0")
+ (bugrep nil)
+ (configfiles nil)
+ )
+ (cond
+ ;; Try configure.in or configure.ac
+ (conf-in
+ (require 'ede/autoconf-edit)
+ (project-am-with-config-current conf-in
+ (let ((aci (autoconf-parameters-for-macro "AC_INIT"))
+ (aia (autoconf-parameters-for-macro "AM_INIT_AUTOMAKE"))
+ (acf (autoconf-parameters-for-macro "AC_CONFIG_FILES"))
+ (aco (autoconf-parameters-for-macro "AC_OUTPUT"))
+ )
+ (cond
+ ;; AC init has more than 1 parameter
+ ((> (length aci) 1)
+ (setq name (nth 0 aci)
+ ver (nth 1 aci)
+ bugrep (nth 2 aci)))
+ ;; The init automake has more than 1 parameter
+ ((> (length aia) 1)
+ (setq name (nth 0 aia)
+ ver (nth 1 aia)
+ bugrep (nth 2 aia)))
+ )
+ ;; AC_CONFIG_FILES, or AC_OUTPUT lists everything that
+ ;; should be detected as part of this PROJECT, but not in a
+ ;; particular TARGET.
+ (let ((outfiles (cond (aco (list (car aco)))
+ (t acf))))
+ (if (> (length outfiles) 1)
+ (setq configfiles outfiles)
+ (setq configfiles (split-string (car outfiles) " " t)))
+ )
+ ))
+ )
+ ;; Else, try the script
+ ((file-exists-p conf-sh)
+ (project-am-with-config-current conf-sh
+ (setq name (project-am-extract-shell-variable "PACKAGE_NAME")
+ ver (project-am-extract-shell-variable "PACKAGE_VERSION")
+ )
+ ))
+ ;; Don't know what else....
+ (t
+ nil))
+ ;; Return stuff
+ (list name ver bugrep configfiles)
+ ))
+
+(defun project-am-package-info (dir)
+ "Get the package information for directory topmost project dir over DIR.
+Calcultes the info with `project-am-extract-package-info'."
+ (let ((top (ede-toplevel)))
+ (when top (setq dir (oref top :directory)))
+ (project-am-extract-package-info dir)))
+
+(provide 'ede/project-am)
+
+;;; ede/project-am.el ends here
Index: cedet/ede/simple.el
===================================================================
RCS file: cedet/ede/simple.el
diff -N cedet/ede/simple.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/simple.el 28 Sep 2009 15:15:07 -0000 1.2
@@ -0,0 +1,108 @@
+;;; ede/simple.el --- Overlay an EDE structure on an existing project
+
+;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; A vast majority of projects use non-EDE project techniques, such
+;; as hand written Makefiles, or other IDE's.
+;;
+;; The EDE-SIMPLE project type allows EDE to wrap an existing mechanism
+;; with minimal configuration, and then provides project-root
+;; information to Semantic or other tools, and also provides structure
+;; information for in-project include header discovery, or speedbar
+;; support.
+;;
+;; It will also support a the minimal EDE UI for compilation and
+;; configuration.
+
+;; @todo - Add support for cpp-root as an ede-simple project.
+;; @todo - Allow ede-simple to store locally.
+
+(require 'ede)
+(require 'cedet-files)
+
+;;; Code:
+
+(defcustom ede-simple-save-directory "~/.ede"
+ "*Directory where simple EDE project overlays are saved."
+ :group 'ede
+ :type 'directory)
+
+(defcustom ede-simple-save-file-name "ProjSimple.ede"
+ "*File name used for simple project wrappers."
+ :group 'ede
+ :type 'string)
+
+(defun ede-simple-projectfile-for-dir (&optional dir)
+ "Return a full file name to the project file stored in the current directory.
+The directory has three parts:
+ <STORAGE ROOT>/<PROJ DIR AS FILE>/ProjSimple.ede"
+ (let ((d (or dir default-directory)))
+ (concat
+ ;; Storage root
+ (file-name-as-directory (expand-file-name ede-simple-save-directory))
+ ;; Convert directory to filename
+ (cedet-directory-name-to-file-name d)
+ ;; Filename
+ ede-simple-save-file-name)
+ ))
+
+(defun ede-simple-load (dir &optional rootproj)
+ "Load a project of type `Simple' for the directory DIR.
+Return nil if there isn't one.
+ROOTPROJ is nil, since we will only create a single EDE project here."
+ (let ((pf (ede-simple-projectfile-for-dir dir))
+ (obj nil))
+ (when pf
+ (setq obj (eieio-persistent-read pf))
+ (oset obj :directory dir)
+ )
+ obj))
+
+(defclass ede-simple-target (ede-target)
+ ()
+ "EDE Simple project target.
+All directories need at least one target.")
+
+(defclass ede-simple-project (ede-project eieio-persistent)
+ ((extension :initform ".ede")
+ (file-header-line :initform ";; EDE Simple Project")
+ )
+ "EDE Simple project class.
+Each directory needs a a project file to control it.")
+
+(defmethod ede-commit-project ((proj ede-simple-project))
+ "Commit any change to PROJ to its file."
+ (when (not (file-exists-p ede-simple-save-directory))
+ (if (y-or-n-p (concat ede-simple-save-directory
+ " doesn't exist. Create? "))
+ (make-directory ede-simple-save-directory)
+ (error "No save directory for new project")))
+ (eieio-persistent-save proj))
+
+(defmethod ede-find-subproject-for-directory ((proj ede-simple-project)
+ dir)
+ "Return PROJ, for handling all subdirs below DIR."
+ proj)
+
+(provide 'ede/simple)
+
+;;; ede/simple.el ends here
Index: cedet/ede/source.el
===================================================================
RCS file: cedet/ede/source.el
diff -N cedet/ede/source.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/source.el 28 Sep 2009 15:15:07 -0000 1.2
@@ -0,0 +1,170 @@
+;; ede/source.el --- EDE source code object
+
+;;; Copyright (C) 2000, 2008 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: project, make
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Manage different types of source code. A master list of source code types
+;; will be maintained, and used to track target objects, what they accept,
+;; and what compilers can be used.
+
+(require 'eieio-base)
+
+;;; Code:
+(defclass ede-sourcecode (eieio-instance-inheritor)
+ ((name :initarg :name
+ :type string
+ :documentation
+ "The name of this type of source code.
+Such as \"C\" or \"Emacs Lisp\"")
+ (sourcepattern :initarg :sourcepattern
+ :initform ".*"
+ :type string
+ :documentation
+ "Emacs regexp matching sourcecode this target accepts.")
+ (auxsourcepattern :initarg :auxsourcepattern
+ :initform nil
+ :type (or null string)
+ :documentation
+ "Emacs regexp matching auxiliary source code this target
accepts.
+Aux source are source code files needed for compilation, which are not compiled
+themselves.")
+ (enable-subdirectories :initarg :enable-subdirectories
+ :initform nil
+ :type boolean
+ :documentation
+ "Non nil if this sourcecode type uses subdirectories.
+If sourcecode always lives near the target creating it, this should be nil.
+If sourcecode can, or typically lives in a subdirectory of the owning
+target, set this to t.")
+ (garbagepattern :initarg :garbagepattern
+ :initform nil
+ :type list
+ :documentation
+ "Shell file regexp matching files considered as garbage.
+This is a list of items added to an `rm' command when executing a `clean'
+type directive.")
+ )
+ "Description of some type of source code.
+Objects will use sourcecode objects to define the types of source
+that they are willing to use.")
+
+(defvar ede-sourcecode-list nil
+ "The master list of all EDE compilers.")
+
+;;; Methods
+;;
+(defmethod initialize-instance :AFTER ((this ede-sourcecode) &rest fields)
+ "Make sure that all ede compiler objects are cached in
+`ede-compiler-list'."
+ (let ((lst ede-sourcecode-list))
+ ;; Find an object of the same name.
+ (while (and lst (not (string= (oref this name) (oref (car lst) name))))
+ (setq lst (cdr lst)))
+ (if lst
+ ;; Replace old definition
+ (setcar lst this)
+ ;; Add to the beginning of the list.
+ (setq ede-sourcecode-list (cons this ede-sourcecode-list)))))
+
+(defmethod ede-want-file-p ((this ede-sourcecode) filename)
+ "Return non-nil if sourcecode definition THIS will take FILENAME."
+ (or (ede-want-file-source-p this filename)
+ (ede-want-file-auxiliary-p this filename)))
+
+(defmethod ede-want-file-source-p ((this ede-sourcecode) filename)
+ "Return non-nil if THIS will take FILENAME as an auxiliary ."
+ (let ((case-fold-search nil))
+ (string-match (oref this sourcepattern) filename)))
+
+(defmethod ede-want-file-auxiliary-p ((this ede-sourcecode) filename)
+ "Return non-nil if THIS will take FILENAME as an auxiliary ."
+ (let ((case-fold-search nil))
+ (and (slot-boundp this 'auxsourcepattern)
+ (oref this auxsourcepattern)
+ (string-match (oref this auxsourcepattern) filename))))
+
+(defmethod ede-want-any-source-files-p ((this ede-sourcecode) filenames)
+ "Return non-nil if THIS will accept any source files in FILENAMES."
+ (let (found)
+ (while (and (not found) filenames)
+ (setq found (ede-want-file-source-p this (pop filenames))))))
+
+(defmethod ede-want-any-auxiliary-files-p ((this ede-sourcecode) filenames)
+ "Return non-nil if THIS will accept any aux files in FILENAMES."
+ (let (found)
+ (while (and (not found) filenames)
+ (setq found (ede-want-file-auxiliary-p this (pop filenames))))))
+
+(defmethod ede-want-any-files-p ((this ede-sourcecode) filenames)
+ "Return non-nil if THIS will accept any files in FILENAMES."
+ (let (found)
+ (while (and (not found) filenames)
+ (setq found (ede-want-file-p this (pop filenames))))))
+
+(defmethod ede-buffer-header-file ((this ede-sourcecode) filename)
+ "Return a list of file names of header files for THIS with FILENAME.
+Used to guess header files, but uses the auxsource regular expression."
+ (let ((dn (file-name-directory filename))
+ (ts (file-name-sans-extension (file-name-nondirectory filename)))
+ (ae (oref this auxsourcepattern)))
+ (if (not ae)
+ nil
+ (directory-files dn t (concat (regexp-quote ts) ae)))))
+
+;;; Utility functions
+;;
+(when nil
+ ;; not used at the moment.
+(defun ede-source-find (name)
+ "Find the sourcecode object based on NAME."
+ (object-assoc name :name ede-sourcecode-list))
+
+(defun ede-source-match (file)
+ "Find the list of soucecode objects which matches FILE."
+ (let ((lst ede-sourcecode-list)
+ (match nil))
+ (while lst
+ ;; ede-file-mine doesn't exist yet
+ (if (ede-file-mine (car lst) file)
+ (setq match (cons (car lst) match)))
+ (setq lst (cdr lst)))
+ match))
+)
+;;; Master list of source code types
+;;
+;; This must appear at the end so that the init method will work.
+(defvar ede-source-scheme
+ (ede-sourcecode "ede-source-scheme"
+ :name "Scheme"
+ :sourcepattern "\\.scm$")
+ "Scheme source code definition.")
+
+;;(defvar ede-source-
+;; (ede-sourcecode "ede-source-"
+;; :name ""
+;; :sourcepattern "\\.$"
+;; :garbagepattern '("*."))
+;; " source code definition.")
+
+(provide 'ede/source)
+
+;;; ede/source.el ends here
Index: cedet/ede/speedbar.el
===================================================================
RCS file: cedet/ede/speedbar.el
diff -N cedet/ede/speedbar.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/speedbar.el 28 Sep 2009 15:15:07 -0000 1.2
@@ -0,0 +1,360 @@
+;;; ede/speedbar.el --- Speedbar viewing of EDE projects
+
+;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2005, 2007, 2008, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: project, make, tags
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Display a project's hierarchy in speedbar.
+;;
+
+;;; Code:
+(require 'speedbar)
+(require 'eieio-speedbar)
+(require 'ede)
+
+;;; Speedbar support mode
+;;
+(defvar ede-speedbar-key-map nil
+ "A Generic object based speedbar display keymap.")
+
+(defun ede-speedbar-make-map ()
+ "Make the generic object based speedbar keymap."
+ (setq ede-speedbar-key-map (speedbar-make-specialized-keymap))
+
+ ;; General viewing things
+ (define-key ede-speedbar-key-map "\C-m" 'speedbar-edit-line)
+ (define-key ede-speedbar-key-map "+" 'speedbar-expand-line)
+ (define-key ede-speedbar-key-map "=" 'speedbar-expand-line)
+ (define-key ede-speedbar-key-map "-" 'speedbar-contract-line)
+ (define-key ede-speedbar-key-map " " 'speedbar-toggle-line-expansion)
+
+ ;; Some object based things
+ (define-key ede-speedbar-key-map "C" 'eieio-speedbar-customize-line)
+
+ ;; Some project based things
+ (define-key ede-speedbar-key-map "R" 'ede-speedbar-remove-file-from-target)
+ (define-key ede-speedbar-key-map "b" 'ede-speedbar-compile-line)
+ (define-key ede-speedbar-key-map "B" 'ede-speedbar-compile-project)
+ (define-key ede-speedbar-key-map "D" 'ede-speedbar-make-distribution)
+ (define-key ede-speedbar-key-map "E" 'ede-speedbar-edit-projectfile)
+ )
+
+(defvar ede-speedbar-menu
+ '([ "Compile" ede-speedbar-compile-line t]
+ [ "Compile Project" ede-speedbar-compile-project
+ (ede-project-child-p (speedbar-line-token)) ]
+ "---"
+ [ "Edit File/Tag" speedbar-edit-line
+ (not (eieio-object-p (speedbar-line-token)))]
+ [ "Expand" speedbar-expand-line
+ (save-excursion (beginning-of-line)
+ (looking-at "[0-9]+: *.\\+. "))]
+ [ "Contract" speedbar-contract-line
+ (save-excursion (beginning-of-line)
+ (looking-at "[0-9]+: *.-. "))]
+ "---"
+ [ "Remove File from Target" ede-speedbar-remove-file-from-target
+ (stringp (speedbar-line-token)) ]
+ [ "Customize Project/Target" eieio-speedbar-customize-line
+ (eieio-object-p (speedbar-line-token)) ]
+ [ "Edit Project File" ede-speedbar-edit-projectfile t]
+ [ "Make Distribution" ede-speedbar-make-distribution
+ (ede-project-child-p (speedbar-line-token)) ]
+ )
+ "Menu part in easymenu format used in speedbar while browsing objects.")
+
+(eieio-speedbar-create 'ede-speedbar-make-map
+ 'ede-speedbar-key-map
+ 'ede-speedbar-menu
+ "Project"
+ 'ede-speedbar-toplevel-buttons)
+
+
+(defun ede-speedbar ()
+ "EDE development environment project browser for speedbar."
+ (interactive)
+ (speedbar-frame-mode 1)
+ (speedbar-change-initial-expansion-list "Project")
+ (speedbar-get-focus)
+ )
+
+(defun ede-speedbar-toplevel-buttons (dir)
+ "Return a list of objects to display in speedbar.
+Argument DIR is the directory from which to derive the list of objects."
+ ede-projects
+ )
+
+;;; Some special commands useful in EDE
+;;
+(defun ede-speedbar-remove-file-from-target ()
+ "Remove the file at point from it's target."
+ (interactive)
+ (if (stringp (speedbar-line-token))
+ (progn
+ (speedbar-edit-line)
+ (ede-remove-file))))
+
+(defun ede-speedbar-compile-line ()
+ "Compile/Build the project or target on this line."
+ (interactive)
+ (let ((obj (eieio-speedbar-find-nearest-object)))
+ (if (not (eieio-object-p obj))
+ nil
+ (cond ((obj-of-class-p obj ede-project)
+ (project-compile-project obj))
+ ((obj-of-class-p obj ede-target)
+ (project-compile-target obj))
+ (t (error "Error in speedbar structure"))))))
+
+(defun ede-speedbar-get-top-project-for-line ()
+ "Return a project object for this line."
+ (interactive)
+ (let ((obj (eieio-speedbar-find-nearest-object)))
+ (if (not (eieio-object-p obj))
+ (error "Error in speedbar or ede structure")
+ (if (obj-of-class-p obj ede-target)
+ (setq obj (ede-target-parent obj)))
+ (if (obj-of-class-p obj ede-project)
+ obj
+ (error "Error in speedbar or ede structure")))))
+
+(defun ede-speedbar-compile-project ()
+ "Compile/Build the project which owns this line."
+ (interactive)
+ (project-compile-project (ede-speedbar-get-top-project-for-line)))
+
+(defun ede-speedbar-compile-file-project ()
+ "Compile/Build the target which the current file belongs to."
+ (interactive)
+ (let* ((file (speedbar-line-file))
+ (buf (find-file-noselect file))
+ (bwin (get-buffer-window buf 0)))
+ (if bwin
+ (progn
+ (select-window bwin)
+ (raise-frame (window-frame bwin)))
+ (dframe-select-attached-frame speedbar-frame)
+ (set-buffer buf)
+ (ede-compile-target))))
+
+(defun ede-speedbar-make-distribution ()
+ "Edit the project file based on this line."
+ (interactive)
+ (project-make-dist (ede-speedbar-get-top-project-for-line)))
+
+(defun ede-speedbar-edit-projectfile ()
+ "Edit the project file based on this line."
+ (interactive)
+ (project-edit-file-target (ede-speedbar-get-top-project-for-line)))
+
+;;; Speedbar Project Methods
+;;
+(defun ede-find-nearest-file-line ()
+ "Go backwards until we find a file."
+ (save-excursion
+ (beginning-of-line)
+ (looking-at "^\\([0-9]+\\):")
+ (let ((depth (string-to-number (match-string 1))))
+ (while (not (re-search-forward "[]] [^ ]"
+ (save-excursion (end-of-line)
+ (point))
+ t))
+ (re-search-backward (format "^%d:" (1- depth)))
+ (setq depth (1- depth)))
+ (speedbar-line-token))))
+
+(defmethod eieio-speedbar-derive-line-path ((obj ede-project) &optional depth)
+ "Return the path to OBJ.
+Optional DEPTH is the depth we start at."
+ (file-name-directory (oref obj file))
+ )
+
+(defmethod eieio-speedbar-derive-line-path ((obj ede-target) &optional depth)
+ "Return the path to OBJ.
+Optional DEPTH is the depth we start at."
+ (let ((proj (ede-target-parent obj)))
+ ;; Check the type of line we are currently on.
+ ;; If we are on a child, we need a file name too.
+ (save-excursion
+ (let ((lt (speedbar-line-token)))
+ (if (or (eieio-object-p lt) (stringp lt))
+ (eieio-speedbar-derive-line-path proj)
+ ;; a child element is a token. Do some work to get a filename too.
+ (concat (eieio-speedbar-derive-line-path proj)
+ (ede-find-nearest-file-line)))))))
+
+(defmethod eieio-speedbar-description ((obj ede-project))
+ "Provide a speedbar description for OBJ."
+ (ede-description obj))
+
+(defmethod eieio-speedbar-description ((obj ede-target))
+ "Provide a speedbar description for OBJ."
+ (ede-description obj))
+
+(defmethod eieio-speedbar-child-description ((obj ede-target))
+ "Provide a speedbar description for a plain-child of OBJ.
+A plain child is a child element which is not an EIEIO object."
+ (or (speedbar-item-info-file-helper)
+ (speedbar-item-info-tag-helper)))
+
+(defmethod eieio-speedbar-object-buttonname ((object ede-project))
+ "Return a string to use as a speedbar button for OBJECT."
+ (if (ede-parent-project object)
+ (ede-name object)
+ (concat (ede-name object) " " (oref object version))))
+
+(defmethod eieio-speedbar-object-buttonname ((object ede-target))
+ "Return a string to use as a speedbar button for OBJECT."
+ (ede-name object))
+
+(defmethod eieio-speedbar-object-children ((this ede-project))
+ "Return the list of speedbar display children for THIS."
+ (condition-case nil
+ (with-slots (subproj targets) this
+ (append subproj targets))
+ (error nil)))
+
+(defmethod eieio-speedbar-object-children ((this ede-target))
+ "Return the list of speedbar display children for THIS."
+ (oref this source))
+
+(defmethod eieio-speedbar-child-make-tag-lines ((this ede-target) depth)
+ "Create a speedbar tag line for a child of THIS.
+It has depth DEPTH."
+ (with-slots (source) this
+ (mapcar (lambda (car)
+ (speedbar-make-tag-line 'bracket ?+
+ 'speedbar-tag-file
+ car
+ car
+ 'ede-file-find
+ car
+ 'speedbar-file-face depth))
+ source)))
+
+;;; Generic file management for TARGETS
+;;
+(defun ede-file-find (text token indent)
+ "Find the file TEXT at path TOKEN.
+INDENT is the current indentation level."
+ (speedbar-find-file-in-frame
+ (expand-file-name token (speedbar-line-directory indent)))
+ (speedbar-maybee-jump-to-attached-frame))
+
+(defun ede-create-tag-buttons (filename indent)
+ "Create the tag buttons associated with FILENAME at INDENT."
+ (let* ((lst (speedbar-fetch-dynamic-tags filename)))
+ ;; if no list, then remove expando button
+ (if (not lst)
+ (speedbar-change-expand-button-char ??)
+ (speedbar-with-writable
+ ;; We must do 1- because indent was already incremented.
+ (speedbar-insert-generic-list (1- indent)
+ lst
+ 'ede-tag-expand
+ 'ede-tag-find)))))
+
+(defun ede-tag-expand (text token indent)
+ "Expand a tag sublist. Imenu will return sub-lists of specialized tag types.
+Etags does not support this feature. TEXT will be the button
+string. TOKEN will be the list, and INDENT is the current indentation
+level."
+ (cond ((string-match "+" text) ;we have to expand this file
+ (speedbar-change-expand-button-char ?-)
+ (speedbar-with-writable
+ (save-excursion
+ (end-of-line) (forward-char 1)
+ (speedbar-insert-generic-list indent token
+ 'ede-tag-expand
+ 'ede-tag-find))))
+ ((string-match "-" text) ;we have to contract this node
+ (speedbar-change-expand-button-char ?+)
+ (speedbar-delete-subblock indent))
+ (t (error "Ooops... not sure what to do")))
+ (speedbar-center-buffer-smartly))
+
+(defun ede-tag-find (text token indent)
+ "For the tag TEXT in a file TOKEN, goto that position.
+INDENT is the current indentation level."
+ (let ((file (ede-find-nearest-file-line)))
+ (speedbar-find-file-in-frame file)
+ (save-excursion (speedbar-stealthy-updates))
+ ;; Reset the timer with a new timeout when cliking a file
+ ;; in case the user was navigating directories, we can cancel
+ ;; that other timer.
+; (speedbar-set-timer speedbar-update-speed)
+ (goto-char token)
+ (run-hooks 'speedbar-visiting-tag-hook)
+ ;;(recenter)
+ (speedbar-maybee-jump-to-attached-frame)
+ ))
+
+;;; EDE and the speedbar FILE display
+;;
+;; This will add a couple keybindings and menu items into the
+;; FILE display for speedbar.
+
+(defvar ede-speedbar-file-menu-additions
+ '("----"
+ ["Create EDE Target" ede-new-target (ede-current-project) ]
+ ["Add to project" ede-speedbar-file-add-to-project (ede-current-project) ]
+ ["Compile project" ede-speedbar-compile-project (ede-current-project) ]
+ ["Compile file target" ede-speedbar-compile-file-target
(ede-current-project) ]
+ ["Make distribution" ede-make-dist (ede-current-project) ]
+ )
+ "Set of menu items to splice into the speedbar menu.")
+
+(defvar ede-speedbar-file-keymap
+ (let ((km (make-sparse-keymap)))
+ (define-key km "a" 'ede-speedbar-file-add-to-project)
+ (define-key km "t" 'ede-new-target)
+ (define-key km "s" 'ede-speedbar)
+ (define-key km "C" 'ede-speedbar-compile-project)
+ (define-key km "c" 'ede-speedbar-compile-file-target)
+ (define-key km "d" 'ede-make-dist)
+ km)
+ "Keymap spliced into the speedbar keymap.")
+
+;;;###autoload
+(defun ede-speedbar-file-setup ()
+ "Setup some keybindings in the Speedbar File display."
+ (setq speedbar-easymenu-definition-special
+ (append speedbar-easymenu-definition-special
+ ede-speedbar-file-menu-additions
+ ))
+ (define-key speedbar-file-key-map "." ede-speedbar-file-keymap)
+ ;; Finally, if the FILES mode is loaded, force a refresh
+ ;; of the menus and such.
+ (when (and (string= speedbar-initial-expansion-list-name "files")
+ (buffer-live-p speedbar-buffer)
+ )
+ (speedbar-change-initial-expansion-list "files")))
+
+(provide 'ede/speedbar)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: ede/loaddefs
+;; generated-autoload-load-name: "ede/speedbar"
+;; End:
+
+;;; ede/speedbar.el ends here
Index: cedet/ede/srecode.el
===================================================================
RCS file: cedet/ede/srecode.el
diff -N cedet/ede/srecode.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/srecode.el 28 Sep 2009 15:15:07 -0000 1.2
@@ -0,0 +1,106 @@
+;;; ede-srecode.el --- EDE utilities on top of SRecoder
+
+;; Copyright (C) 2008 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; EDE utilities for using SRecode to generate project files, such as
+;; Makefiles.
+
+(require 'srecode)
+
+(declare-function srecode-create-dictionary "srecode/dictionary")
+(declare-function srecode-dictionary-set-value "srecode/dictionary")
+(declare-function srecode-load-tables-for-mode "srecode/find")
+(declare-function srecode-table "srecode/find")
+(declare-function srecode-template-get-table "srecode/find")
+(declare-function srecode-insert-fcn "srecode/insert")
+(declare-function srecode-resolve-arguments "srecode/map")
+(declare-function srecode-map-update-map "srecode/map")
+
+;;; Code:
+(defun ede-srecode-setup ()
+ "Update various paths to get SRecode to identify our macros."
+ (let* ((lib (locate-library "ede.el" t))
+ (ededir (file-name-directory lib))
+ (tmpdir (file-name-as-directory
+ (expand-file-name "templates" ededir))))
+ (when (not tmpdir)
+ (error "Unable to location EDE Templates directory"))
+
+ ;; Rig up the map.
+ (require 'srecode/map)
+ (require 'srecode/find)
+ (add-to-list 'srecode-map-load-path tmpdir)
+ (srecode-map-update-map t)
+
+ ;; We don't call this unless we need it. Load in the templates.
+ (srecode-load-tables-for-mode 'makefile-mode)
+ (srecode-load-tables-for-mode 'makefile-mode 'ede)
+
+ ;; @todo - autoconf files.
+
+ ))
+
+(defmacro ede-srecode-insert-with-dictionary (template &rest forms)
+ "Insert TEMPLATE after executing FORMS with a dictionary.
+TEMPLATE should specify a context by using a string format of:
+ context:templatename
+Locally binds the variable DICT to a dictionary which can be
+updated in FORMS."
+ `(let* ((dict (srecode-create-dictionary))
+ (temp (srecode-template-get-table (srecode-table)
+ ,template
+ nil
+ 'ede))
+ )
+ (when (not temp)
+ (error "EDE template %s for %s not found!"
+ ,template major-mode))
+ (srecode-resolve-arguments temp dict)
+
+ ;; Now execute forms for updating DICT.
+ (progn ,@forms)
+
+ (srecode-insert-fcn temp dict)
+ ))
+
+(defun ede-srecode-insert (template &rest dictionary-entries)
+ "Insert at the current point TEMPLATE.
+TEMPLATE should specify a context by using a string format of:
+ context:templatename
+Add DICTIONARY-ENTRIES into the dictionary before insertion.
+Note: Just like `srecode-insert', but templates found in 'ede app."
+ (require 'srecode/insert)
+ (ede-srecode-insert-with-dictionary template
+
+ ;; Add in optional dictionary entries.
+ (while dictionary-entries
+ (srecode-dictionary-set-value dict
+ (car dictionary-entries)
+ (car (cdr dictionary-entries)))
+ (setq dictionary-entries
+ (cdr (cdr dictionary-entries))))
+
+ ))
+
+(provide 'ede-srecode)
+
+;;; ede-srecode.el ends here
Index: cedet/ede/system.el
===================================================================
RCS file: cedet/ede/system.el
diff -N cedet/ede/system.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/system.el 28 Sep 2009 15:15:07 -0000 1.2
@@ -0,0 +1,147 @@
+;;; ede-system.el --- EDE working with the system (VC, FTP, ETC)
+
+;;; Copyright (C) 2001, 2002, 2003 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: project, make, vc
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; EDE system contains some routines to work with EDE projects saved in
+;; CVS repositories, and services such as sourceforge which lets you
+;; perform releases via FTP.
+
+(require 'ede)
+
+;;; Code:
+
+;;; Web/FTP site node.
+
+;;;###autoload
+(defun ede-web-browse-home ()
+ "Browse the home page of the current project."
+ (interactive)
+ (if (not (ede-toplevel))
+ (error "No project"))
+ (let ((home (oref (ede-toplevel) web-site-url)))
+ (if (string= "" home)
+ (error "Now URL is stored in this project"))
+ (require 'browse-url)
+ (browse-url home)
+ ))
+
+;;;###autoload
+(defun ede-edit-web-page ()
+ "Edit the web site for this project."
+ (interactive)
+ (let* ((toplevel (ede-toplevel))
+ (dir (oref toplevel web-site-directory))
+ (file (oref toplevel web-site-file))
+ (endfile (concat (file-name-as-directory dir) file)))
+ (if (string-match "^/r[:@]" endfile)
+ (require 'tramp))
+ (when (not (file-exists-p endfile))
+ (setq endfile file)
+ (if (string-match "^/r[:@]" endfile)
+ (require 'tramp))
+ (if (not (file-exists-p endfile))
+ (error "No project file found")))
+ (find-file endfile)))
+
+;;;###autoload
+(defun ede-upload-distribution ()
+ "Upload the current distribution to the correct location.
+Use /address@hidden: file names for FTP sites.
+Download tramp, and use /r:machine: for names on remote sites w/out FTP
access."
+ (interactive)
+ (let* ((files (project-dist-files (ede-toplevel)))
+ (upload (if (string= (oref (ede-toplevel) ftp-upload-site) "")
+ (oref (ede-toplevel) ftp-site)
+ (oref (ede-toplevel) ftp-upload-site))))
+ (when (or (string= upload "")
+ (not (file-exists-p upload)))
+ (error "Upload directory %S does not exist" upload))
+ (while files
+ (let ((localfile (concat (file-name-directory (oref (ede-toplevel) file))
+ (car files))))
+ (if (not (file-exists-p localfile))
+ (progn
+ (message "File %s does not exist yet. Building a distribution"
+ localfile)
+ (ede-make-dist)
+ (error "File %s does not exist yet. Building a distribution"
+ localfile)
+ ))
+ (setq upload
+ (concat (directory-file-name upload)
+ "/"
+ (file-name-nondirectory localfile)))
+ (copy-file localfile upload)
+ (setq files (cdr files)))))
+ (message "Done uploading files...")
+ )
+
+;;;###autoload
+(defun ede-upload-html-documentation ()
+ "Upload the current distributions documentation as HTML.
+Use /address@hidden: file names for FTP sites.
+Download tramp, and use /r:machine: for names on remote sites w/out FTP
access."
+ (interactive)
+ (let* ((files nil) ;(ede-html-doc-files (ede-toplevel)))
+ (upload (if (string= (oref (ede-toplevel) ftp-upload-site) "")
+ (oref (ede-toplevel) ftp-site)
+ (oref (ede-toplevel) ftp-upload-site))))
+ (when (or (string= upload "")
+ (not (file-exists-p upload)))
+ (error "Upload directory %S does not exist" upload))
+ (while files
+ (let ((localfile (concat (file-name-directory (oref (ede-toplevel) file))
+ (car files))))
+ (if (not (file-exists-p localfile))
+ (progn
+ (message "File %s does not exist yet. Building a distribution"
+ localfile)
+ ;;(project-compile-target ... )
+ (error "File %s does not exist yet. Building a distribution"
+ localfile)
+ ))
+ (copy-file localfile upload)
+ (setq files (cdr files)))))
+ (message "Done uploading files...")
+ )
+
+;;; Version Control
+;;
+;; Do a few nice things with Version control systems.
+
+;;;###autoload
+(defun ede-vc-project-directory ()
+ "Run `vc-dir' on the current project."
+ (interactive)
+ (let ((top (ede-toplevel-project-or-nil default-directory)))
+ (vc-dir top nil)))
+
+(provide 'ede/system)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: ede/loaddefs
+;; generated-autoload-load-name: "ede/system"
+;; End:
+
+;;; ede/system.el ends here
Index: cedet/ede/util.el
===================================================================
RCS file: cedet/ede/util.el
diff -N cedet/ede/util.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/ede/util.el 28 Sep 2009 15:15:07 -0000 1.2
@@ -0,0 +1,106 @@
+;;; ede/util.el --- EDE utilities
+
+;;; Copyright (C) 2000, 2005 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: project, make
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Utilities that may not require project specific help, and oporate
+;; on generic EDE structures. Provide user level commands for activities
+;; not directly related to source code organization or makefile generation.
+
+(require 'ede)
+
+;;; Code:
+
+;;; Updating the version of a project.
+;;;###autoload
+(defun ede-update-version (newversion)
+ "Update the current projects main version number.
+Argument NEWVERSION is the version number to use in the current project."
+ (interactive (list (let* ((o (ede-toplevel))
+ (v (oref o version)))
+ (read-string (format "Update Version (was %s): " v)
+ v nil v))))
+ (let ((ede-object (ede-toplevel)))
+ ;; Don't update anything if there was no change.
+ (unless (string= (oref ede-object :version) newversion)
+ (oset ede-object :version newversion)
+ (project-update-version ede-object)
+ (ede-update-version-in-source ede-object newversion))))
+
+(defmethod project-update-version ((ot ede-project))
+ "The :version of the project OT has been updated.
+Handle saving, or other detail."
+ (error "project-update-version not supported by %s" (object-name ot)))
+
+(defmethod ede-update-version-in-source ((this ede-project) version)
+ "Change occurrences of a version string in sources.
+In project THIS, cycle over all targets to give them a chance to set
+their sources to VERSION."
+ (ede-map-targets this (lambda (targ)
+ (ede-update-version-in-source targ version))))
+
+(defmethod ede-update-version-in-source ((this ede-target) version)
+ "In sources for THIS, change version numbers to VERSION."
+ (if (and (slot-boundp this 'versionsource)
+ (oref this versionsource))
+ (let ((vs (oref this versionsource)))
+ (while vs
+ (save-excursion
+ (set-buffer (find-file-noselect
+ (ede-expand-filename this (car vs))))
+ (goto-char (point-min))
+ (let ((case-fold-search t))
+ (if (re-search-forward "version:\\s-*\\([^ \t\n]+\\)" nil t)
+ (progn
+ (save-match-data
+ (ede-make-buffer-writable))
+ (delete-region (match-beginning 1)
+ (match-end 1))
+ (goto-char (match-beginning 1))
+ (insert version)))))
+ (setq vs (cdr vs))))))
+
+;;; Writable files
+;;
+;; Utils for EDE when it needs to write a file that could be covered by a
+;; version control system.
+(defun ede-make-buffer-writable (&optional buffer)
+ "Make sure that BUFFER is writable.
+If BUFFER isn't specified, use the current buffer."
+ (save-excursion
+ (if buffer (set-buffer buffer))
+ (if buffer-read-only
+ (if (and vc-mode
+ (y-or-n-p (format "Check out %s? " (buffer-file-name))))
+ (vc-toggle-read-only)
+ (if (not vc-mode)
+ (toggle-read-only -1))))))
+
+(provide 'ede/util)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: ede/loaddefs
+;; generated-autoload-load-name: "ede/util"
+;; End:
+
+;;; ede/util.el ends here
Index: cedet/semantic/.cvsignore
===================================================================
RCS file: cedet/semantic/.cvsignore
diff -N cedet/semantic/.cvsignore
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/.cvsignore 28 Sep 2009 15:15:07 -0000 1.2
@@ -0,0 +1 @@
+loaddefs.el
Index: cedet/semantic/analyze.el
===================================================================
RCS file: cedet/semantic/analyze.el
diff -N cedet/semantic/analyze.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/analyze.el 28 Sep 2009 15:15:07 -0000 1.2
@@ -0,0 +1,798 @@
+;;; semantic/analyze.el --- Analyze semantic tags against local context
+
+;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Semantic, as a tool, provides a nice list of searchable tags.
+;; That information can provide some very accurate answers if the current
+;; context of a position is known.
+;;
+;; Semantic-ctxt provides ways of analyzing, and manipulating the
+;; semantic context of a language in code.
+;;
+;; This library provides routines for finding intelligent answers to
+;; tough problems, such as if an argument to a function has the correct
+;; return type, or all possible tags that fit in a given local context.
+;;
+
+;;; Vocabulary:
+;;
+;; Here are some words used to describe different things in the analyzer:
+;;
+;; tag - A single entity
+;; prefix - The beginning of a symbol, usually used to look up something
+;; incomplete.
+;; type - The name of a datatype in the langauge.
+;; metatype - If a type is named in a declaration like:
+;; struct moose somevariable;
+;; that name "moose" can be turned into a concrete type.
+;; tag sequence - In C code, a list of dereferences, such as:
+;; this.that.theother();
+;; parent - For a datatype in an OO language, another datatype
+;; inherited from. This excludes interfaces.
+;; scope - A list of tags that can be dereferenced that cannot
+;; be found from the global namespace.
+;; scopetypes - A list of tags which are datatype that contain
+;; the scope. The scopetypes need to have the scope extracted
+;; in a way that honors the type of inheritance.
+;; nest/nested - When one tag is contained entirely in another.
+;;
+;; context - A semantic datatype representing a point in a buffer.
+;;
+;; constriant - If a context specifies a specific datatype is needed,
+;; that is a constraint.
+;; constants - Some datatypes define elements of themselves as a
+;; constant. These need to be returned as there would be no
+;; other possible completions.
+
+(require 'semantic)
+(require 'semantic/format)
+(require 'semantic/ctxt)
+(require 'semantic/scope)
+(require 'semantic/sort)
+(require 'semantic/analyze/fcn)
+
+(eval-when-compile (require 'semantic/find))
+
+(declare-function data-debug-new-buffer "data-debug")
+(declare-function data-debug-insert-object-slots "eieio-datadebug")
+
+;;; Code:
+(defvar semantic-analyze-error-stack nil
+ "Collection of any errors thrown during analysis.")
+
+(defun semantic-analyze-push-error (err)
+ "Push the error in ERR-DATA onto the error stack.
+Argument ERR"
+ (push err semantic-analyze-error-stack))
+
+;;; Analysis Classes
+;;
+;; These classes represent what a context is. Different types
+;; of contexts provide differing amounts of information to help
+;; provide completions.
+;;
+(defclass semantic-analyze-context ()
+ ((bounds :initarg :bounds
+ :type list
+ :documentation "The bounds of this context.
+Usually bound to the dimension of a single symbol or command.")
+ (prefix :initarg :prefix
+ :type list
+ :documentation "List of tags defining local text.
+This can be nil, or a list where the last element can be a string
+representing text that may be incomplete. Preceeding elements
+must be semantic tags representing variables or functions
+called in a dereference sequence.")
+ (prefixclass :initarg :prefixclass
+ :type list
+ :documentation "Tag classes expected at this context.
+These are clases for tags, such as 'function, or 'variable.")
+ (prefixtypes :initarg :prefixtypes
+ :type list
+ :documentation "List of tags defining types for :prefix.
+This list is one shorter than :prefix. Each element is a semantic
+tag representing a type matching the semantic tag in the same
+position in PREFIX.")
+ (scope :initarg :scope
+ :type (or null semantic-scope-cache)
+ :documentation "List of tags available in scopetype.
+See `semantic-analyze-scoped-tags' for details.")
+ (buffer :initarg :buffer
+ :type buffer
+ :documentation "The buffer this context is derived from.")
+ (errors :initarg :errors
+ :documentation "Any errors thrown an caught during analysis.")
+ )
+ "Base analysis data for a any context.")
+
+(defclass semantic-analyze-context-assignment (semantic-analyze-context)
+ ((assignee :initarg :assignee
+ :type list
+ :documentation "A sequence of tags for an assignee.
+This is a variable into which some value is being placed. The last
+item in the list is the variable accepting the value. Earlier
+tags represent the variables being derefernece to get to the
+assignee."))
+ "Analysis class for a value in an assignment.")
+
+(defclass semantic-analyze-context-functionarg (semantic-analyze-context)
+ ((function :initarg :function
+ :type list
+ :documentation "A sequence of tags for a function.
+This is a function being called. The cursor will be in the position
+of an argument.
+The last tag in :function is the function being called. Earlier
+tags represent the variables being dereferenced to get to the
+function.")
+ (index :initarg :index
+ :type integer
+ :documentation "The index of the argument for this context.
+If a function takes 4 arguments, this value should be bound to
+the values 1 through 4.")
+ (argument :initarg :argument
+ :type list
+ :documentation "A sequence of tags for the :index argument.
+The argument can accept a value of some type, and this contains the
+tag for that definition. It should be a tag, but might
+be just a string in some circumstances.")
+ )
+ "Analysis class for a value as a function argument.")
+
+(defclass semantic-analyze-context-return (semantic-analyze-context)
+ () ; No extra data.
+ "Analysis class for return data.
+Return data methods identify the requred type by the return value
+of the parent function.")
+
+;;; METHODS
+;;
+;; Simple methods against the context classes.
+;;
+(defmethod semantic-analyze-type-constraint
+ ((context semantic-analyze-context) &optional desired-type)
+ "Return a type constraint for completing :prefix in CONTEXT.
+Optional argument DESIRED-TYPE may be a non-type tag to analyze."
+ (when (semantic-tag-p desired-type)
+ ;; Convert the desired type if needed.
+ (if (not (eq (semantic-tag-class desired-type) 'type))
+ (setq desired-type (semantic-tag-type desired-type)))
+ ;; Protect against plain strings
+ (cond ((stringp desired-type)
+ (setq desired-type (list desired-type 'type)))
+ ((and (stringp (car desired-type))
+ (not (semantic-tag-p desired-type)))
+ (setq desired-type (list (car desired-type) 'type)))
+ ((semantic-tag-p desired-type)
+ ;; We have a tag of some sort. Yay!
+ nil)
+ (t (setq desired-type nil))
+ )
+ desired-type))
+
+(defmethod semantic-analyze-type-constraint
+ ((context semantic-analyze-context-functionarg))
+ "Return a type constraint for completing :prefix in CONTEXT."
+ (call-next-method context (car (oref context argument))))
+
+(defmethod semantic-analyze-type-constraint
+ ((context semantic-analyze-context-assignment))
+ "Return a type constraint for completing :prefix in CONTEXT."
+ (call-next-method context (car (reverse (oref context assignee)))))
+
+(defmethod semantic-analyze-interesting-tag
+ ((context semantic-analyze-context))
+ "Return a tag from CONTEXT that would be most interesting to a user."
+ (let ((prefix (reverse (oref context :prefix))))
+ ;; Go back through the prefix until we find a tag we can return.
+ (while (and prefix (not (semantic-tag-p (car prefix))))
+ (setq prefix (cdr prefix)))
+ ;; Return the found tag, or nil.
+ (car prefix)))
+
+(defmethod semantic-analyze-interesting-tag
+ ((context semantic-analyze-context-functionarg))
+ "Try the base, and if that fails, return what we are assigning into."
+ (or (call-next-method) (car-safe (oref context :function))))
+
+(defmethod semantic-analyze-interesting-tag
+ ((context semantic-analyze-context-assignment))
+ "Try the base, and if that fails, return what we are assigning into."
+ (or (call-next-method) (car-safe (oref context :assignee))))
+
+;;; ANALYSIS
+;;
+;; Start out with routines that will calculate useful parts of
+;; the general analyzer function. These could be used directly
+;; by an application that doesn't need to calculate the full
+;; context.
+
+(define-overloadable-function semantic-analyze-find-tag-sequence (sequence
&optional
+ scope typereturn
throwsym)
+ "Attempt to find all tags in SEQUENCE.
+Optional argument LOCALVAR is the list of local variables to use when
+finding the details on the first element of SEQUENCE in case
+it is not found in the global set of tables.
+Optional argument SCOPE are additional terminals to search which are currently
+scoped. These are not local variables, but symbols available in a structure
+which doesn't need to be dereferneced.
+Optional argument TYPERETURN is a symbol in which the types of all found
+will be stored. If nil, that data is thrown away.
+Optional argument THROWSYM specifies a symbol the throw on non-recoverable
error.")
+
+(defun semantic-analyze-find-tag-sequence-default (sequence &optional
+ scope typereturn
+ throwsym)
+ "Attempt to find all tags in SEQUENCE.
+SCOPE are extra tags which are in scope.
+TYPERETURN is a symbol in which to place a list of tag classes that
+are found in SEQUENCE.
+Optional argument THROWSYM specifies a symbol the throw on non-recoverable
error."
+ (let ((s sequence) ; copy of the sequence
+ (tmp nil) ; tmp find variable
+ (tag nil) ; tag return list
+ (tagtype nil) ; tag types return list
+ (fname nil)
+ (miniscope (clone scope))
+ )
+ ;; First order check. Is this wholely contained in the typecache?
+ (setq tmp (semanticdb-typecache-find sequence))
+
+ (if tmp
+ (progn
+ ;; We are effectively done...
+ (setq s nil)
+ (setq tag (list tmp)))
+
+ ;; For the first entry, it better be a variable, but it might
+ ;; be in the local context too.
+ ;; NOTE: Don't forget c++ namespace foo::bar.
+ (setq tmp (or
+ ;; Is this tag within our scope. Scopes can sometimes
+ ;; shadow other things, so it goes first.
+ (and scope (semantic-scope-find (car s) nil scope))
+ ;; Find the tag out there... somewhere, but not in scope
+ (semantic-analyze-find-tag (car s))
+ ))
+
+ (if (and (listp tmp) (semantic-tag-p (car tmp)))
+ (setq tmp (semantic-analyze-select-best-tag tmp)))
+ (if (not (semantic-tag-p tmp))
+ (if throwsym
+ (throw throwsym "Cannot find definition")
+ (error "Cannot find definition for \"%s\"" (car s))))
+ (setq s (cdr s))
+ (setq tag (cons tmp tag)) ; tag is nil here...
+ (setq fname (semantic-tag-file-name tmp))
+ )
+
+ ;; For the middle entries
+ (while s
+ ;; Using the tag found in TMP, lets find the tag
+ ;; representing the full typeographic information of its
+ ;; type, and use that to determine the search context for
+ ;; (car s)
+ (let* ((tmptype
+ ;; In some cases the found TMP is a type,
+ ;; and we can use it directly.
+ (cond ((semantic-tag-of-class-p tmp 'type)
+ ;; update the miniscope when we need to analyze types
directly.
+ (let ((rawscope
+ (apply 'append
+ (mapcar 'semantic-tag-type-members
+ tagtype))))
+ (oset miniscope fullscope rawscope))
+ ;; Now analayze the type to remove metatypes.
+ (or (semantic-analyze-type tmp miniscope)
+ tmp))
+ (t
+ (semantic-analyze-tag-type tmp scope))))
+ (typefile
+ (when tmptype
+ (semantic-tag-file-name tmptype)))
+ (slots nil))
+
+ ;; Get the children
+ (setq slots (semantic-analyze-scoped-type-parts tmptype scope))
+
+ ;; find (car s) in the list o slots
+ (setq tmp (semantic-find-tags-by-name (car s) slots))
+
+ ;; If we have lots
+ (if (and (listp tmp) (semantic-tag-p (car tmp)))
+ (setq tmp (semantic-analyze-select-best-tag tmp)))
+
+ ;; Make sure we have a tag.
+ (if (not (semantic-tag-p tmp))
+ (if (cdr s)
+ ;; In the middle, we need to keep seeking our types out.
+ (error "Cannot find definition for \"%s\"" (car s))
+ ;; Else, it's ok to end with a non-tag
+ (setq tmp (car s))))
+
+ (setq fname (or typefile fname))
+ (when (and fname (semantic-tag-p tmp)
+ (not (semantic-tag-in-buffer-p tmp)))
+ (semantic--tag-put-property tmp :filename fname))
+ (setq tag (cons tmp tag))
+ (setq tagtype (cons tmptype tagtype))
+ )
+ (setq s (cdr s)))
+
+ (if typereturn (set typereturn (nreverse tagtype)))
+ ;; Return the mess
+ (nreverse tag)))
+
+(defun semantic-analyze-find-tag (name &optional tagclass scope)
+ "Return the first tag found with NAME or nil if not found.
+Optional argument TAGCLASS specifies the class of tag to return, such
+as 'function or 'variable.
+Optional argument SCOPE specifies a scope object which has
+additional tags which are in SCOPE and do not need prefixing to
+find.
+
+This is a wrapper on top of semanticdb, semanticdb-typecache,
+semantic-scope, and semantic search functions. Almost all
+searches use the same arguments."
+ (let ((namelst (if (consp name) name ;; test if pre-split.
+ (semantic-analyze-split-name name))))
+ (cond
+ ;; If the splitter gives us a list, use the sequence finder
+ ;; to get the list. Since this routine is expected to return
+ ;; only one tag, return the LAST tag found from the sequence
+ ;; which is supposedly the nested reference.
+ ;;
+ ;; Of note, the SEQUENCE function below calls this function
+ ;; (recursively now) so the names that we get from the above
+ ;; fcn better not, in turn, be splittable.
+ ((listp namelst)
+ ;; If we had a split, then this is likely a c++ style namespace::name
sequence,
+ ;; so take a short-cut through the typecache.
+ (or (semanticdb-typecache-find namelst)
+ ;; Ok, not there, try the usual...
+ (let ((seq (semantic-analyze-find-tag-sequence
+ namelst scope nil)))
+ (semantic-analyze-select-best-tag seq tagclass)
+ )))
+ ;; If NAME is solo, then do our searches for it here.
+ ((stringp namelst)
+ (let ((retlist (and scope (semantic-scope-find name tagclass scope))))
+ (if retlist
+ (semantic-analyze-select-best-tag
+ retlist tagclass)
+ (if (eq tagclass 'type)
+ (semanticdb-typecache-find name)
+ ;; Search in the typecache. First entries in a sequence are
+ ;; often there.
+ (setq retlist (semanticdb-typecache-find name))
+ (if retlist
+ retlist
+ (semantic-analyze-select-best-tag
+ (semanticdb-strip-find-results
+ (semanticdb-find-tags-by-name name)
+ 'name)
+ tagclass)
+ )))))
+ )))
+
+;;; SHORT ANALYSIS
+;;
+;; Create a mini-analysis of just the symbol under point.
+;;
+(define-overloadable-function semantic-analyze-current-symbol
+ (analyzehookfcn &optional position)
+ "Call ANALYZEHOOKFCN after analyzing the symbol under POSITION.
+The ANALYZEHOOKFCN is called with the current symbol bounds, and the
+analyzed prefix. It should take the arguments (START END PREFIX).
+The ANALYZEHOOKFCN is only called if some sort of prefix with bounds was
+found under POSITION.
+
+The results of ANALYZEHOOKFCN is returned, or nil if there was nothing to
+call it with.
+
+For regular analysis, you should call `semantic-analyze-current-context'
+to calculate the context information. The purpose for this function is
+to provide a large number of non-cached analysis for filtering symbols."
+ ;; Only do this in a Semantic enabled buffer.
+ (when (not (semantic-active-p))
+ (error "Cannot analyze buffers not supported by Semantic."))
+ ;; Always refresh out tags in a safe way before doing the
+ ;; context.
+ (semantic-refresh-tags-safe)
+ ;; Do the rest of the analysis.
+ (save-match-data
+ (save-excursion
+ (:override)))
+ )
+
+(defun semantic-analyze-current-symbol-default (analyzehookfcn position)
+ "Call ANALYZEHOOKFCN on the analyzed symbol at POSITION."
+ (let* ((semantic-analyze-error-stack nil)
+ (LLstart (current-time))
+ (prefixandbounds (semantic-ctxt-current-symbol-and-bounds (or position
(point))))
+ (prefix (car prefixandbounds))
+ (bounds (nth 2 prefixandbounds))
+ (scope (semantic-calculate-scope position))
+ (end nil)
+ )
+ ;; Only do work if we have bounds (meaning a prefix to complete)
+ (when bounds
+
+ (if debug-on-error
+ (catch 'unfindable
+ ;; If debug on error is on, allow debugging in this fcn.
+ (setq prefix (semantic-analyze-find-tag-sequence
+ prefix scope 'prefixtypes 'unfindable)))
+ ;; Debug on error is off. Capture errors and move on
+ (condition-case err
+ ;; NOTE: This line is duplicated in
+ ;; semantic-analyzer-debug-global-symbol
+ ;; You will need to update both places.
+ (setq prefix (semantic-analyze-find-tag-sequence
+ prefix scope 'prefixtypes))
+ (error (semantic-analyze-push-error err))))
+
+ (setq end (current-time))
+ ;;(message "Analysis took %.2f sec" (semantic-elapsed-time LLstart end))
+
+ )
+ (when prefix
+ (prog1
+ (funcall analyzehookfcn (car bounds) (cdr bounds) prefix)
+ ;;(setq end (current-time))
+ ;;(message "hookfcn took %.5f sec" (semantic-elapsed-time LLstart end))
+ )
+
+ )))
+
+;;; MAIN ANALYSIS
+;;
+;; Create a full-up context analysis.
+;;
+;;;###autoload
+(define-overloadable-function semantic-analyze-current-context (&optional
position)
+ "Analyze the current context at optional POSITION.
+If called interactively, display interesting information about POSITION
+in a separate buffer.
+Returns an object based on symbol `semantic-analyze-context'.
+
+This function can be overriden with the symbol `analyze-context'.
+When overriding this function, your override will be called while
+cursor is at POSITION. In addition, your function will not be called
+if a cached copy of the return object is found."
+ (interactive "d")
+ ;; Only do this in a Semantic enabled buffer.
+ (when (not (semantic-active-p))
+ (error "Cannot analyze buffers not supported by Semantic."))
+ ;; Always refresh out tags in a safe way before doing the
+ ;; context.
+ (semantic-refresh-tags-safe)
+ ;; Do the rest of the analysis.
+ (if (not position) (setq position (point)))
+ (save-excursion
+ (goto-char position)
+ (let* ((answer (semantic-get-cache-data 'current-context)))
+ (with-syntax-table semantic-lex-syntax-table
+ (when (not answer)
+ (setq answer (:override))
+ (when (and answer (oref answer bounds))
+ (with-slots (bounds) answer
+ (semantic-cache-data-to-buffer (current-buffer)
+ (car bounds)
+ (cdr bounds)
+ answer
+ 'current-context
+ 'exit-cache-zone)))
+ ;; Check for interactivity
+ (when (interactive-p)
+ (if answer
+ (semantic-analyze-pop-to-context answer)
+ (message "No Context."))
+ ))
+
+ answer))))
+
+(defun semantic-analyze-current-context-default (position)
+ "Analyze the current context at POSITION.
+Returns an object based on symbol `semantic-analyze-context'."
+ (let* ((semantic-analyze-error-stack nil)
+ (context-return nil)
+ (prefixandbounds (semantic-ctxt-current-symbol-and-bounds (or position
(point))))
+ (prefix (car prefixandbounds))
+ (bounds (nth 2 prefixandbounds))
+ ;; @todo - vv too early to really know this answer! vv
+ (prefixclass (semantic-ctxt-current-class-list))
+ (prefixtypes nil)
+ (scope (semantic-calculate-scope position))
+ (function nil)
+ (fntag nil)
+ arg fntagend argtag
+ assign asstag
+ )
+
+ ;; Pattern for Analysis:
+ ;;
+ ;; Step 1: Calculate DataTypes in Scope:
+ ;;
+ ;; a) Calculate the scope (above)
+ ;;
+ ;; Step 2: Parse context
+ ;;
+ ;; a) Identify function being called, or variable assignment,
+ ;; and find source tags for those references
+ ;; b) Identify the prefix (text cursor is on) and find the source
+ ;; tags for those references.
+ ;;
+ ;; Step 3: Assemble an object
+ ;;
+
+ ;; Step 2 a:
+
+ (setq function (semantic-ctxt-current-function))
+
+ (when function
+ ;; Calculate the argument for the function if there is one.
+ (setq arg (semantic-ctxt-current-argument))
+
+ ;; Find a tag related to the function name.
+ (condition-case err
+ (setq fntag
+ (semantic-analyze-find-tag-sequence function scope))
+ (error (semantic-analyze-push-error err)))
+
+ ;; fntag can have the last entry as just a string, meaning we
+ ;; could not find the core datatype. In this case, the searches
+ ;; below will not work.
+ (when (stringp (car (last fntag)))
+ ;; Take a wild guess!
+ (setcar (last fntag) (semantic-tag (car (last fntag)) 'function))
+ )
+
+ (when fntag
+ (let ((fcn (semantic-find-tags-by-class 'function fntag)))
+ (when (not fcn)
+ (let ((ty (semantic-find-tags-by-class 'type fntag)))
+ (when ty
+ ;; We might have a constructor with the same name as
+ ;; the found datatype.
+ (setq fcn (semantic-find-tags-by-name
+ (semantic-tag-name (car ty))
+ (semantic-tag-type-members (car ty))))
+ (if fcn
+ (let ((lp fcn))
+ (while lp
+ (when (semantic-tag-get-attribute (car lp)
+ :constructor)
+ (setq fcn (cons (car lp) fcn)))
+ (setq lp (cdr lp))))
+ ;; Give up, go old school
+ (setq fcn fntag))
+ )))
+ (setq fntagend (car (reverse fcn))
+ argtag
+ (when (semantic-tag-p fntagend)
+ (nth (1- arg) (semantic-tag-function-arguments fntagend)))
+ fntag fcn))))
+
+ ;; Step 2 b:
+
+ ;; Only do work if we have bounds (meaning a prefix to complete)
+ (when bounds
+
+ (if debug-on-error
+ (catch 'unfindable
+ ;; If debug on error is on, allow debugging in this fcn.
+ (setq prefix (semantic-analyze-find-tag-sequence
+ prefix scope 'prefixtypes 'unfindable)))
+ ;; Debug on error is off. Capture errors and move on
+ (condition-case err
+ ;; NOTE: This line is duplicated in
+ ;; semantic-analyzer-debug-global-symbol
+ ;; You will need to update both places.
+ (setq prefix (semantic-analyze-find-tag-sequence
+ prefix scope 'prefixtypes))
+ (error (semantic-analyze-push-error err))))
+ )
+
+ ;; Step 3:
+
+ (cond
+ (fntag
+ ;; If we found a tag for our function, we can go into
+ ;; functional context analysis mode, meaning we have a type
+ ;; for the argument.
+ (setq context-return
+ (semantic-analyze-context-functionarg
+ "functionargument"
+ :buffer (current-buffer)
+ :function fntag
+ :index arg
+ :argument (list argtag)
+ :scope scope
+ :prefix prefix
+ :prefixclass prefixclass
+ :bounds bounds
+ :prefixtypes prefixtypes
+ :errors semantic-analyze-error-stack)))
+
+ ;; No function, try assignment
+ ((and (setq assign (semantic-ctxt-current-assignment))
+ ;; We have some sort of an assignment
+ (condition-case err
+ (setq asstag (semantic-analyze-find-tag-sequence
+ assign scope))
+ (error (semantic-analyze-push-error err)
+ nil)))
+
+ (setq context-return
+ (semantic-analyze-context-assignment
+ "assignment"
+ :buffer (current-buffer)
+ :assignee asstag
+ :scope scope
+ :bounds bounds
+ :prefix prefix
+ :prefixclass prefixclass
+ :prefixtypes prefixtypes
+ :errors semantic-analyze-error-stack)))
+
+ ;; TODO: Identify return value condition.
+ ;;((setq return .... what to do?)
+ ;; ...)
+
+ (bounds
+ ;; Nothing in particular
+ (setq context-return
+ (semantic-analyze-context
+ "context"
+ :buffer (current-buffer)
+ :scope scope
+ :bounds bounds
+ :prefix prefix
+ :prefixclass prefixclass
+ :prefixtypes prefixtypes
+ :errors semantic-analyze-error-stack)))
+
+ (t (setq context-return nil))
+ )
+
+ ;; Return our context.
+ context-return))
+
+
+(defun semantic-adebug-analyze (&optional ctxt)
+ "Perform `semantic-analyze-current-context'.
+Display the results as a debug list.
+Optional argument CTXT is the context to show."
+ (interactive)
+ (require 'data-debug)
+ (let ((start (current-time))
+ (ctxt (or ctxt (semantic-analyze-current-context)))
+ (end (current-time)))
+ (if (not ctxt)
+ (message "No Analyzer Results")
+ (message "Analysis took %.2f seconds."
+ (semantic-elapsed-time start end))
+ (semantic-analyze-pulse ctxt)
+ (if ctxt
+ (progn
+ (data-debug-new-buffer "*Analyzer ADEBUG*")
+ (data-debug-insert-object-slots ctxt "]"))
+ (message "No Context to analyze here.")))))
+
+
+;;; DEBUG OUTPUT
+;;
+;; Friendly output of a context analysis.
+;;
+(declare-function pulse-momentary-highlight-region "pulse")
+
+(defmethod semantic-analyze-pulse ((context semantic-analyze-context))
+ "Pulse the region that CONTEXT affects."
+ (require 'pulse)
+ (save-excursion
+ (set-buffer (oref context :buffer))
+ (let ((bounds (oref context :bounds)))
+ (when bounds
+ (pulse-momentary-highlight-region (car bounds) (cdr bounds))))))
+
+(defcustom semantic-analyze-summary-function 'semantic-format-tag-prototype
+ "Function to use when creating items in Imenu.
+Some useful functions are found in `semantic-format-tag-functions'."
+ :group 'semantic
+ :type semantic-format-tag-custom-list)
+
+(defun semantic-analyze-princ-sequence (sequence &optional prefix buff)
+ "Send the tag SEQUENCE to standard out.
+Use PREFIX as a label.
+Use BUFF as a source of override methods."
+ (while sequence
+ (princ prefix)
+ (cond
+ ((semantic-tag-p (car sequence))
+ (princ (funcall semantic-analyze-summary-function
+ (car sequence))))
+ ((stringp (car sequence))
+ (princ "\"")
+ (princ (semantic--format-colorize-text (car sequence) 'variable))
+ (princ "\""))
+ (t
+ (princ (format "'%S" (car sequence)))))
+ (princ "\n")
+ (setq sequence (cdr sequence))
+ (setq prefix (make-string (length prefix) ? ))
+ ))
+
+(defmethod semantic-analyze-show ((context semantic-analyze-context))
+ "Insert CONTEXT into the current buffer in a nice way."
+ (semantic-analyze-princ-sequence (oref context prefix) "Prefix: " )
+ (semantic-analyze-princ-sequence (oref context prefixclass) "Prefix Classes:
")
+ (semantic-analyze-princ-sequence (oref context prefixtypes) "Prefix Types: ")
+ (semantic-analyze-princ-sequence (oref context errors) "Encountered Errors:
")
+ (princ "--------\n")
+ ;(semantic-analyze-princ-sequence (oref context scopetypes) "Scope Types: ")
+ ;(semantic-analyze-princ-sequence (oref context scope) "Scope: ")
+ ;(semantic-analyze-princ-sequence (oref context localvariables) "LocalVars:
")
+ (when (oref context scope)
+ (semantic-analyze-show (oref context scope)))
+ )
+
+(defmethod semantic-analyze-show ((context
semantic-analyze-context-assignment))
+ "Insert CONTEXT into the current buffer in a nice way."
+ (semantic-analyze-princ-sequence (oref context assignee) "Assignee: ")
+ (call-next-method))
+
+(defmethod semantic-analyze-show ((context
semantic-analyze-context-functionarg))
+ "Insert CONTEXT into the current buffer in a nice way."
+ (semantic-analyze-princ-sequence (oref context function) "Function: ")
+ (princ "Argument Index: ")
+ (princ (oref context index))
+ (princ "\n")
+ (semantic-analyze-princ-sequence (oref context argument) "Argument: ")
+ (call-next-method))
+
+(defun semantic-analyze-pop-to-context (context)
+ "Display CONTEXT in a temporary buffer.
+CONTEXT's content is described in `semantic-analyze-current-context'."
+ (semantic-analyze-pulse context)
+ (with-output-to-temp-buffer "*Semantic Context Analysis*"
+ (princ "Context Type: ")
+ (princ (object-name context))
+ (princ "\n")
+ (princ "Bounds: ")
+ (princ (oref context bounds))
+ (princ "\n")
+ (semantic-analyze-show context)
+ )
+ (shrink-window-if-larger-than-buffer
+ (get-buffer-window "*Semantic Context Analysis*"))
+ )
+
+(provide 'semantic/analyze)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/analyze"
+;; End:
+
+;;; semantic/analyze.el ends here
Index: cedet/semantic/bovine.el
===================================================================
RCS file: cedet/semantic/bovine.el
diff -N cedet/semantic/bovine.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/bovine.el 28 Sep 2009 15:15:07 -0000 1.2
@@ -0,0 +1,297 @@
+;;; semantic/bovine.el --- LL Parser/Analyzer core.
+
+;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Semantix 1.x uses an LL parser named the "bovinator". This parser
+;; had several conveniences in it which made for parsing tags out of
+;; languages with list characters easy. This parser lives on as one
+;; of many available parsers for semantic the tool.
+;;
+;; This parser should be used when the language is simple, such as
+;; makefiles or other data-declaritive langauges.
+
+;;; Code:
+(require 'semantic)
+
+(declare-function semantic-create-bovine-debug-error-frame
+ "semantic/bovine/debug")
+(declare-function semantic-bovine-debug-create-frame
+ "semantic/bovine/debug")
+(declare-function semantic-debug-break "semantic/debug")
+
+;;; Variables
+;;
+(defvar semantic-bovinate-nonterminal-check-obarray nil
+ "Obarray of streams already parsed for nonterminal symbols.
+Use this to detect infinite recursion during a parse.")
+(make-variable-buffer-local 'semantic-bovinate-nonterminal-check-obarray)
+
+
+
+;; These are functions that can be called from within a bovine table.
+;; Most of these have code auto-generated from other construct in the
+;; bovine input grammar.
+(defmacro semantic-lambda (&rest return-val)
+ "Create a lambda expression to return a list including RETURN-VAL.
+The return list is a lambda expression to be used in a bovine table."
+ `(lambda (vals start end)
+ (append ,@return-val (list start end))))
+
+;;; Semantic Bovination
+;;
+;; Take a semantic token stream, and convert it using the bovinator.
+;; The bovinator takes a state table, and converts the token stream
+;; into a new semantic stream defined by the bovination table.
+;;
+(defsubst semantic-bovinate-symbol-nonterminal-p (sym table)
+ "Return non-nil if SYM is in TABLE, indicating it is NONTERMINAL."
+ ;; sym is always a sym, so assq should be ok.
+ (if (assq sym table) t nil))
+
+(defmacro semantic-bovinate-nonterminal-db-nt ()
+ "Return the current nonterminal symbol.
+Part of the grammar source debugger. Depends on the existing
+environment of `semantic-bovinate-stream'."
+ `(if nt-stack
+ (car (aref (car nt-stack) 2))
+ nonterminal))
+
+(defun semantic-bovinate-nonterminal-check (stream nonterminal)
+ "Check if STREAM not already parsed for NONTERMINAL.
+If so abort because an infinite recursive parse is suspected."
+ (or (vectorp semantic-bovinate-nonterminal-check-obarray)
+ (setq semantic-bovinate-nonterminal-check-obarray
+ (make-vector 13 nil)))
+ (let* ((nt (symbol-name nonterminal))
+ (vs (symbol-value
+ (intern-soft
+ nt semantic-bovinate-nonterminal-check-obarray))))
+ (if (memq stream vs)
+ ;; Always enter debugger to see the backtrace
+ (let ((debug-on-signal t)
+ (debug-on-error t))
+ (setq semantic-bovinate-nonterminal-check-obarray nil)
+ (error "Infinite recursive parse suspected on %s" nt))
+ (set (intern nt semantic-bovinate-nonterminal-check-obarray)
+ (cons stream vs)))))
+
+;;;###autoload
+(defun semantic-bovinate-stream (stream &optional nonterminal)
+ "Bovinate STREAM, starting at the first NONTERMINAL rule.
+Use `bovine-toplevel' if NONTERMINAL is not provided.
+This is the core routine for converting a stream into a table.
+Return the list (STREAM SEMANTIC-STREAM) where STREAM are those
+elements of STREAM that have not been used. SEMANTIC-STREAM is the
+list of semantic tokens found."
+ (if (not nonterminal)
+ (setq nonterminal 'bovine-toplevel))
+
+ ;; Try to detect infinite recursive parse when doing a full reparse.
+ (or semantic--buffer-cache
+ (semantic-bovinate-nonterminal-check stream nonterminal))
+
+ (let* ((table semantic--parse-table)
+ (matchlist (cdr (assq nonterminal table)))
+ (starting-stream stream)
+ (nt-loop t) ;non-terminal loop condition
+ nt-popup ;non-nil if return from nt recursion
+ nt-stack ;non-terminal recursion stack
+ s ;Temp Stream Tracker
+ lse ;Local Semantic Element
+ lte ;Local matchlist element
+ tev ;Matchlist entry values from buffer
+ val ;Value found in buffer.
+ cvl ;collected values list.
+ out ;Output
+ end ;End of match
+ result
+ )
+ (condition-case debug-condition
+ (while nt-loop
+ (catch 'push-non-terminal
+ (setq nt-popup nil
+ end (semantic-lex-token-end (car stream)))
+ (while (or nt-loop nt-popup)
+ (setq nt-loop nil
+ out nil)
+ (while (or nt-popup matchlist)
+ (if nt-popup
+ ;; End of a non-terminal recursion
+ (setq nt-popup nil)
+ ;; New matching process
+ (setq s stream ;init s from stream.
+ cvl nil ;re-init the collected value list.
+ lte (car matchlist) ;Get the local matchlist entry.
+ )
+ (if (or (byte-code-function-p (car lte))
+ (listp (car lte)))
+ ;; In this case, we have an EMPTY match! Make
+ ;; stuff up.
+ (setq cvl (list nil))))
+
+ (while (and lte
+ (not (byte-code-function-p (car lte)))
+ (not (listp (car lte))))
+
+ ;; GRAMMAR SOURCE DEBUGGING!
+ (if (and (boundp 'semantic-debug-enabled)
+ semantic-debug-enabled)
+ (let* ((db-nt (semantic-bovinate-nonterminal-db-nt))
+ (db-ml (cdr (assq db-nt table)))
+ (db-mlen (length db-ml))
+ (db-midx (- db-mlen (length matchlist)))
+ (db-tlen (length (nth db-midx db-ml)))
+ (db-tidx (- db-tlen (length lte)))
+ (frame (progn
+ (require 'semantic/bovine/debug)
+ (semantic-bovine-debug-create-frame
+ db-nt db-midx db-tidx cvl (car s))))
+ (cmd (semantic-debug-break frame))
+ )
+ (cond ((eq 'fail cmd) (setq lte '(trash 0 . 0)))
+ ((eq 'quit cmd) (signal 'quit "Abort"))
+ ((eq 'abort cmd) (error "Abort"))
+ ;; support more commands here.
+
+ )))
+ ;; END GRAMMAR SOURCE DEBUGGING!
+
+ (cond
+ ;; We have a nonterminal symbol. Recurse inline.
+ ((setq nt-loop (assq (car lte) table))
+
+ (setq
+ ;; push state into the nt-stack
+ nt-stack (cons (vector matchlist cvl lte stream end
+ )
+ nt-stack)
+ ;; new non-terminal matchlist
+ matchlist (cdr nt-loop)
+ ;; new non-terminal stream
+ stream s)
+
+ (throw 'push-non-terminal t)
+
+ )
+ ;; Default case
+ (t
+ (setq lse (car s) ;Get the local stream element
+ s (cdr s)) ;update stream.
+ ;; Do the compare
+ (if (eq (car lte) (semantic-lex-token-class lse))
;syntactic match
+ (let ((valdot (semantic-lex-token-bounds lse)))
+ (setq val (semantic-lex-token-text lse))
+ (setq lte (cdr lte))
+ (if (stringp (car lte))
+ (progn
+ (setq tev (car lte)
+ lte (cdr lte))
+ (if (string-match tev val)
+ (setq cvl (cons
+ (if (memq
(semantic-lex-token-class lse)
+ '(comment
semantic-list))
+ valdot val)
+ cvl)) ;append this value
+ (setq lte nil cvl nil))) ;clear the entry
(exit)
+ (setq cvl (cons
+ (if (memq (semantic-lex-token-class lse)
+ '(comment semantic-list))
+ valdot val) cvl))) ;append
unchecked value.
+ (setq end (semantic-lex-token-end lse))
+ )
+ (setq lte nil cvl nil)) ;No more matches, exit
+ )))
+ (if (not cvl) ;lte=nil; there was no match.
+ (setq matchlist (cdr matchlist)) ;Move to next matchlist
entry
+ (let ((start (semantic-lex-token-start (car stream))))
+ (setq out (cond
+ ((car lte)
+ (funcall (car lte) ;call matchlist fn on values
+ (nreverse cvl) start end))
+ ((and (= (length cvl) 1)
+ (listp (car cvl))
+ (not (numberp (car (car cvl)))))
+ (append (car cvl) (list start end)))
+ (t
+ ;;(append (nreverse cvl) (list start end))))
+ ;; MAYBE THE FOLLOWING NEEDS LESS CONS
+ ;; CELLS THAN THE ABOVE?
+ (nreverse (cons end (cons start cvl)))))
+ matchlist nil) ;;generate exit condition
+ (if (not end)
+ (setq out nil)))
+ ;; Nothin?
+ ))
+ (setq result
+ (if (eq s starting-stream)
+ (list (cdr s) nil)
+ (list s out)))
+ (if nt-stack
+ ;; pop previous state from the nt-stack
+ (let ((state (car nt-stack)))
+
+ (setq nt-popup t
+ ;; pop actual parser state
+ matchlist (aref state 0)
+ cvl (aref state 1)
+ lte (aref state 2)
+ stream (aref state 3)
+ end (aref state 4)
+ ;; update the stack
+ nt-stack (cdr nt-stack))
+
+ (if out
+ (let ((len (length out))
+ (strip (nreverse (cdr (cdr (reverse out))))))
+ (setq end (nth (1- len) out) ;reset end to the end
of exp
+ cvl (cons strip cvl) ;prepend value of exp
+ lte (cdr lte)) ;update the local table entry
+ )
+ ;; No value means that we need to terminate this
+ ;; match.
+ (setq lte nil cvl nil)) ;No match, exit
+ )))))
+ (error
+ ;; On error just move forward the stream of lexical tokens
+ (setq result (list (cdr starting-stream) nil))
+ (when (and (boundp 'semantic-debug-enabled)
+ semantic-debug-enabled)
+ (require 'semantic/bovine/debug)
+ (let ((frame (semantic-create-bovine-debug-error-frame
+ debug-condition)))
+ (semantic-debug-break frame)))))
+ result))
+
+;; Make it the default parser
+;;;###autoload
+(defalias 'semantic-parse-stream-default 'semantic-bovinate-stream)
+
+(provide 'semantic/bovine)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/bovine"
+;; End:
+
+;;; semantic/bovine.el ends here
Index: cedet/semantic/chart.el
===================================================================
RCS file: cedet/semantic/chart.el
diff -N cedet/semantic/chart.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/chart.el 28 Sep 2009 15:15:07 -0000 1.2
@@ -0,0 +1,174 @@
+;;; semantic/chart.el --- Utilities for use with semantic tag tables
+
+;;; Copyright (C) 1999, 2000, 2001, 2003, 2005, 2008, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; A set of simple functions for charting details about a file based on
+;; the output of the semantic parser.
+;;
+
+(require 'semantic)
+(require 'chart)
+(require 'semantic/db)
+(require 'semantic/tag)
+
+(eval-when-compile (require 'semantic/find))
+
+;;; Code:
+
+(defun semantic-chart-tags-by-class (&optional tagtable)
+ "Create a bar chart representing the number of tags for a given tag class.
+Each bar represents how many toplevel tags in TAGTABLE
+exist with a given class. See `semantic-symbol->name-assoc-list'
+for tokens which will be charted.
+TAGTABLE is passedto `semantic-something-to-tag-table'."
+ (interactive)
+ (let* ((stream (semantic-something-to-tag-table
+ (or tagtable (current-buffer))))
+ (names (mapcar 'cdr semantic-symbol->name-assoc-list))
+ (nums (mapcar
+ (lambda (symname)
+ (length
+ (semantic-brute-find-tag-by-class (car symname)
+ stream)
+ ))
+ semantic-symbol->name-assoc-list)))
+ (chart-bar-quickie 'vertical
+ "Semantic Toplevel Tag Volume"
+ names "Tag Class"
+ nums "Volume")
+ ))
+
+(defun semantic-chart-database-size (&optional tagtable)
+ "Create a bar chart representing the size of each file in semanticdb.
+Each bar represents how many toplevel tags in TAGTABLE
+exist in each database entry.
+TAGTABLE is passed to `semantic-something-to-tag-table'."
+ (interactive)
+ (unless (and (fboundp 'semanticdb-minor-mode-p)
+ (semanticdb-minor-mode-p))
+ (error "Semanticdb is not enabled"))
+ (let* ((db semanticdb-current-database)
+ (dbt (semanticdb-get-database-tables db))
+ (names (mapcar 'car
+ (object-assoc-list
+ 'file
+ dbt)))
+ (numnuts (mapcar (lambda (dba)
+ (prog1
+ (cons
+ (if (slot-boundp dba 'tags)
+ (length (oref dba tags))
+ 1)
+ (car names))
+ (setq names (cdr names))))
+ dbt))
+ (nums nil)
+ (fh (/ (- (frame-height) 7) 4)))
+ (setq numnuts (sort numnuts (lambda (a b) (> (car a) (car b)))))
+ (setq names (mapcar 'cdr numnuts)
+ nums (mapcar 'car numnuts))
+ (if (> (length names) fh)
+ (progn
+ (setcdr (nthcdr fh names) nil)
+ (setcdr (nthcdr fh nums) nil)))
+ (chart-bar-quickie 'horizontal
+ "Semantic DB Toplevel Tag Volume"
+ names "File"
+ nums "Volume")
+ ))
+
+(defun semantic-chart-token-complexity (tok)
+ "Calculate the `complexity' of token TOK."
+ (count-lines
+ (semantic-tag-end tok)
+ (semantic-tag-start tok)))
+
+(defun semantic-chart-tag-complexity
+ (&optional class tagtable)
+ "Create a bar chart representing the complexity of some tags.
+Complexity is calculated for tags of CLASS. Each bar represents
+the complexity of some tag in TAGTABLE. Only the most complex
+items are charted. TAGTABLE is passedto
+`semantic-something-to-tag-table'."
+ (interactive)
+ (let* ((sym (if (not class) 'function))
+ (stream
+ (semantic-find-tags-by-class
+ sym (semantic-something-to-tag-table (or tagtable
+ (current-buffer)))
+ ))
+ (name (cond ((semantic-tag-with-position-p (car stream))
+ (buffer-name (semantic-tag-buffer (car stream))))
+ (t "")))
+ (cplx (mapcar (lambda (tok)
+ (cons tok (semantic-chart-token-complexity tok)))
+ stream))
+ (namelabel (cdr (assoc 'function semantic-symbol->name-assoc-list)))
+ (names nil)
+ (nums nil))
+ (setq cplx (sort cplx (lambda (a b) (> (cdr a) (cdr b)))))
+ (while (and cplx (<= (length names) (/ (- (frame-height) 7) 4)))
+ (setq names (cons (semantic-tag-name (car (car cplx)))
+ names)
+ nums (cons (cdr (car cplx)) nums)
+ cplx (cdr cplx)))
+;; ;; (setq names (mapcar (lambda (str)
+;; ;; (substring str (- (length str) 10)))
+;; ;; names))
+ (chart-bar-quickie 'horizontal
+ (format "%s Complexity in %s"
+ (capitalize (symbol-name sym))
+ name)
+ names namelabel
+ nums "Complexity (Lines of code)")
+ ))
+
+(declare-function semanticdb-get-typecache "semantic/db-typecache")
+(declare-function semantic-calculate-scope "semantic/scope")
+
+(defun semantic-chart-analyzer ()
+ "Chart the extent of the context analysis."
+ (interactive)
+ (require 'semantic/db-typecache)
+ (require 'semantic/scope)
+ (let* ((p (semanticdb-find-translate-path nil nil))
+ (plen (length p))
+ (tab semanticdb-current-table)
+ (tc (semanticdb-get-typecache tab))
+ (tclen (+ (length (oref tc filestream))
+ (length (oref tc includestream))))
+ (scope (semantic-calculate-scope))
+ (fslen (length (oref scope fullscope)))
+ (lvarlen (length (oref scope localvar)))
+ )
+ (chart-bar-quickie 'vertical
+ (format "Analyzer Overhead in %s" (buffer-name))
+ '("includes" "typecache" "scopelen" "localvar")
+ "Overhead Entries"
+ (list plen tclen fslen lvarlen)
+ "Number of tags")
+ ))
+
+(provide 'semantic/chart)
+
+;;; semantic/chart.el ends here
Index: cedet/semantic/complete.el
===================================================================
RCS file: cedet/semantic/complete.el
diff -N cedet/semantic/complete.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/complete.el 28 Sep 2009 15:15:07 -0000 1.2
@@ -0,0 +1,2101 @@
+;;; semantic/complete.el --- Routines for performing tag completion
+
+;;; Copyright (C) 2003, 2004, 2005, 2007, 2008, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Completion of tags by name using tables of semantic generated tags.
+;;
+;; While it would be a simple matter of flattening all tag known
+;; tables to perform completion across them using `all-completions',
+;; or `try-completion', that process would be slow. In particular,
+;; when a system database is included in the mix, the potential for a
+;; ludicrous number of options becomes apparent.
+;;
+;; As such, dynamically searching across tables using a prefix,
+;; regular expression, or other feature is needed to help find symbols
+;; quickly without resorting to "show me every possible option now".
+;;
+;; In addition, some symbol names will appear in multiple locations.
+;; If it is important to distiguish, then a way to provide a choice
+;; over these locations is important as well.
+;;
+;; Beyond brute force offers for completion of plain strings,
+;; using the smarts of semantic-analyze to provide reduced lists of
+;; symbols, or fancy tabbing to zoom into files to show multiple hits
+;; of the same name can be provided.
+;;
+;;; How it works:
+;;
+;; There are several parts of any completion engine. They are:
+;;
+;; A. Collection of possible hits
+;; B. Typing or selecting an option
+;; C. Displaying possible unique completions
+;; D. Using the result
+;;
+;; Here, we will treat each section separately (excluding D)
+;; They can then be strung together in user-visible commands to
+;; fullfill specific needs.
+;;
+;; COLLECTORS:
+;;
+;; A collector is an object which represents the means by which tags
+;; to complete on are collected. It's first job is to find all the
+;; tags which are to be completed against. It can also rename
+;; some tags if needed so long as `semantic-tag-clone' is used.
+;;
+;; Some collectors will gather all tags to complete against first
+;; (for in buffer queries, or other small list situations). It may
+;; choose to do a broad search on each completion request. Built in
+;; functionality automatically focuses the cache in as the user types.
+;;
+;; A collector choosing to create and rename tags could choose a
+;; plain name format, a postfix name such as method:class, or a
+;; prefix name such as class.method.
+;;
+;; DISPLAYORS
+;;
+;; A displayor is in charge if showing the user interesting things
+;; about available completions, and can optionally provide a focus.
+;; The simplest display just lists all available names in a separate
+;; window. It may even choose to show short names when there are
+;; many to choose from, or long names when there are fewer.
+;;
+;; A complex displayor could opt to help the user 'focus' on some
+;; range. For example, if 4 tags all have the same name, subsequent
+;; calls to the displayor may opt to show each tag one at a time in
+;; the buffer. When the user likes one, selection would cause the
+;; 'focus' item to be selected.
+;;
+;; CACHE FORMAT
+;;
+;; The format of the tag lists used to perform the completions are in
+;; semanticdb "find" format, like this:
+;;
+;; ( ( DBTABLE1 TAG1 TAG2 ...)
+;; ( DBTABLE2 TAG1 TAG2 ...)
+;; ... )
+;;
+;; INLINE vs MINIBUFFER
+;;
+;; Two major ways completion is used in Emacs is either through a
+;; minibuffer query, or via completion in a normal editing buffer,
+;; encompassing some small range of characters.
+;;
+;; Structure for both types of completion are provided here.
+;; `semantic-complete-read-tag-engine' will use the minibuffer.
+;; `semantic-complete-inline-tag-engine' will complete text in
+;; a buffer.
+
+(require 'semantic)
+(require 'eieio-opt)
+(require 'semantic/analyze)
+(require 'semantic/ctxt)
+(require 'semantic/decorate)
+(require 'semantic/format)
+
+(eval-when-compile
+ ;; For the semantic-find-tags-for-completion macro.
+ (require 'semantic/find))
+
+;;; Code:
+
+(defvar semantic-complete-inline-overlay nil
+ "The overlay currently active while completing inline.")
+
+(defun semantic-completion-inline-active-p ()
+ "Non-nil if inline completion is active."
+ (when (and semantic-complete-inline-overlay
+ (not (semantic-overlay-live-p semantic-complete-inline-overlay)))
+ (semantic-overlay-delete semantic-complete-inline-overlay)
+ (setq semantic-complete-inline-overlay nil))
+ semantic-complete-inline-overlay)
+
+;;; ------------------------------------------------------------
+;;; MINIBUFFER or INLINE utils
+;;
+(defun semantic-completion-text ()
+ "Return the text that is currently in the completion buffer.
+For a minibuffer prompt, this is the minibuffer text.
+For inline completion, this is the text wrapped in the inline completion
+overlay."
+ (if semantic-complete-inline-overlay
+ (semantic-complete-inline-text)
+ (minibuffer-contents)))
+
+(defun semantic-completion-delete-text ()
+ "Delete the text that is actively being completed.
+Presumably if you call this you will insert something new there."
+ (if semantic-complete-inline-overlay
+ (semantic-complete-inline-delete-text)
+ (delete-minibuffer-contents)))
+
+(defun semantic-completion-message (fmt &rest args)
+ "Display the string FMT formatted with ARGS at the end of the minibuffer."
+ (if semantic-complete-inline-overlay
+ (apply 'message fmt args)
+ (message (concat (buffer-string) (apply 'format fmt args)))))
+
+;;; ------------------------------------------------------------
+;;; MINIBUFFER: Option Selection harnesses
+;;
+(defvar semantic-completion-collector-engine nil
+ "The tag collector for the current completion operation.
+Value should be an object of a subclass of
+`semantic-completion-engine-abstract'.")
+
+(defvar semantic-completion-display-engine nil
+ "The tag display engine for the current completion operation.
+Value should be a ... what?")
+
+(defvar semantic-complete-key-map
+ (let ((km (make-sparse-keymap)))
+ (define-key km " " 'semantic-complete-complete-space)
+ (define-key km "\t" 'semantic-complete-complete-tab)
+ (define-key km "\C-m" 'semantic-complete-done)
+ (define-key km "\C-g" 'abort-recursive-edit)
+ (define-key km "\M-n" 'next-history-element)
+ (define-key km "\M-p" 'previous-history-element)
+ (define-key km "\C-n" 'next-history-element)
+ (define-key km "\C-p" 'previous-history-element)
+ ;; Add history navigation
+ km)
+ "Keymap used while completing across a list of tags.")
+
+(defvar semantic-completion-default-history nil
+ "Default history variable for any unhistoried prompt.
+Keeps STRINGS only in the history.")
+
+
+(defun semantic-complete-read-tag-engine (collector displayor prompt
+ default-tag initial-input
+ history)
+ "Read a semantic tag, and return a tag for the selection.
+Argument COLLECTOR is an object which can be used to to calculate
+a list of possible hits. See `semantic-completion-collector-engine'
+for details on COLLECTOR.
+Argumeng DISPLAYOR is an object used to display a list of possible
+completions for a given prefix. See`semantic-completion-display-engine'
+for details on DISPLAYOR.
+PROMPT is a string to prompt with.
+DEFAULT-TAG is a semantic tag or string to use as the default value.
+If INITIAL-INPUT is non-nil, insert it in the minibuffer initially.
+HISTORY is a symbol representing a variable to story the history in."
+ (let* ((semantic-completion-collector-engine collector)
+ (semantic-completion-display-engine displayor)
+ (semantic-complete-active-default nil)
+ (semantic-complete-current-matched-tag nil)
+ (default-as-tag (semantic-complete-default-to-tag default-tag))
+ (default-as-string (when (semantic-tag-p default-as-tag)
+ (semantic-tag-name default-as-tag)))
+ )
+
+ (when default-as-string
+ ;; Add this to the prompt.
+ ;;
+ ;; I really want to add a lookup of the symbol in those
+ ;; tags available to the collector and only add it if it
+ ;; is available as a possibility, but I'm too lazy right
+ ;; now.
+ ;;
+
+ ;; @todo - move from () to into the editable area
+ (if (string-match ":" prompt)
+ (setq prompt (concat
+ (substring prompt 0 (match-beginning 0))
+ " (" default-as-string ")"
+ (substring prompt (match-beginning 0))))
+ (setq prompt (concat prompt " (" default-as-string "): "))))
+ ;;
+ ;; Perform the Completion
+ ;;
+ (unwind-protect
+ (read-from-minibuffer prompt
+ initial-input
+ semantic-complete-key-map
+ nil
+ (or history
+ 'semantic-completion-default-history)
+ default-tag)
+ (semantic-collector-cleanup semantic-completion-collector-engine)
+ (semantic-displayor-cleanup semantic-completion-display-engine)
+ )
+ ;;
+ ;; Extract the tag from the completion machinery.
+ ;;
+ semantic-complete-current-matched-tag
+ ))
+
+
+;;; Util for basic completion prompts
+;;
+
+(defvar semantic-complete-active-default nil
+ "The current default tag calculated for this prompt.")
+
+(defun semantic-complete-default-to-tag (default)
+ "Convert a calculated or passed in DEFAULT into a tag."
+ (if (semantic-tag-p default)
+ ;; Just return what was passed in.
+ (setq semantic-complete-active-default default)
+ ;; If none was passed in, guess.
+ (if (null default)
+ (setq default (semantic-ctxt-current-thing)))
+ (if (null default)
+ ;; Do nothing
+ nil
+ ;; Turn default into something useful.
+ (let ((str
+ (cond
+ ;; Semantic-ctxt-current-symbol will return a list of
+ ;; strings. Technically, we should use the analyzer to
+ ;; fully extract what we need, but for now, just grab the
+ ;; first string
+ ((and (listp default) (stringp (car default)))
+ (car default))
+ ((stringp default)
+ default)
+ ((symbolp default)
+ (symbol-name default))
+ (t
+ (signal 'wrong-type-argument
+ (list default 'semantic-tag-p)))))
+ (tag nil))
+ ;; Now that we have that symbol string, look it up using the active
+ ;; collector. If we get a match, use it.
+ (save-excursion
+ (semantic-collector-calculate-completions
+ semantic-completion-collector-engine
+ str nil))
+ ;; Do we have the perfect match???
+ (let ((ml (semantic-collector-current-exact-match
+ semantic-completion-collector-engine)))
+ (when ml
+ ;; We don't care about uniqueness. Just guess for convenience
+ (setq tag (semanticdb-find-result-nth-in-buffer ml 0))))
+ ;; save it
+ (setq semantic-complete-active-default tag)
+ ;; Return it.. .whatever it may be
+ tag))))
+
+
+;;; Prompt Return Value
+;;
+;; Getting a return value out of this completion prompt is a bit
+;; challenging. The read command returns the string typed in.
+;; We need to convert this into a valid tag. We can exit the minibuffer
+;; for different reasons. If we purposely exit, we must make sure
+;; the focused tag is calculated... preferably once.
+(defvar semantic-complete-current-matched-tag nil
+ "Variable used to pass the tags being matched to the prompt.")
+
+;; semantic-displayor-focus-abstract-child-p is part of the
+;; semantic-displayor-focus-abstract class, defined later in this
+;; file.
+(declare-function semantic-displayor-focus-abstract-child-p
"semantic/complete")
+
+(defun semantic-complete-current-match ()
+ "Calculate a match from the current completion environment.
+Save this in our completion variable. Make sure that variable
+is cleared if any other keypress is made.
+Return value can be:
+ tag - a single tag that has been matched.
+ string - a message to show in the minibuffer."
+ ;; Query the environment for an active completion.
+ (let ((collector semantic-completion-collector-engine)
+ (displayor semantic-completion-display-engine)
+ (contents (semantic-completion-text))
+ matchlist
+ answer)
+ (if (string= contents "")
+ ;; The user wants the defaults!
+ (setq answer semantic-complete-active-default)
+ ;; This forces a full calculation of completion on CR.
+ (save-excursion
+ (semantic-collector-calculate-completions collector contents nil))
+ (semantic-complete-try-completion)
+ (cond
+ ;; Input match displayor focus entry
+ ((setq answer (semantic-displayor-current-focus displayor))
+ ;; We have answer, continue
+ )
+ ;; One match from the collector
+ ((setq matchlist (semantic-collector-current-exact-match collector))
+ (if (= (semanticdb-find-result-length matchlist) 1)
+ (setq answer (semanticdb-find-result-nth-in-buffer matchlist 0))
+ (if (semantic-displayor-focus-abstract-child-p displayor)
+ ;; For focusing displayors, we can claim this is
+ ;; not unique. Multiple focuses can choose the correct
+ ;; one.
+ (setq answer "Not Unique")
+ ;; If we don't have a focusing displayor, we need to do something
+ ;; graceful. First, see if all the matches have the same name.
+ (let ((allsame t)
+ (firstname (semantic-tag-name
+ (car
+ (semanticdb-find-result-nth matchlist 0)))
+ )
+ (cnt 1)
+ (max (semanticdb-find-result-length matchlist)))
+ (while (and allsame (< cnt max))
+ (if (not (string=
+ firstname
+ (semantic-tag-name
+ (car
+ (semanticdb-find-result-nth matchlist cnt)))))
+ (setq allsame nil))
+ (setq cnt (1+ cnt))
+ )
+ ;; Now we know if they are all the same. If they are, just
+ ;; accept the first, otherwise complain.
+ (if allsame
+ (setq answer (semanticdb-find-result-nth-in-buffer
+ matchlist 0))
+ (setq answer "Not Unique"))
+ ))))
+ ;; No match
+ (t
+ (setq answer "No Match")))
+ )
+ ;; Set it into our completion target.
+ (when (semantic-tag-p answer)
+ (setq semantic-complete-current-matched-tag answer)
+ ;; Make sure it is up to date by clearing it if the user dares
+ ;; to touch the keyboard.
+ (add-hook 'pre-command-hook
+ (lambda () (setq semantic-complete-current-matched-tag nil)))
+ )
+ ;; Return it
+ answer
+ ))
+
+
+;;; Keybindings
+;;
+;; Keys are bound to to perform completion using our mechanisms.
+;; Do that work here.
+(defun semantic-complete-done ()
+ "Accept the current input."
+ (interactive)
+ (let ((ans (semantic-complete-current-match)))
+ (if (stringp ans)
+ (semantic-completion-message (concat " [" ans "]"))
+ (exit-minibuffer)))
+ )
+
+(defun semantic-complete-complete-space ()
+ "Complete the partial input in the minibuffer."
+ (interactive)
+ (semantic-complete-do-completion t))
+
+(defun semantic-complete-complete-tab ()
+ "Complete the partial input in the minibuffer as far as possible."
+ (interactive)
+ (semantic-complete-do-completion))
+
+;;; Completion Functions
+;;
+;; Thees routines are functional entry points to performing completion.
+;;
+(defun semantic-complete-hack-word-boundaries (original new)
+ "Return a string to use for completion.
+ORIGINAL is the text in the minibuffer.
+NEW is the new text to insert into the minibuffer.
+Within the difference bounds of ORIGINAL and NEW, shorten NEW
+to the nearest word boundary, and return that."
+ (save-match-data
+ (let* ((diff (substring new (length original)))
+ (end (string-match "\\>" diff))
+ (start (string-match "\\<" diff)))
+ (cond
+ ((and start (> start 0))
+ ;; If start is greater than 0, include only the new
+ ;; white-space stuff
+ (concat original (substring diff 0 start)))
+ (end
+ (concat original (substring diff 0 end)))
+ (t new)))))
+
+(defun semantic-complete-try-completion (&optional partial)
+ "Try a completion for the current minibuffer.
+If PARTIAL, do partial completion stopping at spaces."
+ (let ((comp (semantic-collector-try-completion
+ semantic-completion-collector-engine
+ (semantic-completion-text))))
+ (cond
+ ((null comp)
+ (semantic-completion-message " [No Match]")
+ (ding)
+ )
+ ((stringp comp)
+ (if (string= (semantic-completion-text) comp)
+ (when partial
+ ;; Minibuffer isn't changing AND the text is not unique.
+ ;; Test for partial completion over a word separator character.
+ ;; If there is one available, use that so that SPC can
+ ;; act like a SPC insert key.
+ (let ((newcomp (semantic-collector-current-whitespace-completion
+ semantic-completion-collector-engine)))
+ (when newcomp
+ (semantic-completion-delete-text)
+ (insert newcomp))
+ ))
+ (when partial
+ (let ((orig (semantic-completion-text)))
+ ;; For partial completion, we stop and step over
+ ;; word boundaries. Use this nifty function to do
+ ;; that calculation for us.
+ (setq comp
+ (semantic-complete-hack-word-boundaries orig comp))))
+ ;; Do the replacement.
+ (semantic-completion-delete-text)
+ (insert comp))
+ )
+ ((and (listp comp) (semantic-tag-p (car comp)))
+ (unless (string= (semantic-completion-text)
+ (semantic-tag-name (car comp)))
+ ;; A fully unique completion was available.
+ (semantic-completion-delete-text)
+ (insert (semantic-tag-name (car comp))))
+ ;; The match is complete
+ (if (= (length comp) 1)
+ (semantic-completion-message " [Complete]")
+ (semantic-completion-message " [Complete, but not unique]"))
+ )
+ (t nil))))
+
+(defun semantic-complete-do-completion (&optional partial inline)
+ "Do a completion for the current minibuffer.
+If PARTIAL, do partial completion stopping at spaces.
+if INLINE, then completion is happening inline in a buffer."
+ (let* ((collector semantic-completion-collector-engine)
+ (displayor semantic-completion-display-engine)
+ (contents (semantic-completion-text))
+ (ans nil))
+
+ (save-excursion
+ (semantic-collector-calculate-completions collector contents partial))
+ (let* ((na (semantic-complete-next-action partial)))
+ (cond
+ ;; We're all done, but only from a very specific
+ ;; area of completion.
+ ((eq na 'done)
+ (semantic-completion-message " [Complete]")
+ (setq ans 'done))
+ ;; Perform completion
+ ((or (eq na 'complete)
+ (eq na 'complete-whitespace))
+ (semantic-complete-try-completion partial)
+ (setq ans 'complete))
+ ;; We need to display the completions.
+ ;; Set the completions into the display engine
+ ((or (eq na 'display) (eq na 'displayend))
+ (semantic-displayor-set-completions
+ displayor
+ (or
+ (and (not (eq na 'displayend))
+ (semantic-collector-current-exact-match collector))
+ (semantic-collector-all-completions collector contents))
+ contents)
+ ;; Ask the displayor to display them.
+ (semantic-displayor-show-request displayor))
+ ((eq na 'scroll)
+ (semantic-displayor-scroll-request displayor)
+ )
+ ((eq na 'focus)
+ (semantic-displayor-focus-next displayor)
+ (semantic-displayor-focus-request displayor)
+ )
+ ((eq na 'empty)
+ (semantic-completion-message " [No Match]"))
+ (t nil)))
+ ans))
+
+
+;;; ------------------------------------------------------------
+;;; INLINE: tag completion harness
+;;
+;; Unlike the minibuffer, there is no mode nor other traditional
+;; means of reading user commands in completion mode. Instead
+;; we use a pre-command-hook to inset in our commands, and to
+;; push ourselves out of this mode on alternate keypresses.
+(defvar semantic-complete-inline-map
+ (let ((km (make-sparse-keymap)))
+ (define-key km "\C-i" 'semantic-complete-inline-TAB)
+ (define-key km "\M-p" 'semantic-complete-inline-up)
+ (define-key km "\M-n" 'semantic-complete-inline-down)
+ (define-key km "\C-m" 'semantic-complete-inline-done)
+ (define-key km "\C-\M-c" 'semantic-complete-inline-exit)
+ (define-key km "\C-g" 'semantic-complete-inline-quit)
+ (define-key km "?"
+ (lambda () (interactive)
+ (describe-variable 'semantic-complete-inline-map)))
+ km)
+ "Keymap used while performing Semantic inline completion.
+\\{semantic-complete-inline-map}")
+
+(defface semantic-complete-inline-face
+ '((((class color) (background dark))
+ (:underline "yellow"))
+ (((class color) (background light))
+ (:underline "brown")))
+ "*Face used to show the region being completed inline.
+The face is used in `semantic-complete-inline-tag-engine'."
+ :group 'semantic-faces)
+
+(defun semantic-complete-inline-text ()
+ "Return the text that is being completed inline.
+Similar to `minibuffer-contents' when completing in the minibuffer."
+ (let ((s (semantic-overlay-start semantic-complete-inline-overlay))
+ (e (semantic-overlay-end semantic-complete-inline-overlay)))
+ (if (= s e)
+ ""
+ (buffer-substring-no-properties s e ))))
+
+(defun semantic-complete-inline-delete-text ()
+ "Delete the text currently being completed in the current buffer."
+ (delete-region
+ (semantic-overlay-start semantic-complete-inline-overlay)
+ (semantic-overlay-end semantic-complete-inline-overlay)))
+
+(defun semantic-complete-inline-done ()
+ "This completion thing is DONE, OR, insert a newline."
+ (interactive)
+ (let* ((displayor semantic-completion-display-engine)
+ (tag (semantic-displayor-current-focus displayor)))
+ (if tag
+ (let ((txt (semantic-completion-text)))
+ (insert (substring (semantic-tag-name tag)
+ (length txt)))
+ (semantic-complete-inline-exit))
+
+ ;; Get whatever binding RET usually has.
+ (let ((fcn
+ (condition-case nil
+ (lookup-key (current-active-maps) (this-command-keys))
+ (error
+ ;; I don't know why, but for some reason the above
+ ;; throws an error sometimes.
+ (lookup-key (current-global-map) (this-command-keys))
+ ))))
+ (when fcn
+ (funcall fcn)))
+ )))
+
+(defun semantic-complete-inline-quit ()
+ "Quit an inline edit."
+ (interactive)
+ (semantic-complete-inline-exit)
+ (keyboard-quit))
+
+(defun semantic-complete-inline-exit ()
+ "Exit inline completion mode."
+ (interactive)
+ ;; Remove this hook FIRST!
+ (remove-hook 'pre-command-hook 'semantic-complete-pre-command-hook)
+
+ (condition-case nil
+ (progn
+ (when semantic-completion-collector-engine
+ (semantic-collector-cleanup semantic-completion-collector-engine))
+ (when semantic-completion-display-engine
+ (semantic-displayor-cleanup semantic-completion-display-engine))
+
+ (when semantic-complete-inline-overlay
+ (let ((wc (semantic-overlay-get semantic-complete-inline-overlay
+ 'window-config-start))
+ (buf (semantic-overlay-buffer semantic-complete-inline-overlay))
+ )
+ (semantic-overlay-delete semantic-complete-inline-overlay)
+ (setq semantic-complete-inline-overlay nil)
+ ;; DONT restore the window configuration if we just
+ ;; switched windows!
+ (when (eq buf (current-buffer))
+ (set-window-configuration wc))
+ ))
+
+ (setq semantic-completion-collector-engine nil
+ semantic-completion-display-engine nil))
+ (error nil))
+
+ ;; Remove this hook LAST!!!
+ ;; This will force us back through this function if there was
+ ;; some sort of error above.
+ (remove-hook 'post-command-hook 'semantic-complete-post-command-hook)
+
+ ;;(message "Exiting inline completion.")
+ )
+
+(defun semantic-complete-pre-command-hook ()
+ "Used to redefine what commands are being run while completing.
+When installed as a `pre-command-hook' the special keymap
+`semantic-complete-inline-map' is queried to replace commands normally run.
+Commands which edit what is in the region of interest operate normally.
+Commands which would take us out of the region of interest, or our
+quit hook, will exit this completion mode."
+ (let ((fcn (lookup-key semantic-complete-inline-map
+ (this-command-keys) nil)))
+ (cond ((commandp fcn)
+ (setq this-command fcn))
+ (t nil)))
+ )
+
+(defun semantic-complete-post-command-hook ()
+ "Used to determine if we need to exit inline completion mode.
+If completion mode is active, check to see if we are within
+the bounds of `semantic-complete-inline-overlay', or within
+a reasonable distance."
+ (condition-case nil
+ ;; Exit if something bad happened.
+ (if (not semantic-complete-inline-overlay)
+ (progn
+ ;;(message "Inline Hook installed, but overlay deleted.")
+ (semantic-complete-inline-exit))
+ ;; Exit if commands caused us to exit the area of interest
+ (let ((s (semantic-overlay-start semantic-complete-inline-overlay))
+ (e (semantic-overlay-end semantic-complete-inline-overlay))
+ (b (semantic-overlay-buffer semantic-complete-inline-overlay))
+ (txt nil)
+ )
+ (cond
+ ;; EXIT when we are no longer in a good place.
+ ((or (not (eq b (current-buffer)))
+ (< (point) s)
+ (> (point) e))
+ ;;(message "Exit: %S %S %S" s e (point))
+ (semantic-complete-inline-exit)
+ )
+ ;; Exit if the user typed in a character that is not part
+ ;; of the symbol being completed.
+ ((and (setq txt (semantic-completion-text))
+ (not (string= txt ""))
+ (and (/= (point) s)
+ (save-excursion
+ (forward-char -1)
+ (not (looking-at "\\(\\w\\|\\s_\\)")))))
+ ;;(message "Non symbol character.")
+ (semantic-complete-inline-exit))
+ ((lookup-key semantic-complete-inline-map
+ (this-command-keys) nil)
+ ;; If the last command was one of our completion commands,
+ ;; then do nothing.
+ nil
+ )
+ (t
+ ;; Else, show completions now
+ (semantic-complete-inline-force-display)
+
+ ))))
+ ;; If something goes terribly wrong, clean up after ourselves.
+ (error (semantic-complete-inline-exit))))
+
+(defun semantic-complete-inline-force-display ()
+ "Force the display of whatever the current completions are.
+DO NOT CALL THIS IF THE INLINE COMPLETION ENGINE IS NOT ACTIVE."
+ (condition-case e
+ (save-excursion
+ (let ((collector semantic-completion-collector-engine)
+ (displayor semantic-completion-display-engine)
+ (contents (semantic-completion-text)))
+ (when collector
+ (semantic-collector-calculate-completions
+ collector contents nil)
+ (semantic-displayor-set-completions
+ displayor
+ (semantic-collector-all-completions collector contents)
+ contents)
+ ;; Ask the displayor to display them.
+ (semantic-displayor-show-request displayor))
+ ))
+ (error (message "Bug Showing Completions: %S" e))))
+
+(defun semantic-complete-inline-tag-engine
+ (collector displayor buffer start end)
+ "Perform completion based on semantic tags in a buffer.
+Argument COLLECTOR is an object which can be used to to calculate
+a list of possible hits. See `semantic-completion-collector-engine'
+for details on COLLECTOR.
+Argumeng DISPLAYOR is an object used to display a list of possible
+completions for a given prefix. See`semantic-completion-display-engine'
+for details on DISPLAYOR.
+BUFFER is the buffer in which completion will take place.
+START is a location for the start of the full symbol.
+If the symbol being completed is \"foo.ba\", then START
+is on the \"f\" character.
+END is at the end of the current symbol being completed."
+ ;; Set us up for doing completion
+ (setq semantic-completion-collector-engine collector
+ semantic-completion-display-engine displayor)
+ ;; Create an overlay
+ (setq semantic-complete-inline-overlay
+ (semantic-make-overlay start end buffer nil t))
+ (semantic-overlay-put semantic-complete-inline-overlay
+ 'face
+ 'semantic-complete-inline-face)
+ (semantic-overlay-put semantic-complete-inline-overlay
+ 'window-config-start
+ (current-window-configuration))
+ ;; Install our command hooks
+ (add-hook 'pre-command-hook 'semantic-complete-pre-command-hook)
+ (add-hook 'post-command-hook 'semantic-complete-post-command-hook)
+ ;; Go!
+ (semantic-complete-inline-force-display)
+ )
+
+;;; Inline Completion Keymap Functions
+;;
+(defun semantic-complete-inline-TAB ()
+ "Perform inline completion."
+ (interactive)
+ (let ((cmpl (semantic-complete-do-completion nil t)))
+ (cond
+ ((eq cmpl 'complete)
+ (semantic-complete-inline-force-display))
+ ((eq cmpl 'done)
+ (semantic-complete-inline-done))
+ ))
+ )
+
+(defun semantic-complete-inline-down()
+ "Focus forwards through the displayor."
+ (interactive)
+ (let ((displayor semantic-completion-display-engine))
+ (semantic-displayor-focus-next displayor)
+ (semantic-displayor-focus-request displayor)
+ ))
+
+(defun semantic-complete-inline-up ()
+ "Focus backwards through the displayor."
+ (interactive)
+ (let ((displayor semantic-completion-display-engine))
+ (semantic-displayor-focus-previous displayor)
+ (semantic-displayor-focus-request displayor)
+ ))
+
+
+;;; ------------------------------------------------------------
+;;; Interactions between collection and displaying
+;;
+;; Functional routines used to help collectors communicate with
+;; the current displayor, or for the previous section.
+
+(defun semantic-complete-next-action (partial)
+ "Determine what the next completion action should be.
+PARTIAL is non-nil if we are doing partial completion.
+First, the collector can determine if we should perform a completion or not.
+If there is nothing to complete, then the displayor determines if we are
+to show a completion list, scroll, or perhaps do a focus (if it is capable.)
+Expected return values are:
+ done -> We have a singular match
+ empty -> There are no matches to the current text
+ complete -> Perform a completion action
+ complete-whitespace -> Complete next whitespace type character.
+ display -> Show the list of completions
+ scroll -> The completions have been shown, and the user keeps hitting
+ the complete button. If possible, scroll the completions
+ focus -> The displayor knows how to shift focus among possible completions.
+ Let it do that.
+ displayend -> Whatever options the displayor had for repeating options, there
+ are none left. Try something new."
+ (let ((ans1 (semantic-collector-next-action
+ semantic-completion-collector-engine
+ partial))
+ (ans2 (semantic-displayor-next-action
+ semantic-completion-display-engine))
+ )
+ (cond
+ ;; No collector answer, use displayor answer.
+ ((not ans1)
+ ans2)
+ ;; Displayor selection of 'scroll, 'display, or 'focus trumps
+ ;; 'done
+ ((and (eq ans1 'done) ans2)
+ ans2)
+ ;; Use ans1 when we have it.
+ (t
+ ans1))))
+
+
+
+;;; ------------------------------------------------------------
+;;; Collection Engines
+;;
+;; Collection engines can scan tags from the current environment and
+;; provide lists of possible completions.
+;;
+;; General features of the abstract collector:
+;; * Cache completion lists between uses
+;; * Cache itself per buffer. Handle reparse hooks
+;;
+;; Key Interface Functions to implement:
+;; * semantic-collector-next-action
+;; * semantic-collector-calculate-completions
+;; * semantic-collector-try-completion
+;; * semantic-collector-all-completions
+
+(defvar semantic-collector-per-buffer-list nil
+ "List of collectors active in this buffer.")
+(make-variable-buffer-local 'semantic-collector-per-buffer-list)
+
+(defvar semantic-collector-list nil
+ "List of global collectors active this session.")
+
+(defclass semantic-collector-abstract ()
+ ((buffer :initarg :buffer
+ :type buffer
+ :documentation "Originating buffer for this collector.
+Some collectors use a given buffer as a starting place while looking up
+tags.")
+ (cache :initform nil
+ :type (or null semanticdb-find-result-with-nil)
+ :documentation "Cache of tags.
+These tags are re-used during a completion session.
+Sometimes these tags are cached between completion sessions.")
+ (last-all-completions :initarg nil
+ :type semanticdb-find-result-with-nil
+ :documentation "Last result of `all-completions'.
+This result can be used for refined completions as `last-prefix' gets
+closer to a specific result.")
+ (last-prefix :type string
+ :protection :protected
+ :documentation "The last queried prefix.
+This prefix can be used to cache intermediate completion offers.
+making the action of homing in on a token faster.")
+ (last-completion :type (or null string)
+ :documentation "The last calculated completion.
+This completion is calculated and saved for future use.")
+ (last-whitespace-completion :type (or null string)
+ :documentation "The last whitespace completion.
+For partial completion, SPC will disabiguate over whitespace type
+characters. This is the last calculated version.")
+ (current-exact-match :type list
+ :protection :protected
+ :documentation "The list of matched tags.
+When tokens are matched, they are added to this list.")
+ )
+ "Root class for completion engines.
+The baseclass provides basic functionality for interacting with
+a completion displayor object, and tracking the current progress
+of a completion."
+ :abstract t)
+
+(defmethod semantic-collector-cleanup ((obj semantic-collector-abstract))
+ "Clean up any mess this collector may have."
+ nil)
+
+(defmethod semantic-collector-next-action
+ ((obj semantic-collector-abstract) partial)
+ "What should we do next? OBJ can predict a next good action.
+PARTIAL indicates if we are doing a partial completion."
+ (if (and (slot-boundp obj 'last-completion)
+ (string= (semantic-completion-text) (oref obj last-completion)))
+ (let* ((cem (semantic-collector-current-exact-match obj))
+ (cemlen (semanticdb-find-result-length cem))
+ (cac (semantic-collector-all-completions
+ obj (semantic-completion-text)))
+ (caclen (semanticdb-find-result-length cac)))
+ (cond ((and cem (= cemlen 1)
+ cac (> caclen 1)
+ (eq last-command this-command))
+ ;; Defer to the displayor...
+ nil)
+ ((and cem (= cemlen 1))
+ 'done)
+ ((and (not cem) (not cac))
+ 'empty)
+ ((and partial (semantic-collector-try-completion-whitespace
+ obj (semantic-completion-text)))
+ 'complete-whitespace)))
+ 'complete))
+
+(defmethod semantic-collector-last-prefix= ((obj semantic-collector-abstract)
+ last-prefix)
+ "Return non-nil if OBJ's prefix matches PREFIX."
+ (and (slot-boundp obj 'last-prefix)
+ (string= (oref obj last-prefix) last-prefix)))
+
+(defmethod semantic-collector-get-cache ((obj semantic-collector-abstract))
+ "Get the raw cache of tags for completion.
+Calculate the cache if there isn't one."
+ (or (oref obj cache)
+ (semantic-collector-calculate-cache obj)))
+
+(defmethod semantic-collector-calculate-completions-raw
+ ((obj semantic-collector-abstract) prefix completionlist)
+ "Calculate the completions for prefix from completionlist.
+Output must be in semanticdb Find result format."
+ ;; Must output in semanticdb format
+ (let ((table (save-excursion
+ (set-buffer (oref obj buffer))
+ semanticdb-current-table))
+ (result (semantic-find-tags-for-completion
+ prefix
+ ;; To do this kind of search with a pre-built completion
+ ;; list, we need to strip it first.
+ (semanticdb-strip-find-results completionlist)))
+ )
+ (if result
+ (list (cons table result)))))
+
+(defmethod semantic-collector-calculate-completions
+ ((obj semantic-collector-abstract) prefix partial)
+ "Calculate completions for prefix as setup for other queries."
+ (let* ((case-fold-search semantic-case-fold)
+ (same-prefix-p (semantic-collector-last-prefix= obj prefix))
+ (completionlist
+ (if (or same-prefix-p
+ (and (slot-boundp obj 'last-prefix)
+ (eq (compare-strings (oref obj last-prefix) 0 nil
+ prefix 0 (length prefix))
+ t)))
+ ;; New prefix is subset of old prefix
+ (oref obj last-all-completions)
+ (semantic-collector-get-cache obj)))
+ ;; Get the result
+ (answer (if same-prefix-p
+ completionlist
+ (semantic-collector-calculate-completions-raw
+ obj prefix completionlist))
+ )
+ (completion nil)
+ (complete-not-uniq nil)
+ )
+ ;;(semanticdb-find-result-test answer)
+ (when (not same-prefix-p)
+ ;; Save results if it is interesting and beneficial
+ (oset obj last-prefix prefix)
+ (oset obj last-all-completions answer))
+ ;; Now calculate the completion.
+ (setq completion (try-completion
+ prefix
+ (semanticdb-strip-find-results answer)))
+ (oset obj last-whitespace-completion nil)
+ (oset obj current-exact-match nil)
+ ;; Only do this if a completion was found. Letting a nil in
+ ;; could cause a full semanticdb search by accident.
+ (when completion
+ (oset obj last-completion
+ (cond
+ ;; Unique match in AC. Last completion is a match.
+ ;; Also set the current-exact-match.
+ ((eq completion t)
+ (oset obj current-exact-match answer)
+ prefix)
+ ;; It may be complete (a symbol) but still not unique.
+ ;; We can capture a match
+ ((setq complete-not-uniq
+ (semanticdb-find-tags-by-name
+ prefix
+ answer))
+ (oset obj current-exact-match
+ complete-not-uniq)
+ prefix
+ )
+ ;; Non unique match, return the string that handles
+ ;; completion
+ (t (or completion prefix))
+ )))
+ ))
+
+(defmethod semantic-collector-try-completion-whitespace
+ ((obj semantic-collector-abstract) prefix)
+ "For OBJ, do whatepsace completion based on PREFIX.
+This implies that if there are two completions, one matching
+the test \"preifx\\>\", and one not, the one matching the full
+word version of PREFIX will be chosen, and that text returned.
+This function requires that `semantic-collector-calculate-completions'
+has been run first."
+ (let* ((ac (semantic-collector-all-completions obj prefix))
+ (matchme (concat "^" prefix "\\>"))
+ (compare (semanticdb-find-tags-by-name-regexp matchme ac))
+ (numtag (semanticdb-find-result-length compare))
+ )
+ (if compare
+ (let* ((idx 0)
+ (cutlen (1+ (length prefix)))
+ (twws (semanticdb-find-result-nth compare idx)))
+ ;; Is our tag with whitespace a match that has whitespace
+ ;; after it, or just an already complete symbol?
+ (while (and (< idx numtag)
+ (< (length (semantic-tag-name (car twws))) cutlen))
+ (setq idx (1+ idx)
+ twws (semanticdb-find-result-nth compare idx)))
+ (when (and twws (car-safe twws))
+ ;; If COMPARE has succeeded, then we should take the very
+ ;; first match, and extend prefix by one character.
+ (oset obj last-whitespace-completion
+ (substring (semantic-tag-name (car twws))
+ 0 cutlen))))
+ )))
+
+
+(defmethod semantic-collector-current-exact-match ((obj
semantic-collector-abstract))
+ "Return the active valid MATCH from the semantic collector.
+For now, just return the first element from our list of available
+matches. For semanticdb based results, make sure the file is loaded
+into a buffer."
+ (when (slot-boundp obj 'current-exact-match)
+ (oref obj current-exact-match)))
+
+(defmethod semantic-collector-current-whitespace-completion ((obj
semantic-collector-abstract))
+ "Return the active whitespace completion value."
+ (when (slot-boundp obj 'last-whitespace-completion)
+ (oref obj last-whitespace-completion)))
+
+(defmethod semantic-collector-get-match ((obj semantic-collector-abstract))
+ "Return the active valid MATCH from the semantic collector.
+For now, just return the first element from our list of available
+matches. For semanticdb based results, make sure the file is loaded
+into a buffer."
+ (when (slot-boundp obj 'current-exact-match)
+ (semanticdb-find-result-nth-in-buffer (oref obj current-exact-match) 0)))
+
+(defmethod semantic-collector-all-completions
+ ((obj semantic-collector-abstract) prefix)
+ "For OBJ, retrieve all completions matching PREFIX.
+The returned list consists of all the tags currently
+matching PREFIX."
+ (when (slot-boundp obj 'last-all-completions)
+ (oref obj last-all-completions)))
+
+(defmethod semantic-collector-try-completion
+ ((obj semantic-collector-abstract) prefix)
+ "For OBJ, attempt to match PREFIX.
+See `try-completion' for details on how this works.
+Return nil for no match.
+Return a string for a partial match.
+For a unique match of PREFIX, return the list of all tags
+with that name."
+ (if (slot-boundp obj 'last-completion)
+ (oref obj last-completion)))
+
+(defmethod semantic-collector-calculate-cache
+ ((obj semantic-collector-abstract))
+ "Calculate the completion cache for OBJ."
+ nil
+ )
+
+(defmethod semantic-collector-flush ((this semantic-collector-abstract))
+ "Flush THIS collector object, clearing any caches and prefix."
+ (oset this cache nil)
+ (slot-makeunbound this 'last-prefix)
+ (slot-makeunbound this 'last-completion)
+ (slot-makeunbound this 'last-all-completions)
+ (slot-makeunbound this 'current-exact-match)
+ )
+
+;;; PER BUFFER
+;;
+(defclass semantic-collector-buffer-abstract (semantic-collector-abstract)
+ ()
+ "Root class for per-buffer completion engines.
+These collectors track themselves on a per-buffer basis."
+ :abstract t)
+
+(defmethod constructor :STATIC ((this semantic-collector-buffer-abstract)
+ newname &rest fields)
+ "Reuse previously created objects of this type in buffer."
+ (let ((old nil)
+ (bl semantic-collector-per-buffer-list))
+ (while (and bl (null old))
+ (if (eq (object-class (car bl)) this)
+ (setq old (car bl))))
+ (unless old
+ (let ((new (call-next-method)))
+ (add-to-list 'semantic-collector-per-buffer-list new)
+ (setq old new)))
+ (slot-makeunbound old 'last-completion)
+ (slot-makeunbound old 'last-prefix)
+ (slot-makeunbound old 'current-exact-match)
+ old))
+
+;; Buffer specific collectors should flush themselves
+(defun semantic-collector-buffer-flush (newcache)
+ "Flush all buffer collector objects.
+NEWCACHE is the new tag table, but we ignore it."
+ (condition-case nil
+ (let ((l semantic-collector-per-buffer-list))
+ (while l
+ (if (car l) (semantic-collector-flush (car l)))
+ (setq l (cdr l))))
+ (error nil)))
+
+(add-hook 'semantic-after-toplevel-cache-change-hook
+ 'semantic-collector-buffer-flush)
+
+;;; DEEP BUFFER SPECIFIC COMPLETION
+;;
+(defclass semantic-collector-buffer-deep
+ (semantic-collector-buffer-abstract)
+ ()
+ "Completion engine for tags in the current buffer.
+When searching for a tag, uses semantic deep searche functions.
+Basics search only in the current buffer.")
+
+(defmethod semantic-collector-calculate-cache
+ ((obj semantic-collector-buffer-deep))
+ "Calculate the completion cache for OBJ.
+Uses `semantic-flatten-tags-table'"
+ (oset obj cache
+ ;; Must create it in SEMANTICDB find format.
+ ;; ( ( DBTABLE TAG TAG ... ) ... )
+ (list
+ (cons semanticdb-current-table
+ (semantic-flatten-tags-table (oref obj buffer))))))
+
+;;; PROJECT SPECIFIC COMPLETION
+;;
+(defclass semantic-collector-project-abstract (semantic-collector-abstract)
+ ((path :initarg :path
+ :initform nil
+ :documentation "List of database tables to search.
+At creation time, it can be anything accepted by
+`semanticdb-find-translate-path' as a PATH argument.")
+ )
+ "Root class for project wide completion engines.
+Uses semanticdb for searching all tags in the current project."
+ :abstract t)
+
+;;; Project Search
+(defclass semantic-collector-project (semantic-collector-project-abstract)
+ ()
+ "Completion engine for tags in a project.")
+
+
+(defmethod semantic-collector-calculate-completions-raw
+ ((obj semantic-collector-project) prefix completionlist)
+ "Calculate the completions for prefix from completionlist."
+ (semanticdb-find-tags-for-completion prefix (oref obj path)))
+
+;;; Brutish Project search
+(defclass semantic-collector-project-brutish
(semantic-collector-project-abstract)
+ ()
+ "Completion engine for tags in a project.")
+
+(declare-function semanticdb-brute-deep-find-tags-for-completion
+ "semantic/db-find")
+
+(defmethod semantic-collector-calculate-completions-raw
+ ((obj semantic-collector-project-brutish) prefix completionlist)
+ "Calculate the completions for prefix from completionlist."
+ (require 'semantic/db-find)
+ (semanticdb-brute-deep-find-tags-for-completion prefix (oref obj path)))
+
+(defclass semantic-collector-analyze-completions (semantic-collector-abstract)
+ ((context :initarg :context
+ :type semantic-analyze-context
+ :documentation "An analysis context.
+Specifies some context location from whence completion lists will be drawn."
+ )
+ (first-pass-completions :type list
+ :documentation "List of valid completion tags.
+This list of tags is generated when completion starts. All searches
+derive from this list.")
+ )
+ "Completion engine that uses the context analyzer to provide options.
+The only options available for completion are those which can be logically
+inserted into the current context.")
+
+(defmethod semantic-collector-calculate-completions-raw
+ ((obj semantic-collector-analyze-completions) prefix completionlist)
+ "calculate the completions for prefix from completionlist."
+ ;; if there are no completions yet, calculate them.
+ (if (not (slot-boundp obj 'first-pass-completions))
+ (oset obj first-pass-completions
+ (semantic-analyze-possible-completions (oref obj context))))
+ ;; search our cached completion list. make it look like a semanticdb
+ ;; results type.
+ (list (cons (save-excursion
+ (set-buffer (oref (oref obj context) buffer))
+ semanticdb-current-table)
+ (semantic-find-tags-for-completion
+ prefix
+ (oref obj first-pass-completions)))))
+
+
+;;; ------------------------------------------------------------
+;;; Tag List Display Engines
+;;
+;; A typical displayor accepts a pre-determined list of completions
+;; generated by a collector. This format is in semanticdb search
+;; form. This vaguely standard form is a bit challenging to navigate
+;; because the tags do not contain buffer info, but the file assocated
+;; with the tags preceed the tag in the list.
+;;
+;; Basic displayors don't care, and can strip the results.
+;; Advanced highlighting displayors need to know when they need
+;; to load a file so that the tag in question can be highlighted.
+;;
+;; Key interface methods to a displayor are:
+;; * semantic-displayor-next-action
+;; * semantic-displayor-set-completions
+;; * semantic-displayor-current-focus
+;; * semantic-displayor-show-request
+;; * semantic-displayor-scroll-request
+;; * semantic-displayor-focus-request
+
+(defclass semantic-displayor-abstract ()
+ ((table :type (or null semanticdb-find-result-with-nil)
+ :initform nil
+ :protection :protected
+ :documentation "List of tags this displayor is showing.")
+ (last-prefix :type string
+ :protection :protected
+ :documentation "Prefix associated with slot `table'")
+ )
+ "Abstract displayor baseclass.
+Manages the display of some number of tags.
+Provides the basics for a displayor, including interacting with
+a collector, and tracking tables of completion to display."
+ :abstract t)
+
+(defmethod semantic-displayor-cleanup ((obj semantic-displayor-abstract))
+ "Clean up any mess this displayor may have."
+ nil)
+
+(defmethod semantic-displayor-next-action ((obj semantic-displayor-abstract))
+ "The next action to take on the minibuffer related to display."
+ (if (and (slot-boundp obj 'last-prefix)
+ (string= (oref obj last-prefix) (semantic-completion-text))
+ (eq last-command this-command))
+ 'scroll
+ 'display))
+
+(defmethod semantic-displayor-set-completions ((obj
semantic-displayor-abstract)
+ table prefix)
+ "Set the list of tags to be completed over to TABLE."
+ (oset obj table table)
+ (oset obj last-prefix prefix))
+
+(defmethod semantic-displayor-show-request ((obj semantic-displayor-abstract))
+ "A request to show the current tags table."
+ (ding))
+
+(defmethod semantic-displayor-focus-request ((obj semantic-displayor-abstract))
+ "A request to for the displayor to focus on some tag option."
+ (ding))
+
+(defmethod semantic-displayor-scroll-request ((obj
semantic-displayor-abstract))
+ "A request to for the displayor to scroll the completion list (if needed)."
+ (scroll-other-window))
+
+(defmethod semantic-displayor-focus-previous ((obj
semantic-displayor-abstract))
+ "Set the current focus to the previous item."
+ nil)
+
+(defmethod semantic-displayor-focus-next ((obj semantic-displayor-abstract))
+ "Set the current focus to the next item."
+ nil)
+
+(defmethod semantic-displayor-current-focus ((obj semantic-displayor-abstract))
+ "Return a single tag currently in focus.
+This object type doesn't do focus, so will never have a focus object."
+ nil)
+
+;; Traditional displayor
+(defcustom semantic-completion-displayor-format-tag-function
+ #'semantic-format-tag-name
+ "*A Tag format function to use when showing completions."
+ :group 'semantic
+ :type semantic-format-tag-custom-list)
+
+(defclass semantic-displayor-traditional (semantic-displayor-abstract)
+ ()
+ "Display options in *Completions* buffer.
+Traditional display mechanism for a list of possible completions.
+Completions are showin in a new buffer and listed with the ability
+to click on the items to aid in completion.")
+
+(defmethod semantic-displayor-show-request ((obj
semantic-displayor-traditional))
+ "A request to show the current tags table."
+
+ ;; NOTE TO SELF. Find the character to type next, and emphesize it.
+
+ (with-output-to-temp-buffer "*Completions*"
+ (display-completion-list
+ (mapcar semantic-completion-displayor-format-tag-function
+ (semanticdb-strip-find-results (oref obj table))))
+ )
+ )
+
+;;; Abstract baseclass for any displayor which supports focus
+(defclass semantic-displayor-focus-abstract (semantic-displayor-abstract)
+ ((focus :type number
+ :protection :protected
+ :documentation "A tag index from `table' which has focus.
+Multiple calls to the display function can choose to focus on a
+given tag, by highlighting its location.")
+ (find-file-focus
+ :allocation :class
+ :initform nil
+ :documentation
+ "Non-nil if focusing requires a tag's buffer be in memory.")
+ )
+ "Abstract displayor supporting `focus'.
+A displayor which has the ability to focus in on one tag.
+Focusing is a way of differentiationg between multiple tags
+which have the same name."
+ :abstract t)
+
+(defmethod semantic-displayor-next-action ((obj
semantic-displayor-focus-abstract))
+ "The next action to take on the minibuffer related to display."
+ (if (and (slot-boundp obj 'last-prefix)
+ (string= (oref obj last-prefix) (semantic-completion-text))
+ (eq last-command this-command))
+ (if (and
+ (slot-boundp obj 'focus)
+ (slot-boundp obj 'table)
+ (<= (semanticdb-find-result-length (oref obj table))
+ (1+ (oref obj focus))))
+ ;; We are at the end of the focus road.
+ 'displayend
+ ;; Focus on some item.
+ 'focus)
+ 'display))
+
+(defmethod semantic-displayor-set-completions ((obj
semantic-displayor-focus-abstract)
+ table prefix)
+ "Set the list of tags to be completed over to TABLE."
+ (call-next-method)
+ (slot-makeunbound obj 'focus))
+
+(defmethod semantic-displayor-focus-previous ((obj
semantic-displayor-focus-abstract))
+ "Set the current focus to the previous item.
+Not meaningful return value."
+ (when (and (slot-boundp obj 'table) (oref obj table))
+ (with-slots (table) obj
+ (if (or (not (slot-boundp obj 'focus))
+ (<= (oref obj focus) 0))
+ (oset obj focus (1- (semanticdb-find-result-length table)))
+ (oset obj focus (1- (oref obj focus)))
+ )
+ )))
+
+(defmethod semantic-displayor-focus-next ((obj
semantic-displayor-focus-abstract))
+ "Set the current focus to the next item.
+Not meaningful return value."
+ (when (and (slot-boundp obj 'table) (oref obj table))
+ (with-slots (table) obj
+ (if (not (slot-boundp obj 'focus))
+ (oset obj focus 0)
+ (oset obj focus (1+ (oref obj focus)))
+ )
+ (if (<= (semanticdb-find-result-length table) (oref obj focus))
+ (oset obj focus 0))
+ )))
+
+(defmethod semantic-displayor-focus-tag ((obj
semantic-displayor-focus-abstract))
+ "Return the next tag OBJ should focus on."
+ (when (and (slot-boundp obj 'table) (oref obj table))
+ (with-slots (table) obj
+ (semanticdb-find-result-nth table (oref obj focus)))))
+
+(defmethod semantic-displayor-current-focus ((obj
semantic-displayor-focus-abstract))
+ "Return the tag currently in focus, or call parent method."
+ (if (and (slot-boundp obj 'focus)
+ (slot-boundp obj 'table)
+ ;; Only return the current focus IFF the minibuffer reflects
+ ;; the list this focus was derived from.
+ (slot-boundp obj 'last-prefix)
+ (string= (semantic-completion-text) (oref obj last-prefix))
+ )
+ ;; We need to focus
+ (if (oref obj find-file-focus)
+ (semanticdb-find-result-nth-in-buffer (oref obj table) (oref obj
focus))
+ ;; result-nth returns a cons with car being the tag, and cdr the
+ ;; database.
+ (car (semanticdb-find-result-nth (oref obj table) (oref obj focus))))
+ ;; Do whatever
+ (call-next-method)))
+
+;;; Simple displayor which performs traditional display completion,
+;; and also focuses with highlighting.
+(defclass semantic-displayor-traditional-with-focus-highlight
+ (semantic-displayor-focus-abstract semantic-displayor-traditional)
+ ((find-file-focus :initform t))
+ "Display completions in *Completions* buffer, with focus highlight.
+A traditional displayor which can focus on a tag by showing it.
+Same as `semantic-displayor-traditional', but with selection between
+multiple tags with the same name done by 'focusing' on the source
+location of the different tags to differentiate them.")
+
+(defmethod semantic-displayor-focus-request
+ ((obj semantic-displayor-traditional-with-focus-highlight))
+ "Focus in on possible tag completions.
+Focus is performed by cycling through the tags and highlighting
+one in the source buffer."
+ (let* ((tablelength (semanticdb-find-result-length (oref obj table)))
+ (focus (semantic-displayor-focus-tag obj))
+ ;; Raw tag info.
+ (rtag (car focus))
+ (rtable (cdr focus))
+ ;; Normalize
+ (nt (semanticdb-normalize-one-tag rtable rtag))
+ (tag (cdr nt))
+ (table (car nt))
+ )
+ ;; If we fail to normalize, resete.
+ (when (not tag) (setq table rtable tag rtag))
+ ;; Do the focus.
+ (let ((buf (or (semantic-tag-buffer tag)
+ (and table (semanticdb-get-buffer table)))))
+ ;; If no buffer is provided, then we can make up a summary buffer.
+ (when (not buf)
+ (save-excursion
+ (set-buffer (get-buffer-create "*Completion Focus*"))
+ (erase-buffer)
+ (insert "Focus on tag: \n")
+ (insert (semantic-format-tag-summarize tag nil t) "\n\n")
+ (when table
+ (insert "From table: \n")
+ (insert (object-name table) "\n\n"))
+ (when buf
+ (insert "In buffer: \n\n")
+ (insert (format "%S" buf)))
+ (setq buf (current-buffer))))
+ ;; Show the tag in the buffer.
+ (if (get-buffer-window buf)
+ (select-window (get-buffer-window buf))
+ (switch-to-buffer-other-window buf t)
+ (select-window (get-buffer-window buf)))
+ ;; Now do some positioning
+ (unwind-protect
+ (if (semantic-tag-with-position-p tag)
+ ;; Full tag positional information available
+ (progn
+ (goto-char (semantic-tag-start tag))
+ ;; This avoids a dangerous problem if we just loaded a tag
+ ;; from a file, but the original position was not updated
+ ;; in the TAG variable we are currently using.
+ (semantic-momentary-highlight-tag (semantic-current-tag))
+ ))
+ (select-window (minibuffer-window)))
+ ;; Calculate text difference between contents and the focus item.
+ (let* ((mbc (semantic-completion-text))
+ (ftn (semantic-tag-name tag))
+ (diff (substring ftn (length mbc))))
+ (semantic-completion-message
+ (format "%s [%d of %d matches]" diff (1+ (oref obj focus))
tablelength)))
+ )))
+
+
+;;; Tooltip completion lister
+;;
+;; Written and contributed by Masatake YAMATO <address@hidden>
+;;
+;; 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 <address@hidden>
+
+
+;;; Ghost Text displayor
+;;
+(defclass semantic-displayor-ghost (semantic-displayor-focus-abstract)
+
+ ((ghostoverlay :type overlay
+ :documentation
+ "The overlay the ghost text is displayed in.")
+ (first-show :initform t
+ :documentation
+ "Non nil if we have not seen our first show request.")
+ )
+ "Cycle completions inline with ghost text.
+Completion displayor using ghost chars after point for focus options.
+Whichever completion is currently in focus will be displayed as ghost
+text using overlay options.")
+
+(defmethod semantic-displayor-next-action ((obj semantic-displayor-ghost))
+ "The next action to take on the inline completion related to display."
+ (let ((ans (call-next-method))
+ (table (when (slot-boundp obj 'table)
+ (oref obj table))))
+ (if (and (eq ans 'displayend)
+ table
+ (= (semanticdb-find-result-length table) 1)
+ )
+ nil
+ ans)))
+
+(defmethod semantic-displayor-cleanup ((obj semantic-displayor-ghost))
+ "Clean up any mess this displayor may have."
+ (when (slot-boundp obj 'ghostoverlay)
+ (semantic-overlay-delete (oref obj ghostoverlay)))
+ )
+
+(defmethod semantic-displayor-set-completions ((obj semantic-displayor-ghost)
+ table prefix)
+ "Set the list of tags to be completed over to TABLE."
+ (call-next-method)
+
+ (semantic-displayor-cleanup obj)
+ )
+
+
+(defmethod semantic-displayor-show-request ((obj semantic-displayor-ghost))
+ "A request to show the current tags table."
+; (if (oref obj first-show)
+; (progn
+; (oset obj first-show nil)
+ (semantic-displayor-focus-next obj)
+ (semantic-displayor-focus-request obj)
+; )
+ ;; Only do the traditional thing if the first show request
+ ;; has been seen. Use the first one to start doing the ghost
+ ;; text display.
+; (call-next-method)
+; )
+)
+
+(defmethod semantic-displayor-focus-request
+ ((obj semantic-displayor-ghost))
+ "Focus in on possible tag completions.
+Focus is performed by cycling through the tags and showing a possible
+completion text in ghost text."
+ (let* ((tablelength (semanticdb-find-result-length (oref obj table)))
+ (focus (semantic-displayor-focus-tag obj))
+ (tag (car focus))
+ )
+ (if (not tag)
+ (semantic-completion-message "No tags to focus on.")
+ ;; Display the focus completion as ghost text after the current
+ ;; inline text.
+ (when (or (not (slot-boundp obj 'ghostoverlay))
+ (not (semantic-overlay-live-p (oref obj ghostoverlay))))
+ (oset obj ghostoverlay
+ (semantic-make-overlay (point) (1+ (point)) (current-buffer) t)))
+
+ (let* ((lp (semantic-completion-text))
+ (os (substring (semantic-tag-name tag) (length lp)))
+ (ol (oref obj ghostoverlay))
+ )
+
+ (put-text-property 0 (length os) 'face 'region os)
+
+ (semantic-overlay-put
+ ol 'display (concat os (buffer-substring (point) (1+ (point)))))
+ )
+ ;; Calculate text difference between contents and the focus item.
+ (let* ((mbc (semantic-completion-text))
+ (ftn (concat (semantic-tag-name tag)))
+ )
+ (put-text-property (length mbc) (length ftn) 'face
+ 'bold ftn)
+ (semantic-completion-message
+ (format "%s [%d of %d matches]" ftn (1+ (oref obj focus))
tablelength)))
+ )))
+
+
+;;; ------------------------------------------------------------
+;;; Specific queries
+;;
+(defvar semantic-complete-inline-custom-type
+ (append '(radio)
+ (mapcar
+ (lambda (class)
+ (let* ((C (intern (car class)))
+ (doc (documentation-property C 'variable-documentation))
+ (doc1 (car (split-string doc "\n")))
+ )
+ (list 'const
+ :tag doc1
+ C)))
+ (eieio-build-class-alist semantic-displayor-abstract t))
+ )
+ "Possible options for inlince completion displayors.
+Use this to enable custom editing.")
+
+(defcustom semantic-complete-inline-analyzer-displayor-class
+ 'semantic-displayor-traditional
+ "*Class for displayor to use with inline completion."
+ :group 'semantic
+ :type semantic-complete-inline-custom-type
+ )
+
+(defun semantic-complete-read-tag-buffer-deep (prompt &optional
+ default-tag
+ initial-input
+ history)
+ "Ask for a tag by name from the current buffer.
+Available tags are from the current buffer, at any level.
+Completion options are presented in a traditional way, with highlighting
+to resolve same-name collisions.
+PROMPT is a string to prompt with.
+DEFAULT-TAG is a semantic tag or string to use as the default value.
+If INITIAL-INPUT is non-nil, insert it in the minibuffer initially.
+HISTORY is a symbol representing a variable to store the history in."
+ (semantic-complete-read-tag-engine
+ (semantic-collector-buffer-deep prompt :buffer (current-buffer))
+ (semantic-displayor-traditional-with-focus-highlight "simple")
+ ;;(semantic-displayor-tooltip "simple")
+ prompt
+ default-tag
+ initial-input
+ history)
+ )
+
+(defun semantic-complete-read-tag-project (prompt &optional
+ default-tag
+ initial-input
+ history)
+ "Ask for a tag by name from the current project.
+Available tags are from the current project, at the top level.
+Completion options are presented in a traditional way, with highlighting
+to resolve same-name collisions.
+PROMPT is a string to prompt with.
+DEFAULT-TAG is a semantic tag or string to use as the default value.
+If INITIAL-INPUT is non-nil, insert it in the minibuffer initially.
+HISTORY is a symbol representing a variable to store the history in."
+ (semantic-complete-read-tag-engine
+ (semantic-collector-project-brutish prompt
+ :buffer (current-buffer)
+ :path (current-buffer)
+ )
+ (semantic-displayor-traditional-with-focus-highlight "simple")
+ prompt
+ default-tag
+ initial-input
+ history)
+ )
+
+(defun semantic-complete-inline-tag-project ()
+ "Complete a symbol name by name from within the current project.
+This is similar to `semantic-complete-read-tag-project', except
+that the completion interaction is in the buffer where the context
+was calculated from.
+Customize `semantic-complete-inline-analyzer-displayor-class'
+to control how completion options are displayed.
+See `semantic-complete-inline-tag-engine' for details on how
+completion works."
+ (let* ((collector (semantic-collector-project-brutish
+ "inline"
+ :buffer (current-buffer)
+ :path (current-buffer)))
+ (sbounds (semantic-ctxt-current-symbol-and-bounds))
+ (syms (car sbounds))
+ (start (car (nth 2 sbounds)))
+ (end (cdr (nth 2 sbounds)))
+ (rsym (reverse syms))
+ (thissym (nth 1 sbounds))
+ (nextsym (car-safe (cdr rsym)))
+ (complst nil))
+ (when (and thissym (or (not (string= thissym ""))
+ nextsym))
+ ;; Do a quick calcuation of completions.
+ (semantic-collector-calculate-completions
+ collector thissym nil)
+ ;; Get the master list
+ (setq complst (semanticdb-strip-find-results
+ (semantic-collector-all-completions collector thissym)))
+ ;; Shorten by name
+ (setq complst (semantic-unique-tag-table-by-name complst))
+ (if (or (and (= (length complst) 1)
+ ;; Check to see if it is the same as what is there.
+ ;; if so, we can offer to complete.
+ (let ((compname (semantic-tag-name (car complst))))
+ (not (string= compname thissym))))
+ (> (length complst) 1))
+ ;; There are several options. Do the completion.
+ (semantic-complete-inline-tag-engine
+ collector
+ (funcall semantic-complete-inline-analyzer-displayor-class
+ "inline displayor")
+ ;;(semantic-displayor-tooltip "simple")
+ (current-buffer)
+ start end))
+ )))
+
+(defun semantic-complete-read-tag-analyzer (prompt &optional
+ context
+ history)
+ "Ask for a tag by name based on the current context.
+The function `semantic-analyze-current-context' is used to
+calculate the context. `semantic-analyze-possible-completions' is used
+to generate the list of possible completions.
+PROMPT is the first part of the prompt. Additional prompt
+is added based on the contexts full prefix.
+CONTEXT is the semantic analyzer context to start with.
+HISTORY is a symbol representing a variable to stor the history in.
+usually a default-tag and initial-input are available for completion
+prompts. these are calculated from the CONTEXT variable passed in."
+ (if (not context) (setq context (semantic-analyze-current-context (point))))
+ (let* ((syms (semantic-ctxt-current-symbol (point)))
+ (inp (car (reverse syms))))
+ (setq syms (nreverse (cdr (nreverse syms))))
+ (semantic-complete-read-tag-engine
+ (semantic-collector-analyze-completions
+ prompt
+ :buffer (oref context buffer)
+ :context context)
+ (semantic-displayor-traditional-with-focus-highlight "simple")
+ (save-excursion
+ (set-buffer (oref context buffer))
+ (goto-char (cdr (oref context bounds)))
+ (concat prompt (mapconcat 'identity syms ".")
+ (if syms "." "")
+ ))
+ nil
+ inp
+ history)))
+
+(defun semantic-complete-inline-analyzer (context)
+ "Complete a symbol name by name based on the current context.
+This is similar to `semantic-complete-read-tag-analyze', except
+that the completion interaction is in the buffer where the context
+was calculated from.
+CONTEXT is the semantic analyzer context to start with.
+Customize `semantic-complete-inline-analyzer-displayor-class'
+to control how completion options are displayed.
+
+See `semantic-complete-inline-tag-engine' for details on how
+completion works."
+ (if (not context) (setq context (semantic-analyze-current-context (point))))
+ (if (not context) (error "Nothing to complete on here"))
+ (let* ((collector (semantic-collector-analyze-completions
+ "inline"
+ :buffer (oref context buffer)
+ :context context))
+ (syms (semantic-ctxt-current-symbol (point)))
+ (rsym (reverse syms))
+ (thissym (car rsym))
+ (nextsym (car-safe (cdr rsym)))
+ (complst nil))
+ (when (and thissym (or (not (string= thissym ""))
+ nextsym))
+ ;; Do a quick calcuation of completions.
+ (semantic-collector-calculate-completions
+ collector thissym nil)
+ ;; Get the master list
+ (setq complst (semanticdb-strip-find-results
+ (semantic-collector-all-completions collector thissym)))
+ ;; Shorten by name
+ (setq complst (semantic-unique-tag-table-by-name complst))
+ (if (or (and (= (length complst) 1)
+ ;; Check to see if it is the same as what is there.
+ ;; if so, we can offer to complete.
+ (let ((compname (semantic-tag-name (car complst))))
+ (not (string= compname thissym))))
+ (> (length complst) 1))
+ ;; There are several options. Do the completion.
+ (semantic-complete-inline-tag-engine
+ collector
+ (funcall semantic-complete-inline-analyzer-displayor-class
+ "inline displayor")
+ ;;(semantic-displayor-tooltip "simple")
+ (oref context buffer)
+ (car (oref context bounds))
+ (cdr (oref context bounds))
+ ))
+ )))
+
+(defcustom semantic-complete-inline-analyzer-idle-displayor-class
+ 'semantic-displayor-ghost
+ "*Class for displayor to use with inline completion at idle time."
+ :group 'semantic
+ :type semantic-complete-inline-custom-type
+ )
+
+(defun semantic-complete-inline-analyzer-idle (context)
+ "Complete a symbol name by name based on the current context for idle time.
+CONTEXT is the semantic analyzer context to start with.
+This function is used from `semantic-idle-completions-mode'.
+
+This is the same as `semantic-complete-inline-analyzer', except that
+it uses `semantic-complete-inline-analyzer-idle-displayor-class'
+to control how completions are displayed.
+
+See `semantic-complete-inline-tag-engine' for details on how
+completion works."
+ (let ((semantic-complete-inline-analyzer-displayor-class
+ semantic-complete-inline-analyzer-idle-displayor-class))
+ (semantic-complete-inline-analyzer context)
+ ))
+
+
+;;;###autoload
+(defun semantic-complete-jump-local ()
+ "Jump to a semantic symbol."
+ (interactive)
+ (let ((tag (semantic-complete-read-tag-buffer-deep "Symbol: ")))
+ (when (semantic-tag-p tag)
+ (push-mark)
+ (goto-char (semantic-tag-start tag))
+ (semantic-momentary-highlight-tag tag)
+ (message "%S: %s "
+ (semantic-tag-class tag)
+ (semantic-tag-name tag)))))
+
+;;;###autoload
+(defun semantic-complete-jump ()
+ "Jump to a semantic symbol."
+ (interactive)
+ (let* ((tag (semantic-complete-read-tag-project "Symbol: ")))
+ (when (semantic-tag-p tag)
+ (push-mark)
+ (semantic-go-to-tag tag)
+ (switch-to-buffer (current-buffer))
+ (semantic-momentary-highlight-tag tag)
+ (message "%S: %s "
+ (semantic-tag-class tag)
+ (semantic-tag-name tag)))))
+
+;;;###autoload
+(defun semantic-complete-analyze-and-replace ()
+ "Perform prompt completion to do in buffer completion.
+`semantic-analyze-possible-completions' is used to determine the
+possible values.
+The minibuffer is used to perform the completion.
+The result is inserted as a replacement of the text that was there."
+ (interactive)
+ (let* ((c (semantic-analyze-current-context (point)))
+ (tag (save-excursion (semantic-complete-read-tag-analyzer "" c))))
+ ;; Take tag, and replace context bound with its name.
+ (goto-char (car (oref c bounds)))
+ (delete-region (point) (cdr (oref c bounds)))
+ (insert (semantic-tag-name tag))
+ (message "%S" (semantic-format-tag-summarize tag))))
+
+;;;###autoload
+(defun semantic-complete-analyze-inline ()
+ "Perform prompt completion to do in buffer completion.
+`semantic-analyze-possible-completions' is used to determine the
+possible values.
+The function returns immediately, leaving the buffer in a mode that
+will perform the completion.
+Configure `semantic-complete-inline-analyzer-displayor-class' to change
+how completion options are displayed."
+ (interactive)
+ ;; Only do this if we are not already completing something.
+ (if (not (semantic-completion-inline-active-p))
+ (semantic-complete-inline-analyzer
+ (semantic-analyze-current-context (point))))
+ ;; Report a message if things didn't startup.
+ (if (and (interactive-p)
+ (not (semantic-completion-inline-active-p)))
+ (message "Inline completion not needed.")
+ ;; Since this is most likely bound to something, and not used
+ ;; at idle time, throw in a TAB for good measure.
+ (semantic-complete-inline-TAB)
+ ))
+
+;;;###autoload
+(defun semantic-complete-analyze-inline-idle ()
+ "Perform prompt completion to do in buffer completion.
+`semantic-analyze-possible-completions' is used to determine the
+possible values.
+The function returns immediately, leaving the buffer in a mode that
+will perform the completion.
+Configure `semantic-complete-inline-analyzer-idle-displayor-class'
+to change how completion options are displayed."
+ (interactive)
+ ;; Only do this if we are not already completing something.
+ (if (not (semantic-completion-inline-active-p))
+ (semantic-complete-inline-analyzer-idle
+ (semantic-analyze-current-context (point))))
+ ;; Report a message if things didn't startup.
+ (if (and (interactive-p)
+ (not (semantic-completion-inline-active-p)))
+ (message "Inline completion not needed."))
+ )
+
+;;;###autoload
+(defun semantic-complete-self-insert (arg)
+ "Like `self-insert-command', but does completion afterwards.
+ARG is passed to `self-insert-command'. If ARG is nil,
+use `semantic-complete-analyze-inline' to complete."
+ (interactive "p")
+ ;; If we are already in a completion scenario, exit now, and then start over.
+ (semantic-complete-inline-exit)
+
+ ;; Insert the key
+ (self-insert-command arg)
+
+ ;; Prepare for doing completion, but exit quickly if there is keyboard
+ ;; input.
+ (when (and (not (semantic-exit-on-input 'csi
+ (semantic-fetch-tags)
+ (semantic-throw-on-input 'csi)
+ nil))
+ (= arg 1)
+ (not (semantic-exit-on-input 'csi
+ (semantic-analyze-current-context)
+ (semantic-throw-on-input 'csi)
+ nil)))
+ (condition-case nil
+ (semantic-complete-analyze-inline)
+ ;; Ignore errors. Seems likely that we'll get some once in a while.
+ (error nil))
+ ))
+
+(provide 'semantic/complete)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/complete"
+;; End:
+
+;;; semantic/complete.el ends here
Index: cedet/semantic/ctxt.el
===================================================================
RCS file: cedet/semantic/ctxt.el
diff -N cedet/semantic/ctxt.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/ctxt.el 28 Sep 2009 15:15:07 -0000 1.2
@@ -0,0 +1,621 @@
+;;; semantic/ctxt.el --- Context calculations for Semantic tools.
+
+;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+;;; 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Semantic, as a tool, provides a nice list of searchable tags.
+;; That information can provide some very accurate answers if the current
+;; context of a position is known.
+;;
+;; This library provides the hooks needed for a language to specify how
+;; the current context is calculated.
+;;
+(require 'semantic)
+
+;;; Code:
+(defvar semantic-command-separation-character
+ ";"
+ "String which indicates the end of a command.
+Used for identifying the end of a single command.")
+(make-variable-buffer-local 'semantic-command-separation-character)
+
+(defvar semantic-function-argument-separation-character
+ ","
+ "String which indicates the end of an argument.
+Used for identifying arguments to functions.")
+(make-variable-buffer-local 'semantic-function-argument-separation-character)
+
+;;; Local Contexts
+;;
+;; These context are nested blocks of code, such as code in an
+;; if clause
+(declare-function semantic-current-tag-of-class "semantic/find")
+
+(define-overloadable-function semantic-up-context (&optional point bounds-type)
+ "Move point up one context from POINT.
+Return non-nil if there are no more context levels.
+Overloaded functions using `up-context' take no parameters.
+BOUNDS-TYPE is a symbol representing a tag class to restrict
+movement to. If this is nil, 'function is used.
+This will find the smallest tag of that class (function, variable,
+type, etc) and make sure non-nil is returned if you cannot
+go up past the bounds of that tag."
+ (require 'semantic/find)
+ (if point (goto-char point))
+ (let ((nar (semantic-current-tag-of-class (or bounds-type 'function))))
+ (if nar
+ (semantic-with-buffer-narrowed-to-tag nar (:override-with-args ()))
+ (when bounds-type
+ (error "No context of type %s to advance in" bounds-type))
+ (:override-with-args ()))))
+
+(defun semantic-up-context-default ()
+ "Move the point up and out one context level.
+Works with languages that use parenthetical grouping."
+ ;; By default, assume that the language uses some form of parenthetical
+ ;; do dads for their context.
+ (condition-case nil
+ (progn
+ (up-list -1)
+ nil)
+ (error t)))
+
+(define-overloadable-function semantic-beginning-of-context (&optional point)
+ "Move POINT to the beginning of the current context.
+Return non-nil if there is no upper context.
+The default behavior uses `semantic-up-context'.")
+
+(defun semantic-beginning-of-context-default (&optional point)
+ "Move POINT to the beginning of the current context via parenthisis.
+Return non-nil if there is no upper context."
+ (if point (goto-char point))
+ (if (semantic-up-context)
+ t
+ (forward-char 1)
+ nil))
+
+(define-overloadable-function semantic-end-of-context (&optional point)
+ "Move POINT to the end of the current context.
+Return non-nil if there is no upper context.
+Be default, this uses `semantic-up-context', and assumes parenthetical
+block delimiters.")
+
+(defun semantic-end-of-context-default (&optional point)
+ "Move POINT to the end of the current context via parenthisis.
+Return non-nil if there is no upper context."
+ (if point (goto-char point))
+ (let ((start (point)))
+ (if (semantic-up-context)
+ t
+ ;; Go over the list, and back over the end parenthisis.
+ (condition-case nil
+ (progn
+ (forward-sexp 1)
+ (forward-char -1))
+ (error
+ ;; If an error occurs, get the current tag from the cache,
+ ;; and just go to the end of that. Make sure we end up at least
+ ;; where start was so parse-region type calls work.
+ (if (semantic-current-tag)
+ (progn
+ (goto-char (semantic-tag-end (semantic-current-tag)))
+ (when (< (point) start)
+ (goto-char start)))
+ (goto-char start))
+ t)))
+ nil))
+
+(defun semantic-narrow-to-context ()
+ "Narrow the buffer to the extent of the current context."
+ (let (b e)
+ (save-excursion
+ (if (semantic-beginning-of-context)
+ nil
+ (setq b (point))))
+ (save-excursion
+ (if (semantic-end-of-context)
+ nil
+ (setq e (point))))
+ (if (and b e) (narrow-to-region b e))))
+
+(defmacro semantic-with-buffer-narrowed-to-context (&rest body)
+ "Execute BODY with the buffer narrowed to the current context."
+ `(save-restriction
+ (semantic-narrow-to-context)
+ ,@body))
+(put 'semantic-with-buffer-narrowed-to-context 'lisp-indent-function 0)
+(add-hook 'edebug-setup-hook
+ (lambda ()
+ (def-edebug-spec semantic-with-buffer-narrowed-to-context
+ (def-body))))
+
+;;; Local Variables
+;;
+;;
+(define-overloadable-function semantic-get-local-variables (&optional point)
+ "Get the local variables based on POINT's context.
+Local variables are returned in Semantic tag format.
+This can be overriden with `get-local-variables'."
+ ;; The working status is to let the parser work properly
+ (let ((semantic--progress-reporter
+ (make-progress-reporter (semantic-parser-working-message "Local")
+ 0 100)))
+ (save-excursion
+ (if point (goto-char point))
+ (let* ((semantic-working-type nil)
+ ;; Disable parsing messages
+ (case-fold-search semantic-case-fold))
+ (:override-with-args ())))))
+
+(defun semantic-get-local-variables-default ()
+ "Get local values from a specific context.
+Uses the bovinator with the special top-symbol `bovine-inner-scope'
+to collect tags, such as local variables or prototypes."
+ ;; This assumes a bovine parser. Make sure we don't do
+ ;; anything in that case.
+ (when (and semantic--parse-table (not (eq semantic--parse-table t))
+ (not (semantic-parse-tree-unparseable-p)))
+ (let ((vars (semantic-get-cache-data 'get-local-variables)))
+ (if vars
+ (progn
+ ;;(message "Found cached vars.")
+ vars)
+ (let ((vars2 nil)
+ ;; We want nothing to do with funny syntaxing while doing this.
+ (semantic-unmatched-syntax-hook nil)
+ (start (point))
+ (firstusefulstart nil)
+ )
+ (while (not (semantic-up-context (point) 'function))
+ (when (not vars)
+ (setq firstusefulstart (point)))
+ (save-excursion
+ (forward-char 1)
+ (setq vars
+ ;; Note to self: semantic-parse-region returns cooked
+ ;; but unlinked tags. File information is lost here
+ ;; and is added next.
+ (append (semantic-parse-region
+ (point)
+ (save-excursion (semantic-end-of-context) (point))
+ 'bovine-inner-scope
+ nil
+ t)
+ vars))))
+ ;; Modify the tags in place.
+ (setq vars2 vars)
+ (while vars2
+ (semantic--tag-put-property (car vars2) :filename
(buffer-file-name))
+ (setq vars2 (cdr vars2)))
+ ;; Hash our value into the first context that produced useful results.
+ (when (and vars firstusefulstart)
+ (let ((end (save-excursion
+ (goto-char firstusefulstart)
+ (save-excursion
+ (unless (semantic-end-of-context)
+ (point))))))
+ ;;(message "Caching values %d->%d." firstusefulstart end)
+ (semantic-cache-data-to-buffer
+ (current-buffer) firstusefulstart
+ (or end
+ ;; If the end-of-context fails,
+ ;; just use our cursor starting
+ ;; position.
+ start)
+ vars 'get-local-variables 'exit-cache-zone))
+ )
+ ;; Return our list.
+ vars)))))
+
+(define-overloadable-function semantic-get-local-arguments (&optional point)
+ "Get arguments (variables) from the current context at POINT.
+Parameters are available if the point is in a function or method.
+Return a list of tags unlinked from the originating buffer.
+Arguments are obtained by overriding `get-local-arguments', or by the
+default function `semantic-get-local-arguments-default'. This, must
+return a list of tags, or a list of strings that will be converted to
+tags."
+ (save-excursion
+ (if point (goto-char point))
+ (let* ((case-fold-search semantic-case-fold)
+ (args (:override-with-args ()))
+ arg tags)
+ ;; Convert unsafe arguments to the right thing.
+ (while args
+ (setq arg (car args)
+ args (cdr args)
+ tags (cons (cond
+ ((semantic-tag-p arg)
+ ;; Return a copy of tag without overlay.
+ ;; The overlay is preserved.
+ (semantic-tag-copy arg nil t))
+ ((stringp arg)
+ (semantic--tag-put-property
+ (semantic-tag-new-variable arg nil nil)
+ :filename (buffer-file-name)))
+ (t
+ (error "Unknown parameter element %S" arg)))
+ tags)))
+ (nreverse tags))))
+
+(defun semantic-get-local-arguments-default ()
+ "Get arguments (variables) from the current context.
+Parameters are available if the point is in a function or method."
+ (let ((tag (semantic-current-tag)))
+ (if (and tag (semantic-tag-of-class-p tag 'function))
+ (semantic-tag-function-arguments tag))))
+
+(define-overloadable-function semantic-get-all-local-variables (&optional
point)
+ "Get all local variables for this context, and parent contexts.
+Local variables are returned in Semantic tag format.
+Be default, this gets local variables, and local arguments.
+Optional argument POINT is the location to start getting the variables from.")
+
+(defun semantic-get-all-local-variables-default (&optional point)
+ "Get all local variables for this context.
+Optional argument POINT is the location to start getting the variables from.
+That is a cons (LOCAL-ARGUMENTS . LOCAL-VARIABLES) where:
+
+- LOCAL-ARGUMENTS is collected by `semantic-get-local-arguments'.
+- LOCAL-VARIABLES is collected by `semantic-get-local-variables'."
+ (save-excursion
+ (if point (goto-char point))
+ (let ((case-fold-search semantic-case-fold))
+ (append (semantic-get-local-arguments)
+ (semantic-get-local-variables)))))
+
+;;; Local context parsing
+;;
+;; Context parsing assumes a series of language independent commonalities.
+;; These terms are used to describe those contexts:
+;;
+;; command - One command in the language.
+;; symbol - The symbol the cursor is on.
+;; This would include a series of type/field when applicable.
+;; assignment - The variable currently being assigned to
+;; function - The function call the cursor is on/in
+;; argument - The index to the argument the cursor is on.
+;;
+;;
+(define-overloadable-function semantic-end-of-command ()
+ "Move to the end of the current command.
+Be default, uses `semantic-command-separation-character'.")
+
+(defun semantic-end-of-command-default ()
+ "Move to the end of the current command.
+Depends on `semantic-command-separation-character' to find the
+beginning and end of a command."
+ (semantic-with-buffer-narrowed-to-context
+ (let ((case-fold-search semantic-case-fold))
+ (with-syntax-table semantic-lex-syntax-table
+
+ (if (re-search-forward (regexp-quote
semantic-command-separation-character)
+ nil t)
+ (forward-char -1)
+ ;; If there wasn't a command after this, we are the last
+ ;; command, and we are incomplete.
+ (goto-char (point-max)))))))
+
+(define-overloadable-function semantic-beginning-of-command ()
+ "Move to the beginning of the current command.
+Be default, uses `semantic-command-separation-character'.")
+
+(defun semantic-beginning-of-command-default ()
+ "Move to the beginning of the current command.
+Depends on `semantic-command-separation-character' to find the
+beginning and end of a command."
+ (semantic-with-buffer-narrowed-to-context
+ (with-syntax-table semantic-lex-syntax-table
+ (let ((case-fold-search semantic-case-fold))
+ (skip-chars-backward semantic-command-separation-character)
+ (if (re-search-backward (regexp-quote
semantic-command-separation-character)
+ nil t)
+ (goto-char (match-end 0))
+ ;; If there wasn't a command after this, we are the last
+ ;; command, and we are incomplete.
+ (goto-char (point-min)))
+ (skip-chars-forward " \t\n")
+ ))))
+
+
+(defsubst semantic-point-at-beginning-of-command ()
+ "Return the point at the beginning of the current command."
+ (save-excursion (semantic-beginning-of-command) (point)))
+
+(defsubst semantic-point-at-end-of-command ()
+ "Return the point at the beginning of the current command."
+ (save-excursion (semantic-end-of-command) (point)))
+
+(defsubst semantic-narrow-to-command ()
+ "Narrow the current buffer to the current command."
+ (narrow-to-region (semantic-point-at-beginning-of-command)
+ (semantic-point-at-end-of-command)))
+
+(defmacro semantic-with-buffer-narrowed-to-command (&rest body)
+ "Execute BODY with the buffer narrowed to the current command."
+ `(save-restriction
+ (semantic-narrow-to-command)
+ ,@body))
+(put 'semantic-with-buffer-narrowed-to-command 'lisp-indent-function 0)
+(add-hook 'edebug-setup-hook
+ (lambda ()
+ (def-edebug-spec semantic-with-buffer-narrowed-to-command
+ (def-body))))
+
+
+(define-overloadable-function semantic-ctxt-current-symbol (&optional point)
+ "Return the current symbol the cursor is on at POINT in a list.
+The symbol includes all logical parts of a complex reference.
+For example, in C the statement:
+ this.that().entry
+
+Would be object `this' calling method `that' which returns some structure
+whose field `entry' is being reference. In this case, this function
+would return the list:
+ ( \"this\" \"that\" \"entry\" )")
+
+(defun semantic-ctxt-current-symbol-default (&optional point)
+ "Return the current symbol the cursor is on at POINT in a list.
+This will include a list of type/field names when applicable.
+Depends on `semantic-type-relation-separator-character'."
+ (save-excursion
+ (if point (goto-char point))
+ (let* ((fieldsep1 (mapconcat (lambda (a) (regexp-quote a))
+ semantic-type-relation-separator-character
+ "\\|"))
+ ;; NOTE: The [ \n] expression below should used \\s-, but that
+ ;; doesn't work in C since \n means end-of-comment, and isn't
+ ;; really whitespace.
+ (fieldsep (concat "[ \t\n\r]*\\(" fieldsep1 "\\)[
\t\n\r]*\\(\\w\\|\\s_\\)"))
+ (case-fold-search semantic-case-fold)
+ (symlist nil)
+ end)
+ (with-syntax-table semantic-lex-syntax-table
+ (save-excursion
+ (cond ((looking-at "\\w\\|\\s_")
+ ;; In the middle of a symbol, move to the end.
+ (forward-sexp 1))
+ ((looking-at fieldsep1)
+ ;; We are in a find spot.. do nothing.
+ nil
+ )
+ ((save-excursion
+ (and (condition-case nil
+ (progn (forward-sexp -1)
+ (forward-sexp 1)
+ t)
+ (error nil))
+ (looking-at fieldsep1)))
+ (setq symlist (list ""))
+ (forward-sexp -1)
+ ;; Skip array expressions.
+ (while (looking-at "\\s(") (forward-sexp -1))
+ (forward-sexp 1))
+ )
+ ;; Set our end point.
+ (setq end (point))
+
+ ;; Now that we have gotten started, lets do the rest.
+ (condition-case nil
+ (while (save-excursion
+ (forward-char -1)
+ (looking-at "\\w\\|\\s_"))
+ ;; We have a symbol.. Do symbol things
+ (forward-sexp -1)
+ (setq symlist (cons (buffer-substring-no-properties (point) end)
+ symlist))
+ ;; Skip the next syntactic expression backwards, then go
forwards.
+ (let ((cp (point)))
+ (forward-sexp -1)
+ (forward-sexp 1)
+ ;; If we end up at the same place we started, we are at the
+ ;; beginning of a buffer, or narrowed to a command and
+ ;; have to stop.
+ (if (<= cp (point)) (error nil)))
+ (if (looking-at fieldsep)
+ (progn
+ (forward-sexp -1)
+ ;; Skip array expressions.
+ (while (and (looking-at "\\s(") (not (bobp)))
+ (forward-sexp -1))
+ (forward-sexp 1)
+ (setq end (point)))
+ (error nil))
+ )
+ (error nil)))
+ symlist))))
+
+
+(define-overloadable-function semantic-ctxt-current-symbol-and-bounds
(&optional point)
+ "Return the current symbol and bounds the cursor is on at POINT.
+The symbol should be the same as returned by `semantic-ctxt-current-symbol'.
+Return (PREFIX ENDSYM BOUNDS).")
+
+(defun semantic-ctxt-current-symbol-and-bounds-default (&optional point)
+ "Return the current symbol and bounds the cursor is on at POINT.
+Uses `semantic-ctxt-current-symbol' to calculate the symbol.
+Return (PREFIX ENDSYM BOUNDS)."
+ (save-excursion
+ (when point (goto-char (point)))
+ (let* ((prefix (semantic-ctxt-current-symbol))
+ (endsym (car (reverse prefix)))
+ ;; @todo - Can we get this data direct from ctxt-current-symbol?
+ (bounds (save-excursion
+ (cond ((string= endsym "")
+ (cons (point) (point))
+ )
+ ((and prefix (looking-at endsym))
+ (cons (point) (progn
+ (condition-case nil
+ (forward-sexp 1)
+ (error nil))
+ (point))))
+ (prefix
+ (condition-case nil
+ (cons (progn (forward-sexp -1) (point))
+ (progn (forward-sexp 1) (point)))
+ (error nil)))
+ (t nil))))
+ )
+ (list prefix endsym bounds))))
+
+(define-overloadable-function semantic-ctxt-current-assignment (&optional
point)
+ "Return the current assignment near the cursor at POINT.
+Return a list as per `semantic-ctxt-current-symbol'.
+Return nil if there is nothing relevant.")
+
+(defun semantic-ctxt-current-assignment-default (&optional point)
+ "Return the current assignment near the cursor at POINT.
+By default, assume that \"=\" indicates an assignment."
+ (if point (goto-char point))
+ (let ((case-fold-search semantic-case-fold))
+ (with-syntax-table semantic-lex-syntax-table
+ (condition-case nil
+ (semantic-with-buffer-narrowed-to-command
+ (save-excursion
+ (skip-chars-forward " \t=")
+ (condition-case nil (forward-char 1) (error nil))
+ (re-search-backward "[^=]=\\([^=]\\|$\\)")
+ ;; We are at an equals sign. Go backwards a sexp, and
+ ;; we'll have the variable. Otherwise we threw an error
+ (forward-sexp -1)
+ (semantic-ctxt-current-symbol)))
+ (error nil)))))
+
+(define-overloadable-function semantic-ctxt-current-function (&optional point)
+ "Return the current function call the cursor is in at POINT.
+The function returned is the one accepting the arguments that
+the cursor is currently in. It will not return function symbol if the
+cursor is on the text representing that function.")
+
+(defun semantic-ctxt-current-function-default (&optional point)
+ "Return the current function call the cursor is in at POINT.
+The call will be identifed for C like langauges with the form
+ NAME ( args ... )"
+ (if point (goto-char point))
+ (let ((case-fold-search semantic-case-fold))
+ (with-syntax-table semantic-lex-syntax-table
+ (save-excursion
+ (semantic-up-context)
+ (when (looking-at "(")
+ (semantic-ctxt-current-symbol))))
+ ))
+
+(define-overloadable-function semantic-ctxt-current-argument (&optional point)
+ "Return the index of the argument position the cursor is on at POINT.")
+
+(defun semantic-ctxt-current-argument-default (&optional point)
+ "Return the index of the argument the cursor is on at POINT.
+Depends on `semantic-function-argument-separation-character'."
+ (if point (goto-char point))
+ (let ((case-fold-search semantic-case-fold))
+ (with-syntax-table semantic-lex-syntax-table
+ (when (semantic-ctxt-current-function)
+ (save-excursion
+ ;; Only get the current arg index if we are in function args.
+ (let ((p (point))
+ (idx 1))
+ (semantic-up-context)
+ (while (re-search-forward
+ (regexp-quote
semantic-function-argument-separation-character)
+ p t)
+ (setq idx (1+ idx)))
+ idx))))))
+
+(defun semantic-ctxt-current-thing ()
+ "Calculate a thing identified by the current cursor position.
+Calls previously defined `semantic-ctxt-current-...' calls until something
+gets a match. See `semantic-ctxt-current-symbol',
+`semantic-ctxt-current-function', and `semantic-ctxt-current-assignment'
+for details on the return value."
+ (or (semantic-ctxt-current-symbol)
+ (semantic-ctxt-current-function)
+ (semantic-ctxt-current-assignment)))
+
+(define-overloadable-function semantic-ctxt-current-class-list (&optional
point)
+ "Return a list of tag classes that are allowed at POINT.
+If POINT is nil, the current buffer location is used.
+For example, in Emacs Lisp, the symbol after a ( is most likely
+a function. In a makefile, symbols after a : are rules, and symbols
+after a $( are variables.")
+
+(defun semantic-ctxt-current-class-list-default (&optional point)
+ "Return a list of tag classes that are allowed at POINT.
+Assume a functional typed language. Uses very simple rules."
+ (save-excursion
+ (if point (goto-char point))
+
+ (let ((tag (semantic-current-tag)))
+ (if tag
+ (cond ((semantic-tag-of-class-p tag 'function)
+ '(function variable type))
+ ((or (semantic-tag-of-class-p tag 'type)
+ (semantic-tag-of-class-p tag 'variable))
+ '(type))
+ (t nil))
+ '(type)
+ ))))
+
+;;;###autoload
+(define-overloadable-function semantic-ctxt-current-mode (&optional point)
+ "Return the major mode active at POINT.
+POINT defaults to the value of point in current buffer.
+You should override this function in multiple mode buffers to
+determine which major mode apply at point.")
+
+(defun semantic-ctxt-current-mode-default (&optional point)
+ "Return the major mode active at POINT.
+POINT defaults to the value of point in current buffer.
+This default implementation returns the current major mode."
+ major-mode)
+
+;;; Scoped Types
+;;
+;; Scoped types are types that the current code would have access to.
+;; The come from the global namespace or from special commands such as "using"
+(define-overloadable-function semantic-ctxt-scoped-types (&optional point)
+ "Return a list of type names currently in scope at POINT.
+The return value can be a mixed list of either strings (names of
+types that are in scope) or actual tags (type declared locally
+that may or may not have a name.)")
+
+(defun semantic-ctxt-scoped-types-default (&optional point)
+ "Return a list of scoped types by name for the current context at POINT.
+This is very different for various languages, and does nothing unless
+overriden."
+ (if point (goto-char point))
+ (let ((case-fold-search semantic-case-fold))
+ ;; We need to look at TYPES within the bounds of locally parse arguments.
+ ;; C needs to find using statements and the like too. Bleh.
+ nil
+ ))
+
+(provide 'semantic/ctxt)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/ctxt"
+;; End:
+
+;;; semantic/ctxt.el ends here
Index: cedet/semantic/db-debug.el
===================================================================
RCS file: cedet/semantic/db-debug.el
diff -N cedet/semantic/db-debug.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/db-debug.el 28 Sep 2009 15:15:07 -0000 1.2
@@ -0,0 +1,111 @@
+;;; semantic/db-debug.el --- Extra level debugging routines for Semantic
+
+;;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Various routines for debugging SemanticDB issues, or viewing
+;; semanticdb state.
+
+(require 'data-debug)
+(require 'semantic/db)
+(require 'semantic/format)
+
+;;; Code:
+;;
+(defun semanticdb-dump-all-table-summary ()
+ "Dump a list of all databases in Emacs memory."
+ (interactive)
+ (require 'data-debug)
+ (let ((db semanticdb-database-list))
+ (data-debug-new-buffer "*SEMANTICDB*")
+ (data-debug-insert-stuff-list db "*")))
+
+(defalias 'semanticdb-adebug-database-list 'semanticdb-dump-all-table-summary)
+
+(defun semanticdb-adebug-current-database ()
+ "Run ADEBUG on the current database."
+ (interactive)
+ (require 'data-debug)
+ (let ((p semanticdb-current-database)
+ )
+ (data-debug-new-buffer "*SEMANTICDB ADEBUG*")
+ (data-debug-insert-stuff-list p "*")))
+
+(defun semanticdb-adebug-current-table ()
+ "Run ADEBUG on the current database."
+ (interactive)
+ (require 'data-debug)
+ (let ((p semanticdb-current-table))
+ (data-debug-new-buffer "*SEMANTICDB ADEBUG*")
+ (data-debug-insert-stuff-list p "*")))
+
+
+(defun semanticdb-adebug-project-database-list ()
+ "Run ADEBUG on the current database."
+ (interactive)
+ (require 'data-debug)
+ (let ((p (semanticdb-current-database-list)))
+ (data-debug-new-buffer "*SEMANTICDB ADEBUG*")
+ (data-debug-insert-stuff-list p "*")))
+
+
+
+;;; Sanity Checks
+;;
+
+(defun semanticdb-table-oob-sanity-check (cache)
+ "Validate that CACHE tags do not have any overlays in them."
+ (while cache
+ (when (semantic-overlay-p (semantic-tag-overlay cache))
+ (message "Tag %s has an erroneous overlay!"
+ (semantic-format-tag-summarize (car cache))))
+ (semanticdb-table-oob-sanity-check
+ (semantic-tag-components-with-overlays (car cache)))
+ (setq cache (cdr cache))))
+
+(defun semanticdb-table-sanity-check (&optional table)
+ "Validate the current semanticdb TABLE."
+ (interactive)
+ (if (not table) (setq table semanticdb-current-table))
+ (let* ((full-filename (semanticdb-full-filename table))
+ (buff (find-buffer-visiting full-filename)))
+ (if buff
+ (save-excursion
+ (set-buffer buff)
+ (semantic-sanity-check))
+ ;; We can't use the usual semantic validity check, so hack our own.
+ (semanticdb-table-oob-sanity-check (semanticdb-get-tags table)))))
+
+(defun semanticdb-database-sanity-check ()
+ "Validate the current semantic database."
+ (interactive)
+ (let ((tables (semanticdb-get-database-tables
+ semanticdb-current-database)))
+ (while tables
+ (semanticdb-table-sanity-check (car tables))
+ (setq tables (cdr tables)))
+ ))
+
+
+
+(provide 'semantic/db-debug)
+
+;;; semantic/db-debug.el ends here
Index: cedet/semantic/db-ebrowse.el
===================================================================
RCS file: cedet/semantic/db-ebrowse.el
diff -N cedet/semantic/db-ebrowse.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/db-ebrowse.el 28 Sep 2009 15:15:07 -0000 1.2
@@ -0,0 +1,666 @@
+;;; semantic/db-ebrowse.el --- Semanticdb backend using ebrowse.
+
+;;; Copyright (C) 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Authors: Eric M. Ludlam <address@hidden>, Joakim Verona
+;; Keywords: tags
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; This program was started by Eric Ludlam, and Joakim Verona finished
+;; the implementation by adding searches and fixing bugs.
+;;
+;; Read in custom-created ebrowse BROWSE files into a semanticdb back
+;; end.
+;;
+;; Add these databases to the 'system' search.
+;; Possibly use ebrowse for local parsing too.
+;;
+;; When real details are needed out of the tag system from ebrowse,
+;; we will need to delve into the originating source and parse those
+;; files the usual way.
+;;
+;; COMMANDS:
+;; `semanticdb-create-ebrowse-database' - Call EBROWSE to create a
+;; system database for some directory. In general, use this for
+;; system libraries, such as /usr/include, or include directories
+;; large software projects.
+;; Customize `semanticdb-ebrowse-file-match' to make sure the correct
+;; file extensions are matched.
+;;
+;; `semanticdb-load-ebrowse-caches' - Load all the EBROWSE caches from
+;; your semanticdb system database directory. Once they are
+;; loaded, they become searchable as omnipotent databases for
+;; all C++ files. This is called automatically by semantic-load.
+;; Call it a second time to refresh the Emacs DB with the file.
+;;
+
+(require 'ebrowse)
+(require 'semantic)
+(require 'semantic/db-file)
+
+(eval-when-compile
+ ;; For generic function searching.
+ (require 'eieio)
+ (require 'eieio-opt)
+ (require 'semantic/find))
+
+(declare-function semantic-add-system-include "semantic/dep")
+
+;;; Code:
+(defvar semanticdb-ebrowse-default-file-name "BROWSE"
+ "The EBROWSE file name used for system caches.")
+
+(defcustom semanticdb-ebrowse-file-match "\\.\\(hh?\\|HH?\\|hpp\\)"
+ "Regular expression matching file names for ebrowse to parse.
+This expression should exclude C++ headers that have no extension.
+By default, include only headers since the semantic use of EBrowse
+is only for searching via semanticdb, and thus only headers would
+be searched."
+ :group 'semanticdb
+ :type 'string)
+
+;;; SEMANTIC Database related Code
+;;; Classes:
+(defclass semanticdb-table-ebrowse (semanticdb-table)
+ ((major-mode :initform c++-mode)
+ (ebrowse-tree :initform nil
+ :initarg :ebrowse-tree
+ :documentation
+ "The raw ebrowse tree for this file."
+ )
+ (global-extract :initform nil
+ :initarg :global-extract
+ :documentation
+ "Table of ebrowse tags specific to this file.
+This table is compisited from the ebrowse *Globals* section.")
+ )
+ "A table for returning search results from ebrowse.")
+
+(defclass semanticdb-project-database-ebrowse
+ (semanticdb-project-database)
+ ((new-table-class :initform semanticdb-table-ebrowse
+ :type class
+ :documentation
+ "New tables created for this database are of this class.")
+ (system-include-p :initform nil
+ :initarg :system-include
+ :documentation
+ "Flag indicating this database represents a system include
directory.")
+ (ebrowse-struct :initform nil
+ :initarg :ebrowse-struct
+ )
+ )
+ "Semantic Database deriving tags using the EBROWSE tool.
+EBROWSE is a C/C++ parser for use with `ebrowse' Emacs program.")
+
+
+(defun semanticdb-ebrowse-C-file-p (file)
+ "Is FILE a C or C++ file?"
+ (or (string-match semanticdb-ebrowse-file-match file)
+ (and (string-match "/\\w+$" file)
+ (not (file-directory-p file))
+ (let ((tmp (get-buffer-create "*semanticdb-ebrowse-tmp*")))
+ (save-excursion
+ (set-buffer tmp)
+ (condition-case nil
+ (insert-file-contents file nil 0 100 t)
+ (error (insert-file-contents file nil nil nil t)))
+ (goto-char (point-min))
+ (looking-at "\\s-*/\\(\\*\\|/\\)")
+ ))
+ )))
+
+(defun semanticdb-create-ebrowse-database (dir)
+ "Create an EBROSE database for directory DIR.
+The database file is stored in ~/.semanticdb, or whichever directory
+is specified by `semanticdb-default-save-directory'."
+ (interactive "DDirectory: ")
+ (setq dir (file-name-as-directory dir)) ;; for / on end
+ (let* ((savein (semanticdb-ebrowse-file-for-directory dir))
+ (filebuff (get-buffer-create "*SEMANTICDB EBROWSE TMP*"))
+ (files (directory-files (expand-file-name dir) t))
+ (mma auto-mode-alist)
+ (regexp nil)
+ )
+ ;; Create the input to the ebrowse command
+ (save-excursion
+ (set-buffer filebuff)
+ (buffer-disable-undo filebuff)
+ (setq default-directory (expand-file-name dir))
+
+ ;;; @TODO - convert to use semanticdb-collect-matching-filenames
+ ;; to get the file names.
+
+
+ (mapc (lambda (f)
+ (when (semanticdb-ebrowse-C-file-p f)
+ (insert f)
+ (insert "\n")))
+ files)
+ ;; Cleanup the ebrowse output buffer.
+ (save-excursion
+ (set-buffer (get-buffer-create "*EBROWSE OUTPUT*"))
+ (erase-buffer))
+ ;; Call the EBROWSE command.
+ (message "Creating ebrowse file: %s ..." savein)
+ (call-process-region (point-min) (point-max)
+ "ebrowse" nil "*EBROWSE OUTPUT*" nil
+ (concat "--output-file=" savein)
+ "--very-verbose")
+ )
+ ;; Create a short LOADER program for loading in this database.
+ (let* ((lfn (concat savein "-load.el"))
+ (lf (find-file-noselect lfn)))
+ (save-excursion
+ (set-buffer lf)
+ (erase-buffer)
+ (insert "(semanticdb-ebrowse-load-helper \""
+ (expand-file-name dir)
+ "\")\n")
+ (save-buffer)
+ (kill-buffer (current-buffer)))
+ (message "Creating ebrowse file: %s ... done" savein)
+ ;; Reload that database
+ (load lfn nil t)
+ )))
+
+(defun semanticdb-load-ebrowse-caches ()
+ "Load all semanticdb controlled EBROWSE caches."
+ (interactive)
+ (let ((f (directory-files semanticdb-default-save-directory
+ t (concat semanticdb-ebrowse-default-file-name
"-load.el$") t)))
+ (while f
+ (load (car f) nil t)
+ (setq f (cdr f)))
+ ))
+
+(defun semanticdb-ebrowse-load-helper (directory)
+ "Create the semanticdb database via ebrowse for directory.
+If DIRECTORY is found to be defunct, it won't load the DB, and will
+warn instead."
+ (if (file-directory-p directory)
+ (semanticdb-create-database semanticdb-project-database-ebrowse
+ directory)
+ (let* ((BF (semanticdb-ebrowse-file-for-directory directory))
+ (BFL (concat BF "-load.el"))
+ (BFLB (concat BF "-load.el~")))
+ (save-window-excursion
+ (with-output-to-temp-buffer "*FILES TO DELETE*"
+ (princ "The following BROWSE files are obsolete.\n\n")
+ (princ BF)
+ (princ "\n")
+ (princ BFL)
+ (princ "\n")
+ (when (file-exists-p BFLB)
+ (princ BFLB)
+ (princ "\n"))
+ )
+ (when (y-or-n-p (format
+ "Warning: Obsolete BROWSE file for: %s\nDelete? "
+ directory))
+ (delete-file BF)
+ (delete-file BFL)
+ (when (file-exists-p BFLB)
+ (delete-file BFLB))
+ )))))
+
+;JAVE this just instantiates a default empty ebrowse struct?
+; how would new instances wind up here?
+; the ebrowse class isnt singleton, unlike the emacs lisp one
+(defvar-mode-local c++-mode semanticdb-project-system-databases
+ ()
+ "Search Ebrowse for symbols.")
+
+(defmethod semanticdb-needs-refresh-p ((table semanticdb-table-ebrowse))
+ "EBROWSE database do not need to be refreshed.
+
+JAVE: stub for needs-refresh, because, how do we know if BROWSE files
+ are out of date?
+
+EML: Our database should probably remember the timestamp/checksum of
+ the most recently read EBROWSE file, and use that."
+ nil
+)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+
+;;; EBROWSE code
+;;
+;; These routines deal with part of the ebrowse interface.
+(defun semanticdb-ebrowse-file-for-directory (dir)
+ "Return the file name for DIR where the ebrowse BROWSE file is.
+This file should reside in `semanticdb-default-save-directory'."
+ (let* ((semanticdb-default-save-directory
+ semanticdb-default-save-directory)
+ (B (semanticdb-file-name-directory
+ 'semanticdb-project-database-file
+ (concat (expand-file-name dir)
+ semanticdb-ebrowse-default-file-name)))
+ )
+ B))
+
+(defun semanticdb-ebrowse-get-ebrowse-structure (dir)
+ "Return the ebrowse structure for directory DIR.
+This assumes semantic manages the BROWSE files, so they are assumed to live
+where semantic cache files live, depending on your settings.
+
+For instance: /home/<username>/.semanticdb/!usr!include!BROWSE"
+ (let* ((B (semanticdb-ebrowse-file-for-directory dir))
+ (buf (get-buffer-create "*semanticdb ebrowse*")))
+ (message "semanticdb-ebrowse %s" B)
+ (when (file-exists-p B)
+ (set-buffer buf)
+ (buffer-disable-undo buf)
+ (erase-buffer)
+ (insert-file-contents B)
+ (let ((ans nil)
+ (efcn (symbol-function 'ebrowse-show-progress)))
+ (fset 'ebrowse-show-progress #'(lambda (&rest junk) nil))
+ (unwind-protect ;; Protect against errors w/ ebrowse
+ (setq ans (list B (ebrowse-read)))
+ ;; These items must always happen
+ (erase-buffer)
+ (fset 'ebrowse-show-fcn efcn)
+ )
+ ans))))
+
+;;; Methods for creating a database or tables
+;;
+(defmethod semanticdb-create-database :STATIC ((dbeC
semanticdb-project-database-ebrowse)
+ directory)
+ "Create a new semantic database for DIRECTORY based on ebrowse.
+If there is no database for DIRECTORY available, then
+{not implemented yet} create one. Return nil if that is not possible."
+ ;; MAKE SURE THAT THE FILE LOADED DOESN'T ALREADY EXIST.
+ (require 'semantic/dep)
+ (let ((dbs semanticdb-database-list)
+ (found nil))
+ (while (and (not found) dbs)
+ (when (semanticdb-project-database-ebrowse-p (car dbs))
+ (when (string= (oref (car dbs) reference-directory) directory)
+ (setq found (car dbs))))
+ (setq dbs (cdr dbs)))
+ ;;STATIC means DBE cant be used as object, only as a class
+ (let* ((ebrowse-data (semanticdb-ebrowse-get-ebrowse-structure directory))
+ (dat (car (cdr ebrowse-data)))
+ (ebd (car dat))
+ (db nil)
+ (default-directory directory)
+ )
+ (if found
+ (setq db found)
+ (setq db (make-instance
+ dbeC
+ directory
+ :ebrowse-struct ebd
+ ))
+ (oset db reference-directory directory))
+
+ ;; Once we recycle or make a new DB, refresh the
+ ;; contents from the BROWSE file.
+ (oset db tables nil)
+ ;; only possible after object creation, tables inited to nil.
+ (semanticdb-ebrowse-strip-trees db dat)
+
+ ;; Once our database is loaded, if we are a system DB, we
+ ;; add ourselves to the include list for C++.
+ (semantic-add-system-include directory 'c++-mode)
+ (semantic-add-system-include directory 'c-mode)
+
+ db)))
+
+(defmethod semanticdb-ebrowse-strip-trees ((dbe
semanticdb-project-database-ebrowse)
+ data)
+ "For the ebrowse database DBE, strip all tables from DATA."
+;JAVE what it actually seems to do is split the original tree in "tables"
associated with files
+; im not sure it actually works:
+; the filename slot sometimes gets to be nil,
+; apparently for classes which definition cant be found, yet needs to be
included in the tree
+; like library baseclasses
+; a file can define several classes
+ (let ((T (car (cdr data))));1st comes a header, then the tree
+ (while T
+
+ (let* ((tree (car T))
+ (class (ebrowse-ts-class tree)); root class of tree
+ ;; Something funny going on with this file thing...
+ (filename (or (ebrowse-cs-source-file class)
+ (ebrowse-cs-file class)))
+ )
+ (cond
+ ((ebrowse-globals-tree-p tree)
+ ;; We have the globals tree.. save this special.
+ (semanticdb-ebrowse-add-globals-to-table dbe tree)
+ )
+ (t
+ ;; ebrowse will collect all the info from multiple files
+ ;; into one tree. Semantic wants all the bits to be tied
+ ;; into different files. We need to do a full dissociation
+ ;; into semantic parsable tables.
+ (semanticdb-ebrowse-add-tree-to-table dbe tree)
+ ))
+ (setq T (cdr T))))
+ ))
+
+;;; Filename based methods
+;;
+(defun semanticdb-ebrowse-add-globals-to-table (dbe tree)
+ "For database DBE, add the ebrowse TREE into the table."
+ (if (or (not (ebrowse-ts-p tree))
+ (not (ebrowse-globals-tree-p tree)))
+ (signal 'wrong-type-argument (list 'ebrowse-ts-p tree)))
+
+ (let* ((class (ebrowse-ts-class tree))
+ (fname (or (ebrowse-cs-source-file class)
+ (ebrowse-cs-file class)
+ ;; Not def'd here, assume our current
+ ;; file
+ (concat default-directory "/unknown-proxy.hh")))
+ (vars (ebrowse-ts-member-functions tree))
+ (fns (ebrowse-ts-member-variables tree))
+ (toks nil)
+ )
+ (while vars
+ (let ((nt (semantic-tag (ebrowse-ms-name (car vars))
+ 'variable))
+ (defpoint (ebrowse-bs-point class)))
+ (when defpoint
+ (semantic--tag-set-overlay nt
+ (vector defpoint defpoint)))
+ (setq toks (cons nt toks)))
+ (setq vars (cdr vars)))
+ (while fns
+ (let ((nt (semantic-tag (ebrowse-ms-name (car fns))
+ 'function))
+ (defpoint (ebrowse-bs-point class)))
+ (when defpoint
+ (semantic--tag-set-overlay nt
+ (vector defpoint defpoint)))
+ (setq toks (cons nt toks)))
+ (setq fns (cdr fns)))
+
+ ))
+
+(defun semanticdb-ebrowse-add-tree-to-table (dbe tree &optional fname
baseclasses)
+ "For database DBE, add the ebrowse TREE into the table for FNAME.
+Optional argument BASECLASSES specifyies a baseclass to the tree being
provided."
+ (if (not (ebrowse-ts-p tree))
+ (signal 'wrong-type-argument (list 'ebrowse-ts-p tree)))
+
+ ;; Strategy overview:
+ ;; 1) Calculate the filename for this tree.
+ ;; 2) Find a matching namespace in TAB, or create a new one.
+ ;; 3) Fabricate a tag proxy for CLASS
+ ;; 4) Add it to the namespace
+ ;; 5) Add subclasses
+
+ ;; 1 - Find the filename
+ (if (not fname)
+ (setq fname (or (ebrowse-cs-source-file (ebrowse-ts-class tree))
+ (ebrowse-cs-file (ebrowse-ts-class tree))
+ ;; Not def'd here, assume our current
+ ;; file
+ (concat default-directory "/unknown-proxy.hh"))))
+
+ (let* ((tab (or (semanticdb-file-table dbe fname)
+ (semanticdb-create-table dbe fname)))
+ (class (ebrowse-ts-class tree))
+ (scope (ebrowse-cs-scope class))
+ (ns (when scope (split-string scope ":" t)))
+ (nst nil)
+ (cls nil)
+ )
+
+ ;; 2 - Get the namespace tag
+ (when ns
+ (let ((taglst (if (slot-boundp tab 'tags) (oref tab tags) nil)))
+ (setq nst (semantic-find-first-tag-by-name (car ns) taglst))
+ (when (not nst)
+ (setq nst (semantic-tag (car ns) 'type :type "namespace"))
+ (oset tab tags (cons nst taglst))
+ )))
+
+ ;; 3 - Create a proxy tg.
+ (setq cls (semantic-tag (ebrowse-cs-name class)
+ 'type
+ :type "class"
+ :superclasses baseclasses
+ :faux t
+ :filename fname
+ ))
+ (let ((defpoint (ebrowse-bs-point class)))
+ (when defpoint
+ (semantic--tag-set-overlay cls
+ (vector defpoint defpoint))))
+
+ ;; 4 - add to namespace
+ (if nst
+ (semantic-tag-put-attribute
+ nst :members (cons cls (semantic-tag-get-attribute nst :members)))
+ (oset tab tags (cons cls (when (slot-boundp tab 'tags)
+ (oref tab tags)))))
+
+ ;; 5 - Subclasses
+ (let* ((subclass (ebrowse-ts-subclasses tree))
+ (pname (ebrowse-cs-name class)))
+ (when (ebrowse-cs-scope class)
+ (setq pname (concat (mapconcat (lambda (a) a) (cdr ns) "::") "::"
pname)))
+
+ (while subclass
+ (let* ((scc (ebrowse-ts-class (car subclass)))
+ (fname (or (ebrowse-cs-source-file scc)
+ (ebrowse-cs-file scc)
+ ;; Not def'd here, assume our current
+ ;; file
+ fname
+ )))
+ (when fname
+ (semanticdb-ebrowse-add-tree-to-table
+ dbe (car subclass) fname pname)))
+ (setq subclass (cdr subclass))))
+ ))
+
+;;;
+;; Overload for converting the simple faux tag into something better.
+;;
+(defmethod semanticdb-normalize-tags ((obj semanticdb-table-ebrowse) tags)
+ "Convert in Ebrowse database OBJ a list of TAGS into a complete tag.
+The default tag provided by searches exclude many features of a
+semantic parsed tag. Look up the file for OBJ, and match TAGS
+against a semantic parsed tag that has all the info needed, and
+return that."
+ (let ((tagret nil)
+ )
+ ;; SemanticDB will automatically create a regular database
+ ;; on top of the file just loaded by ebrowse during the set
+ ;; buffer. Fetch that table, and use it's tag list to look
+ ;; up the tag we just got, and thus turn it into a full semantic
+ ;; tag.
+ (while tags
+ (let ((tag (car tags)))
+ (save-excursion
+ (semanticdb-set-buffer obj)
+ (let ((ans nil))
+ ;; Gee, it would be nice to do this, but ebrowse LIES. Oi.
+ (when (semantic-tag-with-position-p tag)
+ (goto-char (semantic-tag-start tag))
+ (let ((foundtag (semantic-current-tag)))
+ ;; Make sure the discovered tag is the same as what we started
with.
+ (when (string= (semantic-tag-name tag)
+ (semantic-tag-name foundtag))
+ ;; We have a winner!
+ (setq ans foundtag))))
+ ;; Sometimes ebrowse lies. Do a generic search
+ ;; to find it within this file.
+ (when (not ans)
+ ;; We might find multiple hits for this tag, and we have no way
+ ;; of knowing which one the user wanted. Return the first one.
+ (setq ans (semantic-deep-find-tags-by-name
+ (semantic-tag-name tag)
+ (semantic-fetch-tags))))
+ (if (semantic-tag-p ans)
+ (setq tagret (cons ans tagret))
+ (setq tagret (append ans tagret)))
+ ))
+ (setq tags (cdr tags))))
+ tagret))
+
+(defmethod semanticdb-normalize-one-tag ((obj semanticdb-table-ebrowse) tag)
+ "Convert in Ebrowse database OBJ one TAG into a complete tag.
+The default tag provided by searches exclude many features of a
+semantic parsed tag. Look up the file for OBJ, and match TAG
+against a semantic parsed tag that has all the info needed, and
+return that."
+ (let ((tagret nil)
+ (objret nil))
+ ;; SemanticDB will automatically create a regular database
+ ;; on top of the file just loaded by ebrowse during the set
+ ;; buffer. Fetch that table, and use it's tag list to look
+ ;; up the tag we just got, and thus turn it into a full semantic
+ ;; tag.
+ (save-excursion
+ (semanticdb-set-buffer obj)
+ (setq objret semanticdb-current-table)
+ (when (not objret)
+ ;; What to do??
+ (debug))
+ (let ((ans nil))
+ ;; Gee, it would be nice to do this, but ebrowse LIES. Oi.
+ (when (semantic-tag-with-position-p tag)
+ (goto-char (semantic-tag-start tag))
+ (let ((foundtag (semantic-current-tag)))
+ ;; Make sure the discovered tag is the same as what we started with.
+ (when (string= (semantic-tag-name tag)
+ (semantic-tag-name foundtag))
+ ;; We have a winner!
+ (setq ans foundtag))))
+ ;; Sometimes ebrowse lies. Do a generic search
+ ;; to find it within this file.
+ (when (not ans)
+ ;; We might find multiple hits for this tag, and we have no way
+ ;; of knowing which one the user wanted. Return the first one.
+ (setq ans (semantic-deep-find-tags-by-name
+ (semantic-tag-name tag)
+ (semantic-fetch-tags))))
+ (if (semantic-tag-p ans)
+ (setq tagret ans)
+ (setq tagret (car ans)))
+ ))
+ (cons objret tagret)))
+
+;;; Search Overrides
+;;
+;; NOTE WHEN IMPLEMENTING: Be sure to add doc-string updates explaining
+;; how your new search routines are implemented.
+;;
+(defmethod semanticdb-find-tags-by-name-method
+ ((table semanticdb-table-ebrowse) name &optional tags)
+ "Find all tags named NAME in TABLE.
+Return a list of tags."
+ ;;(message "semanticdb-find-tags-by-name-method name -- %s" name)
+ (if tags
+ ;; If TAGS are passed in, then we don't need to do work here.
+ (call-next-method)
+ ;; If we ever need to do something special, add here.
+ ;; Since ebrowse tags are converted into semantic tags, we can
+ ;; get away with this sort of thing.
+ (call-next-method)
+ )
+ )
+
+(defmethod semanticdb-find-tags-by-name-regexp-method
+ ((table semanticdb-table-ebrowse) regex &optional tags)
+ "Find all tags with name matching REGEX in TABLE.
+Optional argument TAGS is a list of tags to search.
+Return a list of tags."
+ (if tags (call-next-method)
+ ;; YOUR IMPLEMENTATION HERE
+ (call-next-method)
+ ))
+
+(defmethod semanticdb-find-tags-for-completion-method
+ ((table semanticdb-table-ebrowse) prefix &optional tags)
+ "In TABLE, find all occurances of tags matching PREFIX.
+Optional argument TAGS is a list of tags to search.
+Returns a table of all matching tags."
+ (if tags (call-next-method)
+ ;; YOUR IMPLEMENTATION HERE
+ (call-next-method)
+ ))
+
+(defmethod semanticdb-find-tags-by-class-method
+ ((table semanticdb-table-ebrowse) class &optional tags)
+ "In TABLE, find all occurances of tags of CLASS.
+Optional argument TAGS is a list of tags to search.
+Returns a table of all matching tags."
+ (if tags (call-next-method)
+ (call-next-method)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Deep Searches
+;;
+;; If your language does not have a `deep' concept, these can be left
+;; alone, otherwise replace with implementations similar to those
+;; above.
+;;
+
+(defmethod semanticdb-deep-find-tags-by-name-method
+ ((table semanticdb-table-ebrowse) name &optional tags)
+ "Find all tags name NAME in TABLE.
+Optional argument TAGS is a list of tags t
+Like `semanticdb-find-tags-by-name-method' for ebrowse."
+ ;;(semanticdb-find-tags-by-name-method table name tags)
+ (call-next-method))
+
+(defmethod semanticdb-deep-find-tags-by-name-regexp-method
+ ((table semanticdb-table-ebrowse) regex &optional tags)
+ "Find all tags with name matching REGEX in TABLE.
+Optional argument TAGS is a list of tags to search.
+Like `semanticdb-find-tags-by-name-method' for ebrowse."
+ ;;(semanticdb-find-tags-by-name-regexp-method table regex tags)
+ (call-next-method))
+
+(defmethod semanticdb-deep-find-tags-for-completion-method
+ ((table semanticdb-table-ebrowse) prefix &optional tags)
+ "In TABLE, find all occurances of tags matching PREFIX.
+Optional argument TAGS is a list of tags to search.
+Like `semanticdb-find-tags-for-completion-method' for ebrowse."
+ ;;(semanticdb-find-tags-for-completion-method table prefix tags)
+ (call-next-method))
+
+;;; Advanced Searches
+;;
+(defmethod semanticdb-find-tags-external-children-of-type-method
+ ((table semanticdb-table-ebrowse) type &optional tags)
+ "Find all nonterminals which are child elements of TYPE
+Optional argument TAGS is a list of tags to search.
+Return a list of tags."
+ (if tags (call-next-method)
+ ;; Ebrowse collects all this type of stuff together for us.
+ ;; but we can't use it.... yet.
+ nil
+ ))
+
+(provide 'semantic/db-ebrowse)
+
+;;; semantic/db-ebrowse.el ends here
Index: cedet/semantic/db-el.el
===================================================================
RCS file: cedet/semantic/db-el.el
diff -N cedet/semantic/db-el.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/db-el.el 28 Sep 2009 15:15:07 -0000 1.2
@@ -0,0 +1,347 @@
+;;; semantic/db-el.el --- Semantic database extensions for Emacs Lisp
+
+;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: tags
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; There are a lot of Emacs Lisp functions and variables available for
+;; the asking. This adds on to the semanticdb programming interface to
+;; allow all loaded Emacs Lisp functions to be queried via semanticdb.
+;;
+;; This allows you to use programs written for Semantic using the database
+;; to also work in Emacs Lisp with no compromises.
+;;
+
+(require 'semantic/db)
+
+(eval-when-compile
+ ;; For generic function searching.
+ (require 'eieio)
+ (require 'eieio-opt)
+ (require 'eieio-base))
+
+(declare-function semantic-elisp-desymbolify "semantic/bovine/el")
+
+;;; Code:
+
+;;; Classes:
+(defclass semanticdb-table-emacs-lisp (semanticdb-abstract-table)
+ ((major-mode :initform emacs-lisp-mode)
+ )
+ "A table for returning search results from Emacs.")
+
+(defmethod semanticdb-refresh-table ((obj semanticdb-table-emacs-lisp)
&optional force)
+ "Do not refresh Emacs Lisp table.
+It does not need refreshing."
+ nil)
+
+(defmethod semanticdb-needs-refresh-p ((obj semanticdb-table-emacs-lisp))
+ "Return nil, we never need a refresh."
+ nil)
+
+(defclass semanticdb-project-database-emacs-lisp
+ (semanticdb-project-database eieio-singleton)
+ ((new-table-class :initform semanticdb-table-emacs-lisp
+ :type class
+ :documentation
+ "New tables created for this database are of this class.")
+ )
+ "Database representing Emacs core.")
+
+;; Create the database, and add it to searchable databases for Emacs Lisp mode.
+(defvar-mode-local emacs-lisp-mode semanticdb-project-system-databases
+ (list
+ (semanticdb-project-database-emacs-lisp "Emacs"))
+ "Search Emacs core for symbols.")
+
+(defvar-mode-local emacs-lisp-mode semanticdb-find-default-throttle
+ '(project omniscience)
+ "Search project files, then search this omniscience database.
+It is not necessary to to system or recursive searching because of
+the omniscience database.")
+
+;;; Filename based methods
+;;
+(defmethod semanticdb-get-database-tables ((obj
semanticdb-project-database-emacs-lisp))
+ "For an Emacs Lisp database, there are no explicit tables.
+Create one of our special tables that can act as an intermediary."
+ ;; We need to return something since there is always the "master table"
+ ;; The table can then answer file name type questions.
+ (when (not (slot-boundp obj 'tables))
+ (let ((newtable (semanticdb-table-emacs-lisp "Emacs System Table")))
+ (oset obj tables (list newtable))
+ (oset newtable parent-db obj)
+ (oset newtable tags nil)
+ ))
+ (call-next-method))
+
+(defmethod semanticdb-file-table ((obj semanticdb-project-database-emacs-lisp)
filename)
+ "From OBJ, return FILENAME's associated table object.
+For Emacs Lisp, creates a specialized table."
+ (car (semanticdb-get-database-tables obj))
+ )
+
+(defmethod semanticdb-get-tags ((table semanticdb-table-emacs-lisp ))
+ "Return the list of tags belonging to TABLE."
+ ;; specialty table ? Probably derive tags at request time.
+ nil)
+
+(defmethod semanticdb-equivalent-mode ((table semanticdb-table-emacs-lisp)
&optional buffer)
+ "Return non-nil if TABLE's mode is equivalent to BUFFER.
+Equivalent modes are specified by by `semantic-equivalent-major-modes'
+local variable."
+ (save-excursion
+ (set-buffer buffer)
+ (eq (or mode-local-active-mode major-mode) 'emacs-lisp-mode)))
+
+(defmethod semanticdb-full-filename ((obj semanticdb-table-emacs-lisp))
+ "Fetch the full filename that OBJ refers to.
+For Emacs Lisp system DB, there isn't one."
+ nil)
+
+;;; Conversion
+;;
+(defmethod semanticdb-normalize-tags ((obj semanticdb-table-emacs-lisp) tags)
+ "Convert tags, originating from Emacs OBJ, into standardized form."
+ (let ((newtags nil))
+ (dolist (T tags)
+ (let* ((ot (semanticdb-normalize-one-tag obj T))
+ (tag (cdr ot)))
+ (setq newtags (cons tag newtags))))
+ ;; There is no promise to have files associated.
+ (nreverse newtags)))
+
+(defmethod semanticdb-normalize-one-tag ((obj semanticdb-table-emacs-lisp) tag)
+ "Convert one TAG, originating from Emacs OBJ, into standardized form.
+If Emacs cannot resolve this symbol to a particular file, then return nil."
+ ;; Here's the idea. For each tag, get the name, then use
+ ;; Emacs' `symbol-file' to get the source. Once we have that,
+ ;; we can use more typical semantic searching techniques to
+ ;; get a regularly parsed tag.
+ (let* ((type (cond ((semantic-tag-of-class-p tag 'function)
+ 'defun)
+ ((semantic-tag-of-class-p tag 'variable)
+ 'defvar)
+ ))
+ (sym (intern (semantic-tag-name tag)))
+ (file (condition-case err
+ (symbol-file sym type)
+ ;; Older [X]Emacs don't have a 2nd argument.
+ (error (symbol-file sym))))
+ )
+ (if (or (not file) (not (file-exists-p file)))
+ ;; The file didn't exist. Return nil.
+ ;; We can't normalize this tag. Fake it out.
+ (cons obj tag)
+ (when (string-match "\\.elc" file)
+ (setq file (concat (file-name-sans-extension file)
+ ".el"))
+ (when (and (not (file-exists-p file))
+ (file-exists-p (concat file ".gz")))
+ ;; Is it a .gz file?
+ (setq file (concat file ".gz"))))
+
+ (let* ((tab (semanticdb-file-table-object file))
+ (alltags (semanticdb-get-tags tab))
+ (newtags (semanticdb-find-tags-by-name-method
+ tab (semantic-tag-name tag)))
+ (match nil))
+ ;; Find the best match.
+ (dolist (T newtags)
+ (when (semantic-tag-similar-p T tag)
+ (setq match T)))
+ ;; Backup system.
+ (when (not match)
+ (setq match (car newtags)))
+ ;; Return it.
+ (cons tab match)))))
+
+(defun semanticdb-elisp-sym-function-arglist (sym)
+ "Get the argument list for SYM.
+Deal with all different forms of function.
+This was snarfed out of eldoc."
+ (let* ((prelim-def
+ (let ((sd (and (fboundp sym)
+ (symbol-function sym))))
+ (and (symbolp sd)
+ (condition-case err
+ (setq sd (indirect-function sym))
+ (error (setq sd nil))))
+ sd))
+ (def (if (eq (car-safe prelim-def) 'macro)
+ (cdr prelim-def)
+ prelim-def))
+ (arglist (cond ((null def) nil)
+ ((byte-code-function-p def)
+ ;; This is an eieio compatibility function.
+ ;; We depend on EIEIO, so use this.
+ (eieio-compiled-function-arglist def))
+ ((eq (car-safe def) 'lambda)
+ (nth 1 def))
+ (t nil))))
+ arglist))
+
+(defun semanticdb-elisp-sym->tag (sym &optional toktype)
+ "Convert SYM into a semantic tag.
+TOKTYPE is a hint to the type of tag desired."
+ (if (stringp sym)
+ (setq sym (intern-soft sym)))
+ (when sym
+ (cond ((and (eq toktype 'function) (fboundp sym))
+ (require 'semantic/bovine/el)
+ (semantic-tag-new-function
+ (symbol-name sym)
+ nil ;; return type
+ (semantic-elisp-desymbolify
+ (semanticdb-elisp-sym-function-arglist sym)) ;; arg-list
+ :user-visible-flag (condition-case nil
+ (interactive-form sym)
+ (error nil))
+ ))
+ ((and (eq toktype 'variable) (boundp sym))
+ (semantic-tag-new-variable
+ (symbol-name sym)
+ nil ;; type
+ nil ;; value - ignore for now
+ ))
+ ((and (eq toktype 'type) (class-p sym))
+ (semantic-tag-new-type
+ (symbol-name sym)
+ "class"
+ (semantic-elisp-desymbolify
+ (aref (class-v semanticdb-project-database)
+ class-public-a)) ;; slots
+ (semantic-elisp-desymbolify (class-parents sym)) ;; parents
+ ))
+ ((not toktype)
+ ;; Figure it out on our own.
+ (cond ((class-p sym)
+ (semanticdb-elisp-sym->tag sym 'type))
+ ((fboundp sym)
+ (semanticdb-elisp-sym->tag sym 'function))
+ ((boundp sym)
+ (semanticdb-elisp-sym->tag sym 'variable))
+ (t nil))
+ )
+ (t nil))))
+
+;;; Search Overrides
+;;
+(defvar semanticdb-elisp-mapatom-collector nil
+ "Variable used to collect mapatoms output.")
+
+(defmethod semanticdb-find-tags-by-name-method
+ ((table semanticdb-table-emacs-lisp) name &optional tags)
+ "Find all tags name NAME in TABLE.
+Uses `inter-soft' to match NAME to emacs symbols.
+Return a list of tags."
+ (if tags (call-next-method)
+ ;; No need to search. Use `intern-soft' which does the same thing for us.
+ (let* ((sym (intern-soft name))
+ (fun (semanticdb-elisp-sym->tag sym 'function))
+ (var (semanticdb-elisp-sym->tag sym 'variable))
+ (typ (semanticdb-elisp-sym->tag sym 'type))
+ (taglst nil)
+ )
+ (when (or fun var typ)
+ ;; If the symbol is any of these things, build the search table.
+ (when var (setq taglst (cons var taglst)))
+ (when typ (setq taglst (cons typ taglst)))
+ (when fun (setq taglst (cons fun taglst)))
+ taglst
+ ))))
+
+(defmethod semanticdb-find-tags-by-name-regexp-method
+ ((table semanticdb-table-emacs-lisp) regex &optional tags)
+ "Find all tags with name matching REGEX in TABLE.
+Optional argument TAGS is a list of tags to search.
+Uses `apropos-internal' to find matches.
+Return a list of tags."
+ (if tags (call-next-method)
+ (delq nil (mapcar 'semanticdb-elisp-sym->tag
+ (apropos-internal regex)))))
+
+(defmethod semanticdb-find-tags-for-completion-method
+ ((table semanticdb-table-emacs-lisp) prefix &optional tags)
+ "In TABLE, find all occurances of tags matching PREFIX.
+Optional argument TAGS is a list of tags to search.
+Returns a table of all matching tags."
+ (if tags (call-next-method)
+ (delq nil (mapcar 'semanticdb-elisp-sym->tag
+ (all-completions prefix obarray)))))
+
+(defmethod semanticdb-find-tags-by-class-method
+ ((table semanticdb-table-emacs-lisp) class &optional tags)
+ "In TABLE, find all occurances of tags of CLASS.
+Optional argument TAGS is a list of tags to search.
+Returns a table of all matching tags."
+ (if tags (call-next-method)
+ ;; We could implement this, but it could be messy.
+ nil))
+
+;;; Deep Searches
+;;
+;; For Emacs Lisp deep searches are like top level searches.
+(defmethod semanticdb-deep-find-tags-by-name-method
+ ((table semanticdb-table-emacs-lisp) name &optional tags)
+ "Find all tags name NAME in TABLE.
+Optional argument TAGS is a list of tags to search.
+Like `semanticdb-find-tags-by-name-method' for Emacs Lisp."
+ (semanticdb-find-tags-by-name-method table name tags))
+
+(defmethod semanticdb-deep-find-tags-by-name-regexp-method
+ ((table semanticdb-table-emacs-lisp) regex &optional tags)
+ "Find all tags with name matching REGEX in TABLE.
+Optional argument TAGS is a list of tags to search.
+Like `semanticdb-find-tags-by-name-method' for Emacs Lisp."
+ (semanticdb-find-tags-by-name-regexp-method table regex tags))
+
+(defmethod semanticdb-deep-find-tags-for-completion-method
+ ((table semanticdb-table-emacs-lisp) prefix &optional tags)
+ "In TABLE, find all occurances of tags matching PREFIX.
+Optional argument TAGS is a list of tags to search.
+Like `semanticdb-find-tags-for-completion-method' for Emacs Lisp."
+ (semanticdb-find-tags-for-completion-method table prefix tags))
+
+;;; Advanced Searches
+;;
+(defmethod semanticdb-find-tags-external-children-of-type-method
+ ((table semanticdb-table-emacs-lisp) type &optional tags)
+ "Find all nonterminals which are child elements of TYPE
+Optional argument TAGS is a list of tags to search.
+Return a list of tags."
+ (if tags (call-next-method)
+ ;; EIEIO is the only time this matters
+ (when (featurep 'eieio)
+ (let* ((class (intern-soft type))
+ (taglst (when class
+ (delq nil
+ (mapcar 'semanticdb-elisp-sym->tag
+ ;; Fancy eieio function that knows all
about
+ ;; built in methods belonging to CLASS.
+ (eieio-all-generic-functions class)))))
+ )
+ taglst))))
+
+(provide 'semantic/db-el)
+
+;;; semantic/db-el.el ends here
Index: cedet/semantic/db-file.el
===================================================================
RCS file: cedet/semantic/db-file.el
diff -N cedet/semantic/db-file.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/db-file.el 28 Sep 2009 15:15:07 -0000 1.2
@@ -0,0 +1,457 @@
+;;; semantic/db-file.el --- Save a semanticdb to a cache file.
+
+;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: tags
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; A set of semanticdb classes for persistently saving caches on disk.
+;;
+
+(require 'semantic)
+(require 'semantic/db)
+(require 'cedet-files)
+
+(defvar semanticdb-file-version semantic-version
+ "Version of semanticdb we are writing files to disk with.")
+(defvar semanticdb-file-incompatible-version "1.4"
+ "Version of semanticdb we are not reverse compatible with.")
+
+;;; Settings
+;;
+(defcustom semanticdb-default-file-name "semantic.cache"
+ "File name of the semantic tag cache."
+ :group 'semanticdb
+ :type 'string)
+
+(defcustom semanticdb-default-save-directory
+ (expand-file-name "semanticdb" user-emacs-directory)
+ "Directory name where semantic cache files are stored.
+If this value is nil, files are saved in the current directory. If the value
+is a valid directory, then it overrides `semanticdb-default-file-name' and
+stores caches in a coded file name in this directory."
+ :group 'semanticdb
+ :type '(choice :tag "Default-Directory"
+ :menu-tag "Default-Directory"
+ (const :tag "Use current directory" :value nil)
+ (directory)))
+
+(defcustom semanticdb-persistent-path '(always)
+ "List of valid paths that semanticdb will cache tags to.
+When `global-semanticdb-minor-mode' is active, tag lists will
+be saved to disk when Emacs exits. Not all directories will have
+tags that should be saved.
+The value should be a list of valid paths. A path can be a string,
+indicating a directory in which to save a variable. An element in the
+list can also be a symbol. Valid symbols are `never', which will
+disable any saving anywhere, `always', which enables saving
+everywhere, or `project', which enables saving in any directory that
+passes a list of predicates in `semanticdb-project-predicate-functions'."
+ :group 'semanticdb
+ :type nil)
+
+(defcustom semanticdb-save-database-hooks nil
+ "Abnormal hook run after a database is saved.
+Each function is called with one argument, the object representing
+the database recently written."
+ :group 'semanticdb
+ :type 'hook)
+
+(defvar semanticdb-dir-sep-char (if (boundp 'directory-sep-char)
+ (symbol-value 'directory-sep-char)
+ ?/)
+ "Character used for directory separation.
+Obsoleted in some versions of Emacs. Needed in others.
+NOTE: This should get deleted from semantic soon.")
+
+(defun semanticdb-fix-pathname (dir)
+ "If DIR is broken, fix it.
+Force DIR to end with a /.
+Note: Same as `file-name-as-directory'.
+NOTE: This should get deleted from semantic soon."
+ (file-name-as-directory dir))
+;; I didn't initially know about the above fcn. Keep the below as a
+;; reference. Delete it someday once I've proven everything is the same.
+;; (if (not (= semanticdb-dir-sep-char (aref path (1- (length path)))))
+;; (concat path (list semanticdb-dir-sep-char))
+;; path))
+
+;;; Classes
+;;
+;;;###autoload
+(defclass semanticdb-project-database-file (semanticdb-project-database
+ eieio-persistent)
+ ((file-header-line :initform ";; SEMANTICDB Tags save file")
+ (do-backups :initform nil)
+ (semantic-tag-version :initarg :semantic-tag-version
+ :initform "1.4"
+ :documentation
+ "The version of the tags saved.
+The default value is 1.4. In semantic 1.4 there was no versioning, so
+when those files are loaded, this becomes the version number.
+To save the version number, we must hand-set this version string.")
+ (semanticdb-version :initarg :semanticdb-version
+ :initform "1.4"
+ :documentation
+ "The version of the object system saved.
+The default value is 1.4. In semantic 1.4, there was no versioning,
+so when those files are loaded, this becomes the version number.
+To save the version number, we must hand-set this version string.")
+ )
+ "Database of file tables saved to disk.")
+
+;;; Code:
+;;
+(defmethod semanticdb-create-database :STATIC ((dbc
semanticdb-project-database-file)
+ directory)
+ "Create a new semantic database for DIRECTORY and return it.
+If a database for DIRECTORY has already been loaded, return it.
+If a database for DIRECTORY exists, then load that database, and return it.
+If DIRECTORY doesn't exist, create a new one."
+ ;; Make sure this is fully expanded so we don't get duplicates.
+ (setq directory (file-truename directory))
+ (let* ((fn (semanticdb-cache-filename dbc directory))
+ (db (or (semanticdb-file-loaded-p fn)
+ (if (file-exists-p fn)
+ (progn
+ (semanticdb-load-database fn))))))
+ (unless db
+ (setq db (make-instance
+ dbc ; Create the database requested. Perhaps
+ (concat (file-name-nondirectory
+ (directory-file-name
+ directory))
+ "/")
+ :file fn :tables nil
+ :semantic-tag-version semantic-version
+ :semanticdb-version semanticdb-file-version)))
+ ;; Set this up here. We can't put it in the constructor because it
+ ;; would be saved, and we want DB files to be portable.
+ (oset db reference-directory directory)
+ db))
+
+;;; File IO
+
+(declare-function inversion-test "inversion")
+
+(defun semanticdb-load-database (filename)
+ "Load the database FILENAME."
+ (condition-case foo
+ (let* ((r (eieio-persistent-read filename))
+ (c (semanticdb-get-database-tables r))
+ (tv (oref r semantic-tag-version))
+ (fv (oref r semanticdb-version))
+ )
+ ;; Restore the parent-db connection
+ (while c
+ (oset (car c) parent-db r)
+ (setq c (cdr c)))
+ (unless (and (equal semanticdb-file-version fv)
+ (equal semantic-tag-version tv))
+ ;; Try not to load inversion unless we need it:
+ (require 'inversion)
+ (if (not (inversion-test 'semanticdb-file fv))
+ (when (inversion-test 'semantic-tag tv)
+ ;; Incompatible version. Flush tables.
+ (semanticdb-flush-database-tables r)
+ ;; Reset the version to new version.
+ (oset r semantic-tag-version semantic-tag-version)
+ ;; Warn user
+ (message "Semanticdb file is old. Starting over for %s"
+ filename))
+ ;; Version is not ok. Flush whole system
+ (message "semanticdb file is old. Starting over for %s"
+ filename)
+ ;; This database is so old, we need to replace it.
+ ;; We also need to delete it from the instance tracker.
+ (delete-instance r)
+ (setq r nil)))
+ r)
+ (error (message "Cache Error: [%s] %s, Restart"
+ filename foo)
+ nil)))
+
+(defun semanticdb-file-loaded-p (filename)
+ "Return the project belonging to FILENAME if it was already loaded."
+ (eieio-instance-tracker-find filename 'file 'semanticdb-database-list))
+
+(defmethod semanticdb-file-directory-exists-p ((DB
semanticdb-project-database-file)
+ &optional supress-questions)
+ "Does the directory the database DB needs to write to exist?
+If SUPRESS-QUESTIONS, then do not ask to create the directory."
+ (let ((dest (file-name-directory (oref DB file)))
+ )
+ (cond ((null dest)
+ ;; @TODO - If it was never set up... what should we do ?
+ nil)
+ ((file-exists-p dest) t)
+ ((or supress-questions
+ (and (boundp 'semanticdb--inhibit-make-directory)
+ semanticdb--inhibit-make-directory))
+ nil)
+ ((y-or-n-p (format "Create directory %s for SemanticDB? " dest))
+ (make-directory dest t)
+ t)
+ (t
+ (if (boundp 'semanticdb--inhibit-make-directory)
+ (setq semanticdb--inhibit-make-directory t))
+ nil))))
+
+(defmethod semanticdb-save-db ((DB semanticdb-project-database-file)
+ &optional
+ supress-questions)
+ "Write out the database DB to its file.
+If DB is not specified, then use the current database."
+ (let ((objname (oref DB file)))
+ (when (and (semanticdb-dirty-p DB)
+ (semanticdb-live-p DB)
+ (semanticdb-file-directory-exists-p DB supress-questions)
+ (semanticdb-write-directory-p DB)
+ )
+ ;;(message "Saving tag summary for %s..." objname)
+ (condition-case foo
+ (eieio-persistent-save (or DB semanticdb-current-database))
+ (file-error ; System error saving? Ignore it.
+ (message "%S: %s" foo objname))
+ (error
+ (cond
+ ((and (listp foo)
+ (stringp (nth 1 foo))
+ (string-match "write[- ]protected" (nth 1 foo)))
+ (message (nth 1 foo)))
+ ((and (listp foo)
+ (stringp (nth 1 foo))
+ (string-match "no such directory" (nth 1 foo)))
+ (message (nth 1 foo)))
+ (t
+ ;; @todo - It should ask if we are not called from a hook.
+ ;; How?
+ (if (or supress-questions
+ (y-or-n-p (format "Skip Error: %S ?" (car (cdr foo)))))
+ (message "Save Error: %S: %s" (car (cdr foo))
+ objname)
+ (error "%S" (car (cdr foo))))))))
+ (run-hook-with-args 'semanticdb-save-database-hooks
+ (or DB semanticdb-current-database))
+ ;;(message "Saving tag summary for %s...done" objname)
+ )
+ ))
+
+(defmethod semanticdb-live-p ((obj semanticdb-project-database))
+ "Return non-nil if the file associated with OBJ is live.
+Live databases are objects associated with existing directories."
+ (and (slot-boundp obj 'reference-directory)
+ (file-exists-p (oref obj reference-directory))))
+
+(defmethod semanticdb-live-p ((obj semanticdb-table))
+ "Return non-nil if the file associated with OBJ is live.
+Live files are either buffers in Emacs, or files existing on the filesystem."
+ (let ((full-filename (semanticdb-full-filename obj)))
+ (or (find-buffer-visiting full-filename)
+ (file-exists-p full-filename))))
+
+(defvar semanticdb-data-debug-on-write-error nil
+ "Run the data debugger on tables that issue errors.
+This variable is set to nil after the first error is encountered
+to prevent overload.")
+
+(declare-function data-debug-insert-thing "data-debug")
+
+(defmethod object-write ((obj semanticdb-table))
+ "When writing a table, we have to make sure we deoverlay it first.
+Restore the overlays after writting.
+Argument OBJ is the object to write."
+ (when (semanticdb-live-p obj)
+ (when (semanticdb-in-buffer-p obj)
+ (save-excursion
+ (set-buffer (semanticdb-in-buffer-p obj))
+
+ ;; Make sure all our tag lists are up to date.
+ (semantic-fetch-tags)
+
+ ;; Try to get an accurate unmatched syntax table.
+ (when (and (boundp semantic-show-unmatched-syntax-mode)
+ semantic-show-unmatched-syntax-mode)
+ ;; Only do this if the user runs unmatched syntax
+ ;; mode display enties.
+ (oset obj unmatched-syntax
+ (semantic-show-unmatched-lex-tokens-fetch))
+ )
+
+ ;; Make sure pointmax is up to date
+ (oset obj pointmax (point-max))
+ ))
+
+ ;; Make sure that the file size and other attributes are
+ ;; up to date.
+ (let ((fattr (file-attributes (semanticdb-full-filename obj))))
+ (oset obj fsize (nth 7 fattr))
+ (oset obj lastmodtime (nth 5 fattr))
+ )
+
+ ;; Do it!
+ (condition-case tableerror
+ (call-next-method)
+ (error
+ (when semanticdb-data-debug-on-write-error
+ (require 'data-debug)
+ (data-debug-new-buffer (concat "*SEMANTICDB ERROR*"))
+ (data-debug-insert-thing obj "*" "")
+ (setq semanticdb-data-debug-on-write-error nil))
+ (message "Error Writing Table: %s" (object-name obj))
+ (error "%S" (car (cdr tableerror)))))
+
+ ;; Clear the dirty bit.
+ (oset obj dirty nil)
+ ))
+
+;;; State queries
+;;
+(defmethod semanticdb-write-directory-p ((obj
semanticdb-project-database-file))
+ "Return non-nil if OBJ should be written to disk.
+Uses `semanticdb-persistent-path' to determine the return value."
+ (let ((path semanticdb-persistent-path))
+ (catch 'found
+ (while path
+ (cond ((stringp (car path))
+ (if (string= (oref obj reference-directory) (car path))
+ (throw 'found t)))
+ ((eq (car path) 'project)
+ ;; @TODO - EDE causes us to go in here and disable
+ ;; the old default 'always save' setting.
+ ;;
+ ;; With new default 'always' should I care?
+ (if semanticdb-project-predicate-functions
+ (if (run-hook-with-args-until-success
+ 'semanticdb-project-predicate-functions
+ (oref obj reference-directory))
+ (throw 'found t))
+ ;; If the mode is 'project, and there are no project
+ ;; modes, then just always save the file. If users
+ ;; wish to restrict the search, modify
+ ;; `semanticdb-persistent-path' to include desired paths.
+ (if (= (length semanticdb-persistent-path) 1)
+ (throw 'found t))
+ ))
+ ((eq (car path) 'never)
+ (throw 'found nil))
+ ((eq (car path) 'always)
+ (throw 'found t))
+ (t (error "Invalid path %S" (car path))))
+ (setq path (cdr path)))
+ (call-next-method))
+ ))
+
+;;; Filename manipulation
+;;
+(defmethod semanticdb-file-table ((obj semanticdb-project-database-file)
filename)
+ "From OBJ, return FILENAME's associated table object."
+ ;; Cheater option. In this case, we always have files directly
+ ;; under ourselves. The main project type may not.
+ (object-assoc (file-name-nondirectory filename) 'file (oref obj tables)))
+
+(defmethod semanticdb-file-name-non-directory :STATIC
+ ((dbclass semanticdb-project-database-file))
+ "Return the file name DBCLASS will use.
+File name excludes any directory part."
+ semanticdb-default-file-name)
+
+(defmethod semanticdb-file-name-directory :STATIC
+ ((dbclass semanticdb-project-database-file) directory)
+ "Return the relative directory to where DBCLASS will save its cache file.
+The returned path is related to DIRECTORY."
+ (if semanticdb-default-save-directory
+ (let ((file (cedet-directory-name-to-file-name directory)))
+ ;; Now create a filename for the cache file in
+ ;; ;`semanticdb-default-save-directory'.
+ (expand-file-name
+ file (file-name-as-directory semanticdb-default-save-directory)))
+ directory))
+
+(defmethod semanticdb-cache-filename :STATIC
+ ((dbclass semanticdb-project-database-file) path)
+ "For DBCLASS, return a file to a cache file belonging to PATH.
+This could be a cache file in the current directory, or an encoded file
+name in a secondary directory."
+ ;; Use concat and not expand-file-name, because the dir part
+ ;; may include some of the file name.
+ (concat (semanticdb-file-name-directory dbclass path)
+ (semanticdb-file-name-non-directory dbclass)))
+
+(defmethod semanticdb-full-filename ((obj semanticdb-project-database-file))
+ "Fetch the full filename that OBJ refers to."
+ (oref obj file))
+
+;;; FLUSH OLD FILES
+;;
+(defun semanticdb-cleanup-cache-files (&optional noerror)
+ "Cleanup any cache files associated with directories that no longer exist.
+Optional NOERROR prevents errors from being displayed."
+ (interactive)
+ (when (and (not semanticdb-default-save-directory)
+ (not noerror))
+ (error "No default save directory for semantic-save files"))
+
+ (when semanticdb-default-save-directory
+
+ ;; Calculate all the cache files we have.
+ (let* ((regexp (regexp-quote semanticdb-default-file-name))
+ (files (directory-files semanticdb-default-save-directory
+ t regexp))
+ (orig nil)
+ (to-delete nil))
+ (dolist (F files)
+ (setq orig (cedet-file-name-to-directory-name
+ (file-name-nondirectory F)))
+ (when (not (file-exists-p (file-name-directory orig)))
+ (setq to-delete (cons F to-delete))
+ ))
+ (if to-delete
+ (save-window-excursion
+ (let ((buff (get-buffer-create "*Semanticdb Delete*")))
+ (with-current-buffer buff
+ (erase-buffer)
+ (insert "The following Cache files appear to be obsolete.\n\n")
+ (dolist (F to-delete)
+ (insert F "\n")))
+ (pop-to-buffer buff t t)
+ (fit-window-to-buffer (get-buffer-window buff) nil 1)
+ (when (y-or-n-p "Delete Old Cache Files? ")
+ (mapc (lambda (F)
+ (message "Deleting to %s..." F)
+ (delete-file F))
+ to-delete)
+ (message "done."))
+ ))
+ ;; No files to delete
+ (when (not noerror)
+ (message "No obsolete semanticdb.cache files."))
+ ))))
+
+(provide 'semantic/db-file)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/db-file"
+;; End:
+
+;;; semantic/db-file.el ends here
Index: cedet/semantic/db-find.el
===================================================================
RCS file: cedet/semantic/db-find.el
diff -N cedet/semantic/db-find.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/db-find.el 28 Sep 2009 15:15:07 -0000 1.2
@@ -0,0 +1,1373 @@
+;;; semantic/db-find.el --- Searching through semantic databases.
+
+;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;;; 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: tags
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Databases of various forms can all be searched.
+;; There are a few types of searches that can be done:
+;;
+;; Basic Name Search:
+;; These searches scan a database table collection for tags based
+;; on name.
+;;
+;; Basic Attribute Search:
+;; These searches allow searching on specific attributes of tags,
+;; such as name, type, or other attribute.
+;;
+;; Advanced Search:
+;; These are searches that were needed to accomplish some
+;; specialized tasks as discovered in utilities. Advanced searches
+;; include matching methods defined outside some parent class.
+;;
+;; The reason for advanced searches are so that external
+;; repositories such as the Emacs obarray, or java .class files can
+;; quickly answer these needed questions without dumping the entire
+;; symbol list into Emacs for additional refinement searches via
+;; regular semanticdb search.
+;;
+;; How databases are decided upon is another important aspect of a
+;; database search. When it comes to searching for a name, there are
+;; these types of searches:
+;;
+;; Basic Search:
+;; Basic search means that tags looking for a given name start
+;; with a specific search path. Names are sought on that path
+;; until it is empty or items on the path can no longer be found.
+;; Use `semanticdb-dump-all-table-summary' to test this list.
+;; Use `semanticdb-find-throttle-custom-list' to refine this list.
+;;
+;; Deep Search:
+;; A deep search will search more than just the global namespace.
+;; It will recurse into tags that contain more tags, and search
+;; those too.
+;;
+;; Brute Search:
+;; Brute search means that all tables in all databases in a given
+;; project are searched. Brute searches are the search style as
+;; written for semantic version 1.x.
+;;
+;; How does the search path work?
+;;
+;; A basic search starts with three parameters:
+;;
+;; (FINDME &optional PATH FIND-FILE-MATCH)
+;;
+;; FINDME is key to be searched for dependent on the type of search.
+;; PATH is an indicator of which tables are to be searched.
+;; FIND-FILE-MATCH indicates that any time a match is found, the
+;; file associated with the tag should be read into a file.
+;;
+;; The PATH argument is then the most interesting argument. It can
+;; have these values:
+;;
+;; nil - Take the current buffer, and use it's include list
+;; buffer - Use that buffer's include list.
+;; filename - Use that file's include list. If the file is not
+;; in a buffer, see of there is a semanticdb table for it. If
+;; not, read that file into a buffer.
+;; tag - Get that tag's buffer of file file. See above.
+;; table - Search that table, and it's include list.
+;;
+;; Search Results:
+;;
+;; Semanticdb returns the results in a specific format. There are a
+;; series of routines for using those results, and results can be
+;; passed in as a search-path for refinement searches with
+;; semanticdb. Apropos for semanticdb.*find-result for more.
+;;
+;; Application:
+;;
+;; Here are applications where different searches are needed which
+;; exist as of semantic 1.4.x
+;;
+;; eldoc - popup help
+;; => Requires basic search using default path. (Header files ok)
+;; tag jump - jump to a named tag
+;; => Requires a brute search useing whole project. (Source files only)
+;; completion - Completing symbol names in a smart way
+;; => Basic search (headers ok)
+;; type analysis - finding type definitions for variables & fcns
+;; => Basic search (headers ok)
+;; Class browser - organize types into some structure
+;; => Brute search, or custom navigation.
+
+;; TODO:
+;; During a search, load any unloaded DB files based on paths in the
+;; current project.
+
+(require 'semantic/db)
+(require 'semantic/db-ref)
+(eval-when-compile
+ (require 'semantic/find))
+
+;;; Code:
+
+(defvar data-debug-thing-alist)
+(declare-function data-debug-insert-stuff-list "data-debug")
+(declare-function data-debug-insert-tag-list "data-debug")
+(declare-function semantic-scope-reset-cache "semantic/scope")
+(declare-function semanticdb-typecache-notify-reset "semantic/db-typecache")
+(declare-function ede-current-project "ede")
+
+(defvar semanticdb-find-throttle-custom-list
+ '(repeat (radio (const 'local)
+ (const 'project)
+ (const 'unloaded)
+ (const 'system)
+ (const 'recursive)
+ (const 'omniscience)))
+ "Customization values for semanticdb find throttle.
+See `semanticdb-find-throttle' for details.")
+
+;;;###autoload
+(defcustom semanticdb-find-default-throttle
+ '(local project unloaded system recursive)
+ "The default throttle for `semanticdb-find' routines.
+The throttle controls how detailed the list of database
+tables is for a symbol lookup. The value is a list with
+the following keys:
+ `file' - The file the search is being performed from.
+ This option is here for completeness only, and
+ is assumed to always be on.
+ `local' - Tables from the same local directory are included.
+ This includes files directly referenced by a file name
+ which might be in a different directory.
+ `project' - Tables from the same local project are included
+ If `project' is specified, then `local' is assumed.
+ `unloaded' - If a table is not in memory, load it. If it is not cached
+ on disk either, get the source, parse it, and create
+ the table.
+ `system' - Tables from system databases. These are specifically
+ tables from system header files, or language equivalent.
+ `recursive' - For include based searches, includes tables referenced
+ by included files.
+ `omniscience' - Included system databases which are omniscience, or
+ somehow know everything. Omniscience databases are found
+ in `semanticdb-project-system-databases'.
+ The Emacs Lisp system DB is an omniscience database."
+ :group 'semanticdb
+ :type semanticdb-find-throttle-custom-list)
+
+(defun semanticdb-find-throttle-active-p (access-type)
+ "Non-nil if ACCESS-TYPE is an active throttle type."
+ (or (memq access-type semanticdb-find-default-throttle)
+ (eq access-type 'file)
+ (and (eq access-type 'local)
+ (memq 'project semanticdb-find-default-throttle))
+ ))
+
+;;; Index Class
+;;
+;; The find routines spend a lot of time looking stuff up.
+;; Use this handy search index to cache data between searches.
+;; This should allow searches to start running faster.
+(defclass semanticdb-find-search-index (semanticdb-abstract-search-index)
+ ((include-path :initform nil
+ :documentation
+ "List of semanticdb tables from the include path.")
+ (type-cache :initform nil
+ :documentation
+ "Cache of all the data types accessible from this file.
+Includes all types from all included files, merged namespaces, and
+expunge duplicates.")
+ )
+ "Concrete search index for `semanticdb-find'.
+This class will cache data derived during various searches.")
+
+(defmethod semantic-reset ((idx semanticdb-find-search-index))
+ "Reset the object IDX."
+ (require 'semantic/scope)
+ ;; Clear the include path.
+ (oset idx include-path nil)
+ (when (oref idx type-cache)
+ (semantic-reset (oref idx type-cache)))
+ ;; Clear the scope. Scope doesn't have the data it needs to track
+ ;; it's own reset.
+ (semantic-scope-reset-cache)
+ )
+
+(defmethod semanticdb-synchronize ((idx semanticdb-find-search-index)
+ new-tags)
+ "Synchronize the search index IDX with some NEW-TAGS."
+ ;; Reset our parts.
+ (semantic-reset idx)
+ ;; Notify dependants by clearning their indicies.
+ (semanticdb-notify-references
+ (oref idx table)
+ (lambda (tab me)
+ (semantic-reset (semanticdb-get-table-index tab))))
+ )
+
+(defmethod semanticdb-partial-synchronize ((idx semanticdb-find-search-index)
+ new-tags)
+ "Synchronize the search index IDX with some changed NEW-TAGS."
+ ;; Only reset if include statements changed.
+ (if (semantic-find-tags-by-class 'include new-tags)
+ (progn
+ (semantic-reset idx)
+ ;; Notify dependants by clearning their indicies.
+ (semanticdb-notify-references
+ (oref idx table)
+ (lambda (tab me)
+ (semantic-reset (semanticdb-get-table-index tab))))
+ )
+ ;; Else, not an include, by just a type.
+ (when (oref idx type-cache)
+ (when (semanticdb-partial-synchronize (oref idx type-cache) new-tags)
+ ;; If the synchronize returns true, we need to notify.
+ ;; Notify dependants by clearning their indicies.
+ (semanticdb-notify-references
+ (oref idx table)
+ (lambda (tab me)
+ (let ((tab-idx (semanticdb-get-table-index tab)))
+ ;; Not a full reset?
+ (when (oref tab-idx type-cache)
+ (require 'db-typecache)
+ (semanticdb-typecache-notify-reset
+ (oref tab-idx type-cache)))
+ )))
+ ))
+ ))
+
+
+;;; Path Translations
+;;
+;;; OVERLOAD Functions
+;;
+;; These routines needed to be overloaded by specific language modes.
+;; They are needed for translating an INCLUDE tag into a semanticdb
+;; TABLE object.
+;;;###autoload
+(define-overloadable-function semanticdb-find-translate-path (path brutish)
+ "Translate PATH into a list of semantic tables.
+Path translation involves identifying the PATH input argument
+in one of the following ways:
+ nil - Take the current buffer, and use it's include list
+ buffer - Use that buffer's include list.
+ filename - Use that file's include list. If the file is not
+ in a buffer, see of there is a semanticdb table for it. If
+ not, read that file into a buffer.
+ tag - Get that tag's buffer of file file. See above.
+ table - Search that table, and it's include list.
+ find result - Search the results of a previous find.
+
+In addition, once the base path is found, there is the possibility of
+each added table adding yet more tables to the path, so this routine
+can return a lengthy list.
+
+If argument BRUTISH is non-nil, then instead of using the include
+list, use all tables found in the parent project of the table
+identified by translating PATH. Such searches use brute force to
+scan every available table.
+
+The return value is a list of objects of type `semanticdb-table' or
+it's children. In the case of passing in a find result, the result
+is returned unchanged.
+
+This routine uses `semanticdb-find-table-for-include' to translate
+specific include tags into a semanticdb table.
+
+Note: When searching using a non-brutish method, the list of
+included files will be cached between runs. Database-references
+are used to track which files need to have their include lists
+refreshed when things change. See `semanticdb-ref-test'.
+
+Note for overloading: If you opt to overload this function for your
+major mode, and your routine takes a long time, be sure to call
+
+ (semantic-throw-on-input 'your-symbol-here)
+
+so that it can be called from the idle work handler."
+ )
+
+(defun semanticdb-find-translate-path-default (path brutish)
+ "Translate PATH into a list of semantic tables.
+If BRUTISH is non nil, return all tables associated with PATH.
+Default action as described in `semanticdb-find-translate-path'."
+ (if (semanticdb-find-results-p path)
+ ;; nil means perform the search over these results.
+ nil
+ (if brutish
+ (semanticdb-find-translate-path-brutish-default path)
+ (semanticdb-find-translate-path-includes-default path))))
+
+;;;###autoload
+(define-overloadable-function semanticdb-find-table-for-include (includetag
&optional table)
+ "For a single INCLUDETAG found in TABLE, find a `semanticdb-table' object
+INCLUDETAG is a semantic TAG of class 'include.
+TABLE is a semanticdb table that identifies where INCLUDETAG came from.
+TABLE is optional if INCLUDETAG has an overlay of :filename attribute."
+ )
+
+(defun semanticdb-find-translate-path-brutish-default (path)
+ "Translate PATH into a list of semantic tables.
+Default action as described in `semanticdb-find-translate-path'."
+ (let ((basedb
+ (cond ((null path) semanticdb-current-database)
+ ((semanticdb-table-p path) (oref path parent-db))
+ (t (let ((tt (semantic-something-to-tag-table path)))
+ (save-excursion
+ ;; @todo - What does this DO ??!?!
+ (set-buffer (semantic-tag-buffer (car tt)))
+ semanticdb-current-database))))))
+ (apply
+ #'nconc
+ (mapcar
+ (lambda (db)
+ (let ((tabs (semanticdb-get-database-tables db))
+ (ret nil))
+ ;; Only return tables of the same language (major-mode)
+ ;; as the current search environment.
+ (while tabs
+
+ (semantic-throw-on-input 'translate-path-brutish)
+
+ (if (semanticdb-equivalent-mode-for-search (car tabs)
+ (current-buffer))
+ (setq ret (cons (car tabs) ret)))
+ (setq tabs (cdr tabs)))
+ ret))
+ ;; FIXME:
+ ;; This should scan the current project directory list for all
+ ;; semanticdb files, perhaps handling proxies for them.
+ (semanticdb-current-database-list
+ (if basedb (oref basedb reference-directory)
+ default-directory))))
+ ))
+
+(defun semanticdb-find-incomplete-cache-entries-p (cache)
+ "Are there any incomplete entries in CACHE?"
+ (let ((ans nil))
+ (dolist (tab cache)
+ (when (and (semanticdb-table-child-p tab)
+ (not (number-or-marker-p (oref tab pointmax))))
+ (setq ans t))
+ )
+ ans))
+
+(defun semanticdb-find-need-cache-update-p (table)
+ "Non nil if the semanticdb TABLE cache needs to be updated."
+ ;; If we were passed in something related to a TABLE,
+ ;; do a caching lookup.
+ (let* ((index (semanticdb-get-table-index table))
+ (cache (when index (oref index include-path)))
+ (incom (semanticdb-find-incomplete-cache-entries-p cache))
+ (unl (semanticdb-find-throttle-active-p 'unloaded))
+ )
+ (if (and
+ cache ;; Must have a cache
+ (or
+ ;; If all entries are "full", or if 'unloaded
+ ;; OR
+ ;; is not in the throttle, it is ok to use the cache.
+ (not incom) (not unl)
+ ))
+ nil
+ ;;cache
+ ;; ELSE
+ ;;
+ ;; We need an update.
+ t))
+ )
+
+(defun semanticdb-find-translate-path-includes-default (path)
+ "Translate PATH into a list of semantic tables.
+Default action as described in `semanticdb-find-translate-path'."
+ (let ((table (cond ((null path)
+ semanticdb-current-table)
+ ((bufferp path)
+ (semantic-buffer-local-value 'semanticdb-current-table
path))
+ ((and (stringp path) (file-exists-p path))
+ (semanticdb-file-table-object path t))
+ ((semanticdb-abstract-table-child-p path)
+ path)
+ (t nil))))
+ (if table
+ ;; If we were passed in something related to a TABLE,
+ ;; do a caching lookup.
+ (let ((index (semanticdb-get-table-index table)))
+ (if (semanticdb-find-need-cache-update-p table)
+ ;; Lets go look up our indicies
+ (let ((ans (semanticdb-find-translate-path-includes--internal
path)))
+ (oset index include-path ans)
+ ;; Once we have our new indicies set up, notify those
+ ;; who depend on us if we found something for them to
+ ;; depend on.
+ (when ans (semanticdb-refresh-references table))
+ ans)
+ ;; ELSE
+ ;;
+ ;; Just return the cache.
+ (oref index include-path)))
+ ;; If we were passed in something like a tag list, or other boring
+ ;; searchable item, then instead do the regular thing without caching.
+ (semanticdb-find-translate-path-includes--internal path))))
+
+(defvar semanticdb-find-lost-includes nil
+ "Include files that we cannot find associated with this buffer.")
+(make-variable-buffer-local 'semanticdb-find-lost-includes)
+
+(defvar semanticdb-find-scanned-include-tags nil
+ "All include tags scanned, plus action taken on the tag.
+Each entry is an alist:
+ (ACTION . TAG)
+where ACTION is one of 'scanned, 'duplicate, 'lost.
+and TAG is a clone of the include tag that was found.")
+(make-variable-buffer-local 'semanticdb-find-scanned-include-tags)
+
+(defvar semanticdb-implied-include-tags nil
+ "Include tags implied for all files of a given mode.
+Set this variable with `defvar-mode-local' for a particular mode so
+that any symbols that exist for all files for that mode are included.
+
+Note: This could be used as a way to write a file in a langauge
+to declare all the built-ins for that language.")
+
+(defun semanticdb-find-translate-path-includes--internal (path)
+ "Internal implementation of
`semanticdb-find-translate-path-includes-default'.
+This routine does not depend on the cache, but will always derive
+a new path from the provided PATH."
+ (let ((includetags nil)
+ (curtable nil)
+ (matchedtables (list semanticdb-current-table))
+ (matchedincludes nil)
+ (lostincludes nil)
+ (scannedincludes nil)
+ (incfname nil)
+ nexttable)
+ (cond ((null path)
+ (semantic-refresh-tags-safe)
+ (setq includetags (append
+ (semantic-find-tags-included (current-buffer))
+ semanticdb-implied-include-tags)
+ curtable semanticdb-current-table
+ incfname (buffer-file-name))
+ )
+ ((semanticdb-table-p path)
+ (setq includetags (semantic-find-tags-included path)
+ curtable path
+ incfname (semanticdb-full-filename path))
+ )
+ ((bufferp path)
+ (save-excursion
+ (set-buffer path)
+ (semantic-refresh-tags-safe))
+ (setq includetags (semantic-find-tags-included path)
+ curtable (save-excursion (set-buffer path)
+ semanticdb-current-table)
+ incfname (buffer-file-name path)))
+ (t
+ (setq includetags (semantic-find-tags-included path))
+ (when includetags
+ ;; If we have some tags, derive a table from them.
+ ;; else we will do nothing, so the table is useless.
+
+ ;; @todo - derive some tables
+ (message "Need to derive tables for %S in
translate-path-includes--default."
+ path)
+ )))
+
+ ;; Make sure each found include tag has an originating file name associated
+ ;; with it.
+ (when incfname
+ (dolist (it includetags)
+ (semantic--tag-put-property it :filename incfname)))
+
+ ;; Loop over all include tags adding to matchedtables
+ (while includetags
+ (semantic-throw-on-input 'semantic-find-translate-path-includes-default)
+
+ ;; If we've seen this include string before, lets skip it.
+ (if (member (semantic-tag-name (car includetags)) matchedincludes)
+ (progn
+ (setq nexttable nil)
+ (push (cons 'duplicate (semantic-tag-clone (car includetags)))
+ scannedincludes)
+ )
+ (setq nexttable (semanticdb-find-table-for-include (car includetags)
curtable))
+ (when (not nexttable)
+ ;; Save the lost include.
+ (push (car includetags) lostincludes)
+ (push (cons 'lost (semantic-tag-clone (car includetags)))
+ scannedincludes)
+ )
+ )
+
+ ;; Push the include file, so if we can't find it, we only
+ ;; can't find it once.
+ (push (semantic-tag-name (car includetags)) matchedincludes)
+
+ ;; (message "Scanning %s" (semantic-tag-name (car includetags)))
+ (when (and nexttable
+ (not (memq nexttable matchedtables))
+ (semanticdb-equivalent-mode-for-search nexttable
+ (current-buffer))
+ )
+ ;; Add to list of tables
+ (push nexttable matchedtables)
+
+ ;; Queue new includes to list
+ (if (semanticdb-find-throttle-active-p 'recursive)
+ ;; @todo - recursive includes need to have the originating
+ ;; buffer's location added to the path.
+ (let ((newtags
+ (cond
+ ((semanticdb-table-p nexttable)
+ (semanticdb-refresh-table nexttable)
+ ;; Use the method directly, or we will recurse
+ ;; into ourselves here.
+ (semanticdb-find-tags-by-class-method
+ nexttable 'include))
+ (t ;; @todo - is this ever possible???
+ (message "semanticdb-ftp - how did you do that?")
+ (semantic-find-tags-included
+ (semanticdb-get-tags nexttable)))
+ ))
+ (newincfname (semanticdb-full-filename nexttable))
+ )
+
+ (push (cons 'scanned (semantic-tag-clone (car includetags)))
+ scannedincludes)
+
+ ;; Setup new tags so we know where they are.
+ (dolist (it newtags)
+ (semantic--tag-put-property it :filename
+ newincfname))
+
+ (setq includetags (nconc includetags newtags)))
+ ;; ELSE - not recursive throttle
+ (push (cons 'scanned-no-recurse
+ (semantic-tag-clone (car includetags)))
+ scannedincludes)
+ )
+ )
+ (setq includetags (cdr includetags)))
+
+ (setq semanticdb-find-lost-includes lostincludes)
+ (setq semanticdb-find-scanned-include-tags (reverse scannedincludes))
+
+ ;; Find all the omniscient databases for this major mode, and
+ ;; add them if needed
+ (when (and (semanticdb-find-throttle-active-p 'omniscience)
+ semanticdb-search-system-databases)
+ ;; We can append any mode-specific omniscience databases into
+ ;; our search list here.
+ (let ((systemdb semanticdb-project-system-databases)
+ (ans nil))
+ (while systemdb
+ (setq ans (semanticdb-file-table
+ (car systemdb)
+ ;; I would expect most omniscient to return the same
+ ;; thing reguardless of filename, but we may have
+ ;; one that can return a table of all things the
+ ;; current file needs.
+ (buffer-file-name (current-buffer))))
+ (when (not (memq ans matchedtables))
+ (setq matchedtables (cons ans matchedtables)))
+ (setq systemdb (cdr systemdb))))
+ )
+ (nreverse matchedtables)))
+
+(define-overloadable-function semanticdb-find-load-unloaded (filename)
+ "Create a database table for FILENAME if it hasn't been parsed yet.
+Assumes that FILENAME exists as a source file.
+Assumes that a preexisting table does not exist, even if it
+isn't in memory yet."
+ (if (semanticdb-find-throttle-active-p 'unloaded)
+ (:override)
+ (semanticdb-file-table-object filename t)))
+
+(defun semanticdb-find-load-unloaded-default (filename)
+ "Load an unloaded file in FILENAME using the default semanticdb loader."
+ (semanticdb-file-table-object filename))
+
+;; The creation of the overload occurs above.
+(defun semanticdb-find-table-for-include-default (includetag &optional table)
+ "Default implementation of `semanticdb-find-table-for-include'.
+Uses `semanticdb-current-database-list' as the search path.
+INCLUDETAG and TABLE are documented in `semanticdb-find-table-for-include'.
+Included databases are filtered based on `semanticdb-find-default-throttle'."
+ (if (not (eq (semantic-tag-class includetag) 'include))
+ (signal 'wrong-type-argument (list includetag 'include)))
+
+ (let ((name
+ ;; Note, some languages (like Emacs or Java) use include tag names
+ ;; that don't represent files! We want to have file names.
+ (semantic-tag-include-filename includetag))
+ (originfiledir nil)
+ (roots nil)
+ (tmp nil)
+ (ans nil))
+
+ ;; INCLUDETAG should have some way to reference where it came
+ ;; from! If not, TABLE should provide the way. Each time we
+ ;; look up a tag, we may need to find it in some relative way
+ ;; and must set our current buffer eto the origin of includetag
+ ;; or nothing may work.
+ (setq originfiledir
+ (cond ((semantic-tag-file-name includetag)
+ ;; A tag may have a buffer, or a :filename property.
+ (file-name-directory (semantic-tag-file-name includetag)))
+ (table
+ (file-name-directory (semanticdb-full-filename table)))
+ (t
+ ;; @todo - what to do here? Throw an error maybe
+ ;; and fix usage bugs?
+ default-directory)))
+
+ (cond
+ ;; Step 1: Relative path name
+ ;;
+ ;; If the name is relative, then it should be findable as relative
+ ;; to the source file that this tag originated in, and be fast.
+ ;;
+ ((and (semanticdb-find-throttle-active-p 'local)
+ (file-exists-p (expand-file-name name originfiledir)))
+
+ (setq ans (semanticdb-find-load-unloaded
+ (expand-file-name name originfiledir)))
+ )
+ ;; Step 2: System or Project level includes
+ ;;
+ ((or
+ ;; First, if it a system include, we can investigate that tags
+ ;; dependency file
+ (and (semanticdb-find-throttle-active-p 'system)
+
+ ;; Sadly, not all languages make this distinction.
+ ;;(semantic-tag-include-system-p includetag)
+
+ ;; Here, we get local and system files.
+ (setq tmp (semantic-dependency-tag-file includetag))
+ )
+ ;; Second, project files are active, we and we have EDE,
+ ;; we can find it using the same tool.
+ (and (semanticdb-find-throttle-active-p 'project)
+ ;; Make sure EDE is available, and we have a project
+ (featurep 'ede) (ede-current-project originfiledir)
+ ;; The EDE query is hidden in this call.
+ (setq tmp (semantic-dependency-tag-file includetag))
+ )
+ )
+ (setq ans (semanticdb-find-load-unloaded tmp))
+ )
+ ;; Somewhere in our project hierarchy
+ ;;
+ ;; Remember: Roots includes system databases which can create
+ ;; specialized tables we can search.
+ ;;
+ ;; NOTE: Not used if EDE is active!
+ ((and (semanticdb-find-throttle-active-p 'project)
+ ;; And dont do this if it is a system include. Not supported by all
languages,
+ ;; but when it is, this is a nice fast way to skip this step.
+ (not (semantic-tag-include-system-p includetag))
+ ;; Don't do this if we have an EDE project.
+ (not (and (featurep 'ede)
+ ;; Note: We don't use originfiledir here because
+ ;; we want to know about the source file we are
+ ;; starting from.
+ (ede-current-project)))
+ )
+
+ (setq roots (semanticdb-current-database-list))
+
+ (while (and (not ans) roots)
+ (let* ((ref (if (slot-boundp (car roots) 'reference-directory)
+ (oref (car roots) reference-directory)))
+ (fname (cond ((null ref) nil)
+ ((file-exists-p (expand-file-name name ref))
+ (expand-file-name name ref))
+ ((file-exists-p (expand-file-name
(file-name-nondirectory name) ref))
+ (expand-file-name (file-name-nondirectory name)
ref)))))
+ (when (and ref fname)
+ ;; There is an actual file. Grab it.
+ (setq ans (semanticdb-find-load-unloaded fname)))
+
+ ;; ELSE
+ ;;
+ ;; NOTE: We used to look up omniscient databases here, but that
+ ;; is now handled one layer up.
+ ;;
+ ;; Missing: a database that knows where missing files are. Hmm.
+ ;; perhaps I need an override function for that?
+
+ )
+
+ (setq roots (cdr roots))))
+ )
+ ans))
+
+
+;;; Perform interactive tests on the path/search mechanisms.
+;;
+;;;###autoload
+(defun semanticdb-find-test-translate-path (&optional arg)
+ "Call and output results of `semanticdb-find-translate-path'.
+With ARG non-nil, specify a BRUTISH translation.
+See `semanticdb-find-default-throttle' and `semanticdb-project-roots'
+for details on how this list is derived."
+ (interactive "P")
+ (semantic-fetch-tags)
+ (require 'data-debug)
+ (let ((start (current-time))
+ (p (semanticdb-find-translate-path nil arg))
+ (end (current-time))
+ )
+ (data-debug-new-buffer "*SEMANTICDB FTP ADEBUG*")
+ (message "Search of tags took %.2f seconds."
+ (semantic-elapsed-time start end))
+
+ (data-debug-insert-stuff-list p "*")))
+
+(defun semanticdb-find-test-translate-path-no-loading (&optional arg)
+ "Call and output results of `semanticdb-find-translate-path'.
+With ARG non-nil, specify a BRUTISH translation.
+See `semanticdb-find-default-throttle' and `semanticdb-project-roots'
+for details on how this list is derived."
+ (interactive "P")
+ (semantic-fetch-tags)
+ (require 'data-debug)
+ (let* ((semanticdb-find-default-throttle
+ (if (featurep 'semantic/db-find)
+ (remq 'unloaded semanticdb-find-default-throttle)
+ nil))
+ (start (current-time))
+ (p (semanticdb-find-translate-path nil arg))
+ (end (current-time))
+ )
+ (data-debug-new-buffer "*SEMANTICDB FTP ADEBUG*")
+ (message "Search of tags took %.2f seconds."
+ (semantic-elapsed-time start end))
+
+ (data-debug-insert-stuff-list p "*")))
+
+;;;###autoload
+(defun semanticdb-find-adebug-lost-includes ()
+ "Translate the current path, then display the lost includes.
+Examines the variable `semanticdb-find-lost-includes'."
+ (interactive)
+ (require 'data-debug)
+ (semanticdb-find-translate-path nil nil)
+ (let ((lost semanticdb-find-lost-includes)
+ )
+
+ (if (not lost)
+ (message "There are no unknown includes for %s"
+ (buffer-name))
+
+ (data-debug-new-buffer "*SEMANTICDB lost-includes ADEBUG*")
+ (data-debug-insert-tag-list lost "*")
+ )))
+
+(defun semanticdb-find-adebug-insert-scanned-tag-cons (consdata prefix
prebuttontext)
+ "Insert a button representing scanned include CONSDATA.
+PREFIX is the text that preceeds the button.
+PREBUTTONTEXT is some text between prefix and the overlay button."
+ (let* ((start (point))
+ (end nil)
+ (mode (car consdata))
+ (tag (cdr consdata))
+ (name (semantic-tag-name tag))
+ (file (semantic-tag-file-name tag))
+ (str1 (format "%S %s" mode name))
+ (str2 (format " : %s" file))
+ (tip nil))
+ (insert prefix prebuttontext str1)
+ (setq end (point))
+ (insert str2)
+ (put-text-property start end 'face
+ (cond ((eq mode 'scanned)
+ 'font-lock-function-name-face)
+ ((eq mode 'duplicate)
+ 'font-lock-comment-face)
+ ((eq mode 'lost)
+ 'font-lock-variable-name-face)
+ ((eq mode 'scanned-no-recurse)
+ 'font-lock-type-face)))
+ (put-text-property start end 'ddebug (cdr consdata))
+ (put-text-property start end 'ddebug-indent(length prefix))
+ (put-text-property start end 'ddebug-prefix prefix)
+ (put-text-property start end 'help-echo tip)
+ (put-text-property start end 'ddebug-function
+ 'data-debug-insert-tag-parts-from-point)
+ (insert "\n")
+ )
+ )
+
+(defun semanticdb-find-adebug-scanned-includes ()
+ "Translate the current path, then display the lost includes.
+Examines the variable `semanticdb-find-lost-includes'."
+ (interactive)
+ (require 'data-debug)
+ (semanticdb-find-translate-path nil nil)
+ (let ((scanned semanticdb-find-scanned-include-tags)
+ (data-debug-thing-alist
+ (cons
+ '((lambda (thing) (and (consp thing)
+ (symbolp (car thing))
+ (memq (car thing)
+ '(scanned scanned-no-recurse
+ lost duplicate))))
+ . semanticdb-find-adebug-insert-scanned-tag-cons)
+ data-debug-thing-alist))
+ )
+
+ (if (not scanned)
+ (message "There are no includes scanned %s"
+ (buffer-name))
+
+ (data-debug-new-buffer "*SEMANTICDB scanned-includes ADEBUG*")
+ (data-debug-insert-stuff-list scanned "*")
+ )))
+
+;;; API Functions
+;;
+;; Once you have a search result, use these routines to operate
+;; on the search results at a higher level
+
+;;;###autoload
+(defun semanticdb-strip-find-results (results &optional find-file-match)
+ "Strip a semanticdb search RESULTS to exclude objects.
+This makes it appear more like the results of a `semantic-find-' call.
+Optional FIND-FILE-MATCH loads all files associated with RESULTS
+into buffers. This has the side effect of enabling `semantic-tag-buffer' to
+return a value.
+If FIND-FILE-MATCH is 'name, then only the filename is stored
+in each tag instead of loading each file into a buffer.
+If the input RESULTS are not going to be used again, and if
+FIND-FILE-MATCH is nil, you can use `semanticdb-fast-strip-find-results'
+instead."
+ (if find-file-match
+ ;; Load all files associated with RESULTS.
+ (let ((tmp results)
+ (output nil))
+ (while tmp
+ (let ((tab (car (car tmp)))
+ (tags (cdr (car tmp))))
+ (dolist (T tags)
+ ;; Normilzation gives specialty database tables a chance
+ ;; to convert into a more stable tag format.
+ (let* ((norm (semanticdb-normalize-one-tag tab T))
+ (ntab (car norm))
+ (ntag (cdr norm))
+ (nametable ntab))
+
+ ;; If it didn't normalize, use what we had.
+ (if (not norm)
+ (setq nametable tab)
+ (setq output (append output (list ntag))))
+
+ ;; Find-file-match allows a tool to make sure the tag is
+ ;; 'live', somewhere in a buffer.
+ (cond ((eq find-file-match 'name)
+ (let ((f (semanticdb-full-filename nametable)))
+ (semantic--tag-put-property ntag :filename f)))
+ ((and find-file-match ntab)
+ (semanticdb-get-buffer ntab))
+ )
+ ))
+ )
+ (setq tmp (cdr tmp)))
+ output)
+ ;; @todo - I could use nconc, but I don't know what the caller may do with
+ ;; RESULTS after this is called. Right now semantic-complete will
+ ;; recycling the input after calling this routine.
+ (apply #'append (mapcar #'cdr results))))
+
+(defun semanticdb-fast-strip-find-results (results)
+ "Destructively strip a semanticdb search RESULTS to exclude objects.
+This makes it appear more like the results of a `semantic-find-' call.
+This is like `semanticdb-strip-find-results', except the input list RESULTS
+will be changed."
+ (apply #'nconc (mapcar #'cdr results)))
+
+(defun semanticdb-find-results-p (resultp)
+ "Non-nil if RESULTP is in the form of a semanticdb search result.
+This query only really tests the first entry in the list that is RESULTP,
+but should be good enough for debugging assertions."
+ (and (listp resultp)
+ (listp (car resultp))
+ (semanticdb-abstract-table-child-p (car (car resultp)))
+ (or (semantic-tag-p (car (cdr (car resultp))))
+ (null (car (cdr (car resultp)))))))
+
+(defun semanticdb-find-result-prin1-to-string (result)
+ "Presuming RESULT satisfies `semanticdb-find-results-p', provide a short
PRIN1 output."
+ (if (< (length result) 2)
+ (concat "#<FIND RESULT "
+ (mapconcat (lambda (a)
+ (concat "(" (object-name (car a) ) " . "
+ "#<TAG LIST " (number-to-string (length (cdr
a))) ">)"))
+ result
+ " ")
+ ">")
+ ;; Longer results should have an abreviated form.
+ (format "#<FIND RESULT %d TAGS in %d FILES>"
+ (semanticdb-find-result-length result)
+ (length result))))
+
+(defun semanticdb-find-result-with-nil-p (resultp)
+ "Non-nil of RESULTP is in the form of a semanticdb search result.
+nil is a valid value where a TABLE usually is, but only if the TAG
+results include overlays.
+This query only really tests the first entry in the list that is RESULTP,
+but should be good enough for debugging assertions."
+ (and (listp resultp)
+ (listp (car resultp))
+ (let ((tag-to-test (car-safe (cdr (car resultp)))))
+ (or (and (semanticdb-abstract-table-child-p (car (car resultp)))
+ (or (semantic-tag-p tag-to-test)
+ (null tag-to-test)))
+ (and (null (car (car resultp)))
+ (or (semantic-tag-with-position-p tag-to-test)
+ (null tag-to-test))))
+ )))
+
+;;;###autoload
+(defun semanticdb-find-result-length (result)
+ "Number of tags found in RESULT."
+ (let ((count 0))
+ (mapc (lambda (onetable)
+ (setq count (+ count (1- (length onetable)))))
+ result)
+ count))
+
+;;;###autoload
+(defun semanticdb-find-result-nth (result n)
+ "In RESULT, return the Nth search result.
+This is a 0 based search result, with the first match being element 0.
+
+The returned value is a cons cell: (TAG . TABLE) where TAG
+is the tag at the Nth position. TABLE is the semanticdb table where
+the TAG was found. Sometimes TABLE can be nil."
+ (let ((ans nil)
+ (anstable nil))
+ ;; Loop over each single table hit.
+ (while (and (not ans) result)
+ ;; For each table result, get local length, and modify
+ ;; N to be that much less.
+ (let ((ll (length (cdr (car result))))) ;; local length
+ (if (> ll n)
+ ;; We have a local match.
+ (setq ans (nth n (cdr (car result)))
+ anstable (car (car result)))
+ ;; More to go. Decrement N.
+ (setq n (- n ll))))
+ ;; Keep moving.
+ (setq result (cdr result)))
+ (cons ans anstable)))
+
+(defun semanticdb-find-result-test (result)
+ "Test RESULT by accessing all the tags in the list."
+ (if (not (semanticdb-find-results-p result))
+ (error "Does not pass `semanticdb-find-results-p.\n"))
+ (let ((len (semanticdb-find-result-length result))
+ (i 0))
+ (while (< i len)
+ (let ((tag (semanticdb-find-result-nth result i)))
+ (if (not (semantic-tag-p (car tag)))
+ (error "%d entry is not a tag" i)))
+ (setq i (1+ i)))))
+
+;;;###autoload
+(defun semanticdb-find-result-nth-in-buffer (result n)
+ "In RESULT, return the Nth search result.
+Like `semanticdb-find-result-nth', except that only the TAG
+is returned, and the buffer it is found it will be made current.
+If the result tag has no position information, the originating buffer
+is still made current."
+ (let* ((ret (semanticdb-find-result-nth result n))
+ (ans (car ret))
+ (anstable (cdr ret)))
+ ;; If we have a hit, double-check the find-file
+ ;; entry. If the file must be loaded, then gat that table's
+ ;; source file into a buffer.
+
+ (if anstable
+ (let ((norm (semanticdb-normalize-one-tag anstable ans)))
+ (when norm
+ ;; The normalized tags can now be found based on that
+ ;; tags table.
+ (semanticdb-set-buffer (car norm))
+ ;; Now reset ans
+ (setq ans (cdr norm))
+ ))
+ )
+ ;; Return the tag.
+ ans))
+
+(defun semanticdb-find-result-mapc (fcn result)
+ "Apply FCN to each element of find RESULT for side-effects only.
+FCN takes two arguments. The first is a TAG, and the
+second is a DB from wence TAG originated.
+Returns result."
+ (mapc (lambda (sublst)
+ (mapc (lambda (tag)
+ (funcall fcn tag (car sublst)))
+ (cdr sublst)))
+ result)
+ result)
+
+;;; Search Logging
+;;
+;; Basic logging to see what the search routines are doing.
+(defvar semanticdb-find-log-flag nil
+ "Non-nil means log the process of searches.")
+
+(defvar semanticdb-find-log-buffer-name "*SemanticDB Find Log*"
+ "The name of the logging buffer.")
+
+(defun semanticdb-find-toggle-logging ()
+ "Toggle sematnicdb logging."
+ (interactive)
+ (setq semanticdb-find-log-flag (null semanticdb-find-log-flag))
+ (message "Semanticdb find logging is %sabled"
+ (if semanticdb-find-log-flag "en" "dis")))
+
+(defun semanticdb-reset-log ()
+ "Reset the log buffer."
+ (interactive)
+ (when semanticdb-find-log-flag
+ (save-excursion
+ (set-buffer (get-buffer-create semanticdb-find-log-buffer-name))
+ (erase-buffer)
+ )))
+
+(defun semanticdb-find-log-move-to-end ()
+ "Move to the end of the semantic log."
+ (let ((cb (current-buffer))
+ (cw (selected-window)))
+ (unwind-protect
+ (progn
+ (set-buffer semanticdb-find-log-buffer-name)
+ (if (get-buffer-window (current-buffer) 'visible)
+ (select-window (get-buffer-window (current-buffer) 'visible)))
+ (goto-char (point-max)))
+ (if cw (select-window cw))
+ (set-buffer cb))))
+
+(defun semanticdb-find-log-new-search (forwhat)
+ "Start a new search FORWHAT."
+ (when semanticdb-find-log-flag
+ (save-excursion
+ (set-buffer (get-buffer-create semanticdb-find-log-buffer-name))
+ (insert (format "New Search: %S\n" forwhat))
+ )
+ (semanticdb-find-log-move-to-end)))
+
+(defun semanticdb-find-log-activity (table result)
+ "Log that TABLE has been searched and RESULT was found."
+ (when semanticdb-find-log-flag
+ (save-excursion
+ (set-buffer semanticdb-find-log-buffer-name)
+ (insert "Table: " (object-print table)
+ " Result: " (int-to-string (length result)) " tags"
+ "\n")
+ )
+ (semanticdb-find-log-move-to-end)))
+
+;;; Semanticdb find API functions
+;; These are the routines actually used to perform searches.
+;;
+(defun semanticdb-find-tags-collector (function &optional path find-file-match
+ brutish)
+ "Collect all tags returned by FUNCTION over PATH.
+The FUNCTION must take two arguments. The first is TABLE,
+which is a semanticdb table containing tags. The second argument
+to FUNCTION is TAGS. TAGS may be a list of tags. If TAGS is non-nil, then
+FUNCTION should search the TAG list, not through TABLE.
+
+See `semanticdb-find-translate-path' for details on PATH.
+FIND-FILE-MATCH indicates that any time a match is found, the file
+associated with that tag should be loaded into a buffer.
+
+Note: You should leave FIND-FILE-MATCH as nil. It is far more
+efficient to take the results from any search and use
+`semanticdb-strip-find-results' instead. This argument is here
+for backward compatibility.
+
+If optional argument BRUTISH is non-nil, then ignore include statements,
+and search all tables in this project tree."
+ (let (found match)
+ (save-excursion
+ ;; If path is a buffer, set ourselves up in that buffer
+ ;; so that the override methods work correctly.
+ (when (bufferp path) (set-buffer path))
+ (if (semanticdb-find-results-p path)
+ ;; When we get find results, loop over that.
+ (dolist (tableandtags path)
+ (semantic-throw-on-input 'semantic-find-translate-path)
+ ;; If FIND-FILE-MATCH is non-nil, skip tables of class
+ ;; `semanticdb-search-results-table', since those are system
+ ;; databases and not associated with a file.
+ (unless (and find-file-match
+ (obj-of-class-p
+ (car tableandtags) semanticdb-search-results-table))
+ (when (setq match (funcall function
+ (car tableandtags) (cdr tableandtags)))
+ (when find-file-match
+ (save-excursion (semanticdb-set-buffer (car tableandtags))))
+ (push (cons (car tableandtags) match) found)))
+ )
+ ;; Only log searches across data bases.
+ (semanticdb-find-log-new-search nil)
+ ;; If we get something else, scan the list of tables resulting
+ ;; from translating it into a list of objects.
+ (dolist (table (semanticdb-find-translate-path path brutish))
+ (semantic-throw-on-input 'semantic-find-translate-path)
+ ;; If FIND-FILE-MATCH is non-nil, skip tables of class
+ ;; `semanticdb-search-results-table', since those are system
+ ;; databases and not associated with a file.
+ (unless (and find-file-match
+ (obj-of-class-p table semanticdb-search-results-table))
+ (when (and table (setq match (funcall function table nil)))
+ (semanticdb-find-log-activity table match)
+ (when find-file-match
+ (save-excursion (semanticdb-set-buffer table)))
+ (push (cons table match) found))))))
+ ;; At this point, FOUND has had items pushed onto it.
+ ;; This means items are being returned in REVERSE order
+ ;; of the tables searched, so if you just get th CAR, then
+ ;; too-bad, you may have some system-tag that has no
+ ;; buffer associated with it.
+
+ ;; It must be reversed.
+ (nreverse found)))
+
+;;;###autoload
+(defun semanticdb-find-tags-by-name (name &optional path find-file-match)
+ "Search for all tags matching NAME on PATH.
+See `semanticdb-find-translate-path' for details on PATH.
+FIND-FILE-MATCH indicates that any time a match is found, the file
+associated with that tag should be loaded into a buffer."
+ (semanticdb-find-tags-collector
+ (lambda (table tags)
+ (semanticdb-find-tags-by-name-method table name tags))
+ path find-file-match))
+
+;;;###autoload
+(defun semanticdb-find-tags-by-name-regexp (regexp &optional path
find-file-match)
+ "Search for all tags matching REGEXP on PATH.
+See `semanticdb-find-translate-path' for details on PATH.
+FIND-FILE-MATCH indicates that any time a match is found, the file
+associated with that tag should be loaded into a buffer."
+ (semanticdb-find-tags-collector
+ (lambda (table tags)
+ (semanticdb-find-tags-by-name-regexp-method table regexp tags))
+ path find-file-match))
+
+;;;###autoload
+(defun semanticdb-find-tags-for-completion (prefix &optional path
find-file-match)
+ "Search for all tags matching PREFIX on PATH.
+See `semanticdb-find-translate-path' for details on PATH.
+FIND-FILE-MATCH indicates that any time a match is found, the file
+associated with that tag should be loaded into a buffer."
+ (semanticdb-find-tags-collector
+ (lambda (table tags)
+ (semanticdb-find-tags-for-completion-method table prefix tags))
+ path find-file-match))
+
+;;;###autoload
+(defun semanticdb-find-tags-by-class (class &optional path find-file-match)
+ "Search for all tags of CLASS on PATH.
+See `semanticdb-find-translate-path' for details on PATH.
+FIND-FILE-MATCH indicates that any time a match is found, the file
+associated with that tag should be loaded into a buffer."
+ (semanticdb-find-tags-collector
+ (lambda (table tags)
+ (semanticdb-find-tags-by-class-method table class tags))
+ path find-file-match))
+
+;;; Deep Searches
+(defun semanticdb-deep-find-tags-by-name (name &optional path find-file-match)
+ "Search for all tags matching NAME on PATH.
+Search also in all components of top level tags founds.
+See `semanticdb-find-translate-path' for details on PATH.
+FIND-FILE-MATCH indicates that any time a match is found, the file
+associated with that tag should be loaded into a buffer."
+ (semanticdb-find-tags-collector
+ (lambda (table tags)
+ (semanticdb-deep-find-tags-by-name-method table name tags))
+ path find-file-match))
+
+(defun semanticdb-deep-find-tags-by-name-regexp (regexp &optional path
find-file-match)
+ "Search for all tags matching REGEXP on PATH.
+Search also in all components of top level tags founds.
+See `semanticdb-find-translate-path' for details on PATH.
+FIND-FILE-MATCH indicates that any time a match is found, the file
+associated with that tag should be loaded into a buffer."
+ (semanticdb-find-tags-collector
+ (lambda (table tags)
+ (semanticdb-deep-find-tags-by-name-regexp-method table regexp tags))
+ path find-file-match))
+
+(defun semanticdb-deep-find-tags-for-completion (prefix &optional path
find-file-match)
+ "Search for all tags matching PREFIX on PATH.
+Search also in all components of top level tags founds.
+See `semanticdb-find-translate-path' for details on PATH.
+FIND-FILE-MATCH indicates that any time a match is found, the file
+associated with that tag should be loaded into a buffer."
+ (semanticdb-find-tags-collector
+ (lambda (table tags)
+ (semanticdb-deep-find-tags-for-completion-method table prefix tags))
+ path find-file-match))
+
+;;; Brutish Search Routines
+;;
+(defun semanticdb-brute-deep-find-tags-by-name (name &optional path
find-file-match)
+ "Search for all tags matching NAME on PATH.
+See `semanticdb-find-translate-path' for details on PATH.
+The argument BRUTISH will be set so that searching includes all tables
+in the current project.
+FIND-FILE-MATCH indicates that any time a matchi is found, the file
+associated wit that tag should be loaded into a buffer."
+ (semanticdb-find-tags-collector
+ (lambda (table tags)
+ (semanticdb-deep-find-tags-by-name-method table name tags))
+ path find-file-match t))
+
+(defun semanticdb-brute-deep-find-tags-for-completion (prefix &optional path
find-file-match)
+ "Search for all tags matching PREFIX on PATH.
+See `semanticdb-find-translate-path' for details on PATH.
+The argument BRUTISH will be set so that searching includes all tables
+in the current project.
+FIND-FILE-MATCH indicates that any time a matchi is found, the file
+associated wit that tag should be loaded into a buffer."
+ (semanticdb-find-tags-collector
+ (lambda (table tags)
+ (semanticdb-deep-find-tags-for-completion-method table prefix tags))
+ path find-file-match t))
+
+(defun semanticdb-brute-find-tags-by-class (class &optional path
find-file-match)
+ "Search for all tags of CLASS on PATH.
+See `semanticdb-find-translate-path' for details on PATH.
+The argument BRUTISH will be set so that searching includes all tables
+in the current project.
+FIND-FILE-MATCH indicates that any time a match is found, the file
+associated with that tag should be loaded into a buffer."
+ (semanticdb-find-tags-collector
+ (lambda (table tags)
+ (semanticdb-find-tags-by-class-method table class tags))
+ path find-file-match t))
+
+;;; Specialty Search Routines
+(defun semanticdb-find-tags-external-children-of-type
+ (type &optional path find-file-match)
+ "Search for all tags defined outside of TYPE w/ TYPE as a parent.
+See `semanticdb-find-translate-path' for details on PATH.
+FIND-FILE-MATCH indicates that any time a match is found, the file
+associated with that tag should be loaded into a buffer."
+ (semanticdb-find-tags-collector
+ (lambda (table tags)
+ (semanticdb-find-tags-external-children-of-type-method table type tags))
+ path find-file-match))
+
+(defun semanticdb-find-tags-subclasses-of-type
+ (type &optional path find-file-match)
+ "Search for all tags of class type defined that subclass TYPE.
+See `semanticdb-find-translate-path' for details on PATH.
+FIND-FILE-MATCH indicates that any time a match is found, the file
+associated with that tag should be loaded into a buffer."
+ (semanticdb-find-tags-collector
+ (lambda (table tags)
+ (semanticdb-find-tags-subclasses-of-type-method table type tags))
+ path find-file-match t))
+
+;;; METHODS
+;;
+;; Default methods for semanticdb database and table objects.
+;; Override these with system databases to as new types of back ends.
+
+;;; Top level Searches
+(defmethod semanticdb-find-tags-by-name-method ((table
semanticdb-abstract-table) name &optional tags)
+ "In TABLE, find all occurances of tags with NAME.
+Optional argument TAGS is a list of tags to search.
+Returns a table of all matching tags."
+ (semantic-find-tags-by-name name (or tags (semanticdb-get-tags table))))
+
+(defmethod semanticdb-find-tags-by-name-regexp-method ((table
semanticdb-abstract-table) regexp &optional tags)
+ "In TABLE, find all occurances of tags matching REGEXP.
+Optional argument TAGS is a list of tags to search.
+Returns a table of all matching tags."
+ (semantic-find-tags-by-name-regexp regexp (or tags (semanticdb-get-tags
table))))
+
+(defmethod semanticdb-find-tags-for-completion-method ((table
semanticdb-abstract-table) prefix &optional tags)
+ "In TABLE, find all occurances of tags matching PREFIX.
+Optional argument TAGS is a list of tags to search.
+Returns a table of all matching tags."
+ (semantic-find-tags-for-completion prefix (or tags (semanticdb-get-tags
table))))
+
+(defmethod semanticdb-find-tags-by-class-method ((table
semanticdb-abstract-table) class &optional tags)
+ "In TABLE, find all occurances of tags of CLASS.
+Optional argument TAGS is a list of tags to search.
+Returns a table of all matching tags."
+ (semantic-find-tags-by-class class (or tags (semanticdb-get-tags table))))
+
+(defmethod semanticdb-find-tags-external-children-of-type-method ((table
semanticdb-abstract-table) parent &optional tags)
+ "In TABLE, find all occurances of tags whose parent is the PARENT type.
+Optional argument TAGS is a list of tags to search.
+Returns a table of all matching tags."
+ (require 'semantic/find)
+ (semantic-find-tags-external-children-of-type parent (or tags
(semanticdb-get-tags table))))
+
+(defmethod semanticdb-find-tags-subclasses-of-type-method ((table
semanticdb-abstract-table) parent &optional tags)
+ "In TABLE, find all occurances of tags whose parent is the PARENT type.
+Optional argument TAGS is a list of tags to search.
+Returns a table of all matching tags."
+ (require 'semantic/find)
+ (semantic-find-tags-subclasses-of-type parent (or tags (semanticdb-get-tags
table))))
+
+;;; Deep Searches
+(defmethod semanticdb-deep-find-tags-by-name-method ((table
semanticdb-abstract-table) name &optional tags)
+ "In TABLE, find all occurances of tags with NAME.
+Search in all tags in TABLE, and all components of top level tags in
+TABLE.
+Optional argument TAGS is a list of tags to search.
+Return a table of all matching tags."
+ (semantic-find-tags-by-name name (semantic-flatten-tags-table (or tags
(semanticdb-get-tags table)))))
+
+(defmethod semanticdb-deep-find-tags-by-name-regexp-method ((table
semanticdb-abstract-table) regexp &optional tags)
+ "In TABLE, find all occurances of tags matching REGEXP.
+Search in all tags in TABLE, and all components of top level tags in
+TABLE.
+Optional argument TAGS is a list of tags to search.
+Return a table of all matching tags."
+ (semantic-find-tags-by-name-regexp regexp (semantic-flatten-tags-table (or
tags (semanticdb-get-tags table)))))
+
+(defmethod semanticdb-deep-find-tags-for-completion-method ((table
semanticdb-abstract-table) prefix &optional tags)
+ "In TABLE, find all occurances of tags matching PREFIX.
+Search in all tags in TABLE, and all components of top level tags in
+TABLE.
+Optional argument TAGS is a list of tags to search.
+Return a table of all matching tags."
+ (semantic-find-tags-for-completion prefix (semantic-flatten-tags-table (or
tags (semanticdb-get-tags table)))))
+
+(provide 'semantic/db-find)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/db-find"
+;; End:
+
+;;; semantic/db-find.el ends here
Index: cedet/semantic/db-global.el
===================================================================
RCS file: cedet/semantic/db-global.el
diff -N cedet/semantic/db-global.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/db-global.el 28 Sep 2009 15:15:08 -0000 1.2
@@ -0,0 +1,227 @@
+;;; semantic/db-global.el --- Semantic database extensions for GLOBAL
+
+;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2008, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: tags
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Use GNU Global for by-name database searches.
+;;
+;; This will work as an "omniscient" database for a given project.
+;;
+
+(require 'cedet-global)
+(require 'semantic/db-find)
+(require 'semantic/symref/global)
+
+(eval-when-compile
+ ;; For generic function searching.
+ (require 'eieio)
+ (require 'eieio-opt)
+ )
+
+;;; Code:
+
+(declare-function data-debug-new-buffer "data-debug")
+(declare-function data-debug-insert-thing result "data-debug")
+
+;;;###autoload
+(defun semanticdb-enable-gnu-global-databases (mode)
+ "Enable the use of the GNU Global SemanticDB back end for all files of MODE.
+This will add an instance of a GNU Global database to each buffer
+in a GNU Global supported hierarchy."
+ (interactive
+ (list (completing-read
+ "Emable in Mode: " obarray
+ #'(lambda (s) (get s 'mode-local-symbol-table))
+ t (symbol-name major-mode))))
+
+ ;; First, make sure the version is ok.
+ (cedet-gnu-global-version-check)
+
+ ;; Make sure mode is a symbol.
+ (when (stringp mode)
+ (setq mode (intern mode)))
+
+ (let ((ih (mode-local-value mode 'semantic-init-mode-hook)))
+ (eval `(setq-mode-local
+ ,mode semantic-init-mode-hook
+ (cons 'semanticdb-enable-gnu-global-hook ih))))
+
+ )
+
+(defun semanticdb-enable-gnu-global-hook ()
+ "Add support for GNU Global in the current buffer via semantic-init-hook.
+MODE is the major mode to support."
+ (semanticdb-enable-gnu-global-in-buffer t))
+
+(defclass semanticdb-project-database-global
+ ;; @todo - convert to one DB per directory.
+ (semanticdb-project-database eieio-instance-tracker)
+ ()
+ "Database representing a GNU Global tags file.")
+
+(defun semanticdb-enable-gnu-global-in-buffer (&optional
dont-err-if-not-available)
+ "Enable a GNU Global database in the current buffer.
+Argument DONT-ERR-IF-NOT-AVAILABLE will throw an error if GNU Global
+is not available for this directory."
+ (interactive "P")
+ (if (cedet-gnu-global-root)
+ (setq
+ ;; Add to the system database list.
+ semanticdb-project-system-databases
+ (cons (semanticdb-project-database-global "global")
+ semanticdb-project-system-databases)
+ ;; Apply the throttle.
+ semanticdb-find-default-throttle
+ (append semanticdb-find-default-throttle
+ '(omniscience))
+ )
+ (if dont-err-if-not-available
+ (message "No Global support in %s" default-directory)
+ (error "No Global support in %s" default-directory))
+ ))
+
+;;; Classes:
+(defclass semanticdb-table-global (semanticdb-search-results-table)
+ ((major-mode :initform nil)
+ )
+ "A table for returning search results from GNU Global.")
+
+(defmethod semanticdb-equivalent-mode ((table semanticdb-table-global)
&optional buffer)
+ "Return t, pretend that this table's mode is equivalent to BUFFER.
+Equivalent modes are specified by by `semantic-equivalent-major-modes'
+local variable."
+ ;; @todo - hack alert!
+ t)
+
+;;; Filename based methods
+;;
+(defmethod semanticdb-get-database-tables ((obj
semanticdb-project-database-global))
+ "For a global database, there are no explicit tables.
+For each file hit, get the traditional semantic table from that file."
+ ;; We need to return something since there is always the "master table"
+ ;; The table can then answer file name type questions.
+ (when (not (slot-boundp obj 'tables))
+ (let ((newtable (semanticdb-table-global "GNU Global Search Table")))
+ (oset obj tables (list newtable))
+ (oset newtable parent-db obj)
+ (oset newtable tags nil)
+ ))
+
+ (call-next-method))
+
+(defmethod semanticdb-file-table ((obj semanticdb-project-database-global)
filename)
+ "From OBJ, return FILENAME's associated table object."
+ ;; We pass in "don't load". I wonder if we need to avoid that or not?
+ (car (semanticdb-get-database-tables obj))
+ )
+
+;;; Search Overrides
+;;
+;; Only NAME based searches work with GLOBAL as that is all it tracks.
+;;
+(defmethod semanticdb-find-tags-by-name-method
+ ((table semanticdb-table-global) name &optional tags)
+ "Find all tags named NAME in TABLE.
+Return a list of tags."
+ (if tags
+ ;; If TAGS are passed in, then we don't need to do work here.
+ (call-next-method)
+ ;; Call out to GNU Global for some results.
+ (let* ((semantic-symref-tool 'global)
+ (result (semantic-symref-find-tags-by-name name 'project))
+ )
+ (when result
+ ;; We could ask to keep the buffer open, but that annoys
+ ;; people.
+ (semantic-symref-result-get-tags result))
+ )))
+
+(defmethod semanticdb-find-tags-by-name-regexp-method
+ ((table semanticdb-table-global) regex &optional tags)
+ "Find all tags with name matching REGEX in TABLE.
+Optional argument TAGS is a list of tags to search.
+Return a list of tags."
+ (if tags (call-next-method)
+ (let* ((semantic-symref-tool 'global)
+ (result (semantic-symref-find-tags-by-regexp regex 'project))
+ )
+ (when result
+ (semantic-symref-result-get-tags result))
+ )))
+
+(defmethod semanticdb-find-tags-for-completion-method
+ ((table semanticdb-table-global) prefix &optional tags)
+ "In TABLE, find all occurances of tags matching PREFIX.
+Optional argument TAGS is a list of tags to search.
+Returns a table of all matching tags."
+ (if tags (call-next-method)
+ (let* ((semantic-symref-tool 'global)
+ (result (semantic-symref-find-tags-by-completion prefix 'project))
+ (faketags nil)
+ )
+ (when result
+ (dolist (T (oref result :hit-text))
+ ;; We should look up each tag one at a time, but I'm lazy!
+ ;; Doing this may be good enough.
+ (setq faketags (cons
+ (semantic-tag T 'function :faux t)
+ faketags))
+ )
+ faketags))))
+
+;;; Deep Searches
+;;
+;; If your language does not have a `deep' concept, these can be left
+;; alone, otherwise replace with implementations similar to those
+;; above.
+;;
+(defmethod semanticdb-deep-find-tags-by-name-method
+ ((table semanticdb-table-global) name &optional tags)
+ "Find all tags name NAME in TABLE.
+Optional argument TAGS is a list of tags t
+Like `semanticdb-find-tags-by-name-method' for global."
+ (semanticdb-find-tags-by-name-method table name tags))
+
+(defmethod semanticdb-deep-find-tags-by-name-regexp-method
+ ((table semanticdb-table-global) regex &optional tags)
+ "Find all tags with name matching REGEX in TABLE.
+Optional argument TAGS is a list of tags to search.
+Like `semanticdb-find-tags-by-name-method' for global."
+ (semanticdb-find-tags-by-name-regexp-method table regex tags))
+
+(defmethod semanticdb-deep-find-tags-for-completion-method
+ ((table semanticdb-table-global) prefix &optional tags)
+ "In TABLE, find all occurances of tags matching PREFIX.
+Optional argument TAGS is a list of tags to search.
+Like `semanticdb-find-tags-for-completion-method' for global."
+ (semanticdb-find-tags-for-completion-method table prefix tags))
+
+(provide 'semantic/db-global)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/db-global"
+;; End:
+
+;;; semantic/db-global.el ends here
Index: cedet/semantic/db-javascript.el
===================================================================
RCS file: cedet/semantic/db-javascript.el
diff -N cedet/semantic/db-javascript.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/db-javascript.el 28 Sep 2009 15:15:08 -0000 1.2
@@ -0,0 +1,311 @@
+;;; semantic/db-javascript.el --- Semantic database extensions for javascript
+
+;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
+;;; Free Software Foundation, Inc.
+
+;; Author: Joakim Verona
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Semanticdb database for Javascript.
+;;
+;; This is an omniscient database with a hard-coded list of symbols for
+;; Javascript. See the doc at the end of this file for adding or modifying
+;; the list of tags.
+;;
+
+(require 'semantic/db)
+(require 'semantic/db-find)
+
+(eval-when-compile
+ ;; For generic function searching.
+ (require 'eieio)
+ (require 'eieio-opt))
+
+;;; Code:
+(defvar semanticdb-javascript-tags
+ '(("eval" function
+ (:arguments
+ (("x" variable nil nil nil)))
+ nil nil)
+ ("parseInt" function
+ (:arguments
+ (("string" variable nil nil nil)
+ ("radix" variable nil nil nil)))
+ nil nil)
+ ("parseFloat" function
+ (:arguments
+ (("string" variable nil nil nil)))
+ nil nil)
+ ("isNaN" function
+ (:arguments
+ (("number" variable nil nil nil)))
+ nil nil)
+ ("isFinite" function
+ (:arguments
+ (("number" variable nil nil nil)))
+ nil nil)
+ ("decodeURI" function
+ (:arguments
+ (("encodedURI" variable nil nil nil)))
+ nil nil)
+ ("decodeURIComponent" function
+ (:arguments
+ (("encodedURIComponent" variable nil nil nil)))
+ nil nil)
+ ("encodeURI" function
+ (:arguments
+ (("uri" variable nil nil nil)))
+ nil nil)
+ ("encodeURIComponent" function
+ (:arguments
+ (("uriComponent" variable nil nil nil)))
+ nil nil))
+ "Hard-coded list of javascript tags for semanticdb.
+See bottom of this file for instruction on managing this list.")
+
+;;; Classes:
+(defclass semanticdb-table-javascript (semanticdb-search-results-table)
+ ((major-mode :initform javascript-mode)
+ )
+ "A table for returning search results from javascript.")
+
+(defclass semanticdb-project-database-javascript
+ (semanticdb-project-database
+ eieio-singleton ;this db is for js globals, so singleton is apropriate
+ )
+ ((new-table-class :initform semanticdb-table-javascript
+ :type class
+ :documentation
+ "New tables created for this database are of this class.")
+ )
+ "Database representing javascript.")
+
+;; Create the database, and add it to searchable databases for javascript mode.
+(defvar-mode-local javascript-mode semanticdb-project-system-databases
+ (list
+ (semanticdb-project-database-javascript "Javascript"))
+ "Search javascript for symbols.")
+
+;; NOTE: Be sure to modify this to the best advantage of your
+;; language.
+(defvar-mode-local javascript-mode semanticdb-find-default-throttle
+ '(project omniscience)
+ "Search project files, then search this omniscience database.
+It is not necessary to to system or recursive searching because of
+the omniscience database.")
+
+;;; Filename based methods
+;;
+(defmethod semanticdb-get-database-tables ((obj
semanticdb-project-database-javascript))
+ "For a javascript database, there are no explicit tables.
+Create one of our special tables that can act as an intermediary."
+ ;; NOTE: This method overrides an accessor for the `tables' slot in
+ ;; a database. You can either construct your own (like tmp here
+ ;; or you can manage any number of tables.
+
+ ;; We need to return something since there is always the "master table"
+ ;; The table can then answer file name type questions.
+ (when (not (slot-boundp obj 'tables))
+ (let ((newtable (semanticdb-table-javascript "tmp")))
+ (oset obj tables (list newtable))
+ (oset newtable parent-db obj)
+ (oset newtable tags nil)
+ ))
+ (call-next-method)
+ )
+
+(defmethod semanticdb-file-table ((obj semanticdb-project-database-javascript)
filename)
+ "From OBJ, return FILENAME's associated table object."
+ ;; NOTE: See not for `semanticdb-get-database-tables'.
+ (car (semanticdb-get-database-tables obj))
+ )
+
+(defmethod semanticdb-get-tags ((table semanticdb-table-javascript ))
+ "Return the list of tags belonging to TABLE."
+ ;; NOTE: Omniscient databases probably don't want to keep large tabes
+ ;; lolly-gagging about. Keep internal Emacs tables empty and
+ ;; refer to alternate databases when you need something.
+ semanticdb-javascript-tags)
+
+(defmethod semanticdb-equivalent-mode ((table semanticdb-table-javascript)
&optional buffer)
+ "Return non-nil if TABLE's mode is equivalent to BUFFER.
+Equivalent modes are specified by by `semantic-equivalent-major-modes'
+local variable."
+ (save-excursion
+ (set-buffer buffer)
+ (eq (or mode-local-active-mode major-mode) 'javascript-mode)))
+
+;;; Usage
+;;
+;; Unlike other tables, an omniscent database does not need to
+;; be associated with a path. Use this routine to always add ourselves
+;; to a search list.
+(define-mode-local-override semanticdb-find-translate-path javascript-mode
+ (path brutish)
+ "Return a list of semanticdb tables asociated with PATH.
+If brutish, do the default action.
+If not brutish, do the default action, and append the system
+database (if available.)"
+ (let ((default
+ ;; When we recurse, disable searching of system databases
+ ;; so that our Javascript database only shows up once when
+ ;; we append it in this iteration.
+ (let ((semanticdb-search-system-databases nil)
+ )
+ (semanticdb-find-translate-path-default path brutish))))
+ ;; Don't add anything if BRUTISH is on (it will be added in that fcn)
+ ;; or if we aren't supposed to search the system.
+ (if (or brutish (not semanticdb-search-system-databases))
+ default
+ (let ((tables (apply #'append
+ (mapcar
+ (lambda (db) (semanticdb-get-database-tables db))
+ semanticdb-project-system-databases))))
+ (append default tables)))))
+
+;;; Search Overrides
+;;
+;; NOTE WHEN IMPLEMENTING: Be sure to add doc-string updates explaining
+;; how your new search routines are implemented.
+;;
+(defun semanticdb-javascript-regexp-search (regexp)
+ "Search for REGEXP in our fixed list of javascript tags."
+ (let* ((tags semanticdb-javascript-tags)
+ (result nil))
+ (while tags
+ (if (string-match regexp (caar tags))
+ (setq result (cons (car tags) result)))
+ (setq tags (cdr tags)))
+ result))
+
+(defmethod semanticdb-find-tags-by-name-method
+ ((table semanticdb-table-javascript) name &optional tags)
+ "Find all tags named NAME in TABLE.
+Return a list of tags."
+ (if tags
+ ;; If TAGS are passed in, then we don't need to do work here.
+ (call-next-method)
+ (assoc-string name semanticdb-javascript-tags)
+ ))
+
+(defmethod semanticdb-find-tags-by-name-regexp-method
+ ((table semanticdb-table-javascript) regex &optional tags)
+ "Find all tags with name matching REGEX in TABLE.
+Optional argument TAGS is a list of tags to search.
+Return a list of tags."
+ (if tags (call-next-method)
+ ;; YOUR IMPLEMENTATION HERE
+ (semanticdb-javascript-regexp-search regex)
+
+ ))
+
+(defmethod semanticdb-find-tags-for-completion-method
+ ((table semanticdb-table-javascript) prefix &optional tags)
+ "In TABLE, find all occurances of tags matching PREFIX.
+Optional argument TAGS is a list of tags to search.
+Returns a table of all matching tags."
+ (if tags (call-next-method)
+ ;; YOUR IMPLEMENTATION HERE
+ (semanticdb-javascript-regexp-search (concat "^" prefix ".*"))
+ ))
+
+(defmethod semanticdb-find-tags-by-class-method
+ ((table semanticdb-table-javascript) class &optional tags)
+ "In TABLE, find all occurances of tags of CLASS.
+Optional argument TAGS is a list of tags to search.
+Returns a table of all matching tags."
+ (if tags (call-next-method)
+ ;; YOUR IMPLEMENTATION HERE
+ ;;
+ ;; Note: This search method could be considered optional in an
+ ;; omniscient database. It may be unwise to return all tags
+ ;; that exist for a language that are a variable or function.
+ ;;
+ ;; If it is optional, you can just delete this method.
+ nil))
+
+;;; Deep Searches
+;;
+;; If your language does not have a `deep' concept, these can be left
+;; alone, otherwise replace with implementations similar to those
+;; above.
+;;
+(defmethod semanticdb-deep-find-tags-by-name-method
+ ((table semanticdb-table-javascript) name &optional tags)
+ "Find all tags name NAME in TABLE.
+Optional argument TAGS is a list of tags t
+Like `semanticdb-find-tags-by-name-method' for javascript."
+ (semanticdb-find-tags-by-name-method table name tags))
+
+(defmethod semanticdb-deep-find-tags-by-name-regexp-method
+ ((table semanticdb-table-javascript) regex &optional tags)
+ "Find all tags with name matching REGEX in TABLE.
+Optional argument TAGS is a list of tags to search.
+Like `semanticdb-find-tags-by-name-method' for javascript."
+ (semanticdb-find-tags-by-name-regexp-method table regex tags))
+
+(defmethod semanticdb-deep-find-tags-for-completion-method
+ ((table semanticdb-table-javascript) prefix &optional tags)
+ "In TABLE, find all occurances of tags matching PREFIX.
+Optional argument TAGS is a list of tags to search.
+Like `semanticdb-find-tags-for-completion-method' for javascript."
+ (semanticdb-find-tags-for-completion-method table prefix tags))
+
+;;; Advanced Searches
+;;
+(defmethod semanticdb-find-tags-external-children-of-type-method
+ ((table semanticdb-table-javascript) type &optional tags)
+ "Find all nonterminals which are child elements of TYPE
+Optional argument TAGS is a list of tags to search.
+Return a list of tags."
+ (if tags (call-next-method)
+ ;; YOUR IMPLEMENTATION HERE
+ ;;
+ ;; OPTIONAL: This could be considered an optional function. It is
+ ;; used for `semantic-adopt-external-members' and may not
+ ;; be possible to do in your language.
+ ;;
+ ;; If it is optional, you can just delete this method.
+ ))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun semanticdb-javascript-strip-tags (tags)
+ "Strip TAGS from overlays and reparse symbols."
+ (cond ((and (consp tags) (eq 'reparse-symbol (car tags)))
+ nil)
+ ((overlayp tags) nil)
+ ((atom tags) tags)
+ (t (cons (semanticdb-javascript-strip-tags
+ (car tags)) (semanticdb-javascript-strip-tags
+ (cdr tags))))))
+
+;this list was made from a javascript file, and the above function
+;; function eval(x){}
+;; function parseInt(string,radix){}
+;; function parseFloat(string){}
+;; function isNaN(number){}
+;; function isFinite(number){}
+;; function decodeURI(encodedURI){}
+;; function decodeURIComponent (encodedURIComponent){}
+;; function encodeURI (uri){}
+;; function encodeURIComponent (uriComponent){}
+
+(provide 'semantic/db-javascript)
+
+;;; semantic/db-javascript.el ends here
Index: cedet/semantic/db-mode.el
===================================================================
RCS file: cedet/semantic/db-mode.el
diff -N cedet/semantic/db-mode.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/db-mode.el 28 Sep 2009 15:15:08 -0000 1.2
@@ -0,0 +1,221 @@
+;;; semantic/db-mode.el --- Semanticdb Minor Mode
+
+;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Major mode for managing Semantic Databases automatically.
+
+;;; Code:
+
+(require 'semantic/db)
+
+(declare-function semantic-lex-spp-set-dynamic-table "semantic/lex-spp")
+
+;;; Start/Stop database use
+;;
+(defvar semanticdb-hooks
+ '((semanticdb-semantic-init-hook-fcn semantic-init-db-hook)
+ (semanticdb-synchronize-table semantic-after-toplevel-cache-change-hook)
+ (semanticdb-partial-synchronize-table
semantic-after-partial-cache-change-hook)
+ (semanticdb-revert-hook before-revert-hook)
+ (semanticdb-kill-hook kill-buffer-hook)
+ (semanticdb-kill-hook change-major-mode-hook) ;; Not really a kill, but we
need the same effect.
+ (semanticdb-kill-emacs-hook kill-emacs-hook)
+ (semanticdb-save-all-db-idle auto-save-hook)
+ )
+ "List of hooks and values to add/remove when configuring semanticdb.")
+
+;;; SEMANTICDB-MODE
+;;
+;;;###autoload
+(defun semanticdb-minor-mode-p ()
+ "Return non-nil if `semanticdb-minor-mode' is active."
+ (member (car (car semanticdb-hooks))
+ (symbol-value (car (cdr (car semanticdb-hooks))))))
+
+;;;###autoload
+(define-minor-mode global-semanticdb-minor-mode
+ "Toggle Semantic DB mode.
+With ARG, turn Semantic DB mode on if ARG is positive, off otherwise.
+
+In Semantic DB mode, Semantic parsers store results in a
+database, which can be saved for future Emacs sessions."
+ :global t
+ :group 'semantic
+ (if global-semanticdb-minor-mode
+ ;; Enable
+ (dolist (elt semanticdb-hooks)
+ (add-hook (cadr elt) (car elt)))
+ ;; Disable
+ (dolist (elt semanticdb-hooks)
+ (add-hook (cadr elt) (car elt)))))
+
+(defvaralias 'semanticdb-mode-hook 'global-semanticdb-minor-mode-hook)
+(defvaralias 'semanticdb-global-mode 'global-semanticdb-minor-mode)
+(semantic-varalias-obsolete 'semanticdb-mode-hooks
+ 'global-semanticdb-minor-mode-hook)
+
+
+(defun semanticdb-toggle-global-mode ()
+ "Toggle use of the Semantic Database feature.
+Update the environment of Semantic enabled buffers accordingly."
+ (interactive)
+ (if (semanticdb-minor-mode-p)
+ ;; Save databases before disabling semanticdb.
+ (semanticdb-save-all-db))
+ ;; Toggle semanticdb minor mode.
+ (global-semanticdb-minor-mode))
+
+;;; Hook Functions:
+;;
+;; Functions used in hooks to keep SemanticDB operating.
+;;
+(defun semanticdb-semantic-init-hook-fcn ()
+ "Function saved in `semantic-init-db-hook'.
+Sets up the semanticdb environment."
+ ;; Only initialize semanticdb if we have a file name.
+ ;; There is no reason to cache a tag table if there is no
+ ;; way to load it back in later.
+ (when (buffer-file-name)
+ (let* ((ans (semanticdb-create-table-for-file (buffer-file-name)))
+ (cdb (car ans))
+ (ctbl (cdr ans))
+ )
+ ;; Get the current DB for this directory
+ (setq semanticdb-current-database cdb)
+ ;; We set the major mode because we know what it is.
+ (oset ctbl major-mode major-mode)
+ ;; Local state
+ (setq semanticdb-current-table ctbl)
+ ;; Try to swap in saved tags
+ (if (or (not (slot-boundp ctbl 'tags)) (not (oref ctbl tags))
+ (/= (or (oref ctbl pointmax) 0) (point-max))
+ )
+ (semantic-clear-toplevel-cache)
+ ;; Unmatched syntax
+ (condition-case nil
+ (semantic-set-unmatched-syntax-cache
+ (oref ctbl unmatched-syntax))
+ (unbound-slot
+ ;; Old version of the semanticdb table can miss the unmatched
+ ;; syntax slot. If so, just clear the unmatched syntax cache.
+ (semantic-clear-unmatched-syntax-cache)
+ ;; Make sure it has a value.
+ (oset ctbl unmatched-syntax nil)
+ ))
+ ;; Keep lexical tables up to date. Don't load
+ ;; semantic-spp if it isn't needed.
+ (let ((lt (oref ctbl lexical-table)))
+ (when lt
+ (require 'semantic/lex-spp)
+ (semantic-lex-spp-set-dynamic-table lt)))
+ ;; Set the main tag cache.
+ ;; This must happen after setting up buffer local variables
+ ;; since this will turn around and re-save those variables.
+ (semantic--set-buffer-cache (oref ctbl tags))
+ ;; Don't need it to be dirty. Set dirty due to hooks from above.
+ (oset ctbl dirty nil) ;; Special case here.
+ (oset ctbl buffer (current-buffer))
+ ;; Bind into the buffer.
+ (semantic--tag-link-cache-to-buffer)
+ )
+ )))
+
+(defun semanticdb-revert-hook ()
+ "Hook run before a revert buffer.
+We can't track incremental changes due to a revert, so just clear the cache.
+This will prevent the next batch of hooks from wasting time parsing things
+that don't need to be parsed."
+ (if (and (semantic-active-p)
+ semantic--buffer-cache
+ semanticdb-current-table)
+ (semantic-clear-toplevel-cache)))
+
+(defun semanticdb-kill-hook ()
+ "Function run when a buffer is killed.
+If there is a semantic cache, slurp out the overlays, and store
+it in our database. If that buffer has no cache, ignore it, we'll
+handle it later if need be."
+ (when (and (semantic-active-p)
+ semantic--buffer-cache
+ semanticdb-current-table)
+
+ ;; Try to get a fast update.
+ (semantic-fetch-tags-fast)
+
+ ;; If the buffer is in a bad state, don't save anything...
+ (if (semantic-parse-tree-needs-rebuild-p)
+ ;; If this is the case, don't save anything.
+ (progn
+ (semantic-clear-toplevel-cache)
+ (oset semanticdb-current-table pointmax 0)
+ (oset semanticdb-current-table fsize 0)
+ (oset semanticdb-current-table lastmodtime nil)
+ )
+ ;; We have a clean buffer, save it off.
+ (condition-case nil
+ (progn
+ (semantic--tag-unlink-cache-from-buffer)
+ ;; Set pointmax only if we had some success in the unlink.
+ (oset semanticdb-current-table pointmax (point-max))
+ (let ((fattr (file-attributes
+ (semanticdb-full-filename
+ semanticdb-current-table))))
+ (oset semanticdb-current-table fsize (nth 7 fattr))
+ (oset semanticdb-current-table lastmodtime (nth 5 fattr))
+ (oset semanticdb-current-table buffer nil)
+ ))
+ ;; If this messes up, just clear the system
+ (error
+ (semantic-clear-toplevel-cache)
+ (message "semanticdb: Failed to deoverlay tag cache.")))
+ )
+ ))
+
+(defun semanticdb-kill-emacs-hook ()
+ "Function called when Emacs is killed.
+Save all the databases."
+ (semanticdb-save-all-db))
+
+;;; SYNCHRONIZATION HOOKS
+;;
+(defun semanticdb-synchronize-table (new-table)
+ "Function run after parsing.
+Argument NEW-TABLE is the new table of tags."
+ (when semanticdb-current-table
+ (semanticdb-synchronize semanticdb-current-table new-table)))
+
+(defun semanticdb-partial-synchronize-table (new-table)
+ "Function run after parsing.
+Argument NEW-TABLE is the new table of tags."
+ (when semanticdb-current-table
+ (semanticdb-partial-synchronize semanticdb-current-table new-table)))
+
+
+(provide 'semantic/db-mode)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/db-mode"
+;; End:
+
+;;; semantic/db-mode.el ends here
Index: cedet/semantic/db-ref.el
===================================================================
RCS file: cedet/semantic/db-ref.el
diff -N cedet/semantic/db-ref.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/db-ref.el 28 Sep 2009 15:15:08 -0000 1.2
@@ -0,0 +1,173 @@
+;;; semantic/db-ref.el --- Handle cross-db file references
+
+;;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Handle cross-database file references.
+;;
+;; Any given database may be referred to by some other database. For
+;; example, if a .cpp file has a #include in a header, then that
+;; header file should have a reference to the .cpp file that included
+;; it.
+;;
+;; This is critical for purposes where a file (such as a .cpp file)
+;; needs to have its caches flushed because of changes in the
+;; header. Changing a header may cause a referring file to be
+;; reparsed due to account for changes in defined macros, or perhaps
+;; a change to files the header includes.
+
+
+;;; Code:
+(require 'eieio)
+(require 'semantic)
+(require 'semantic/db)
+(require 'semantic/tag)
+
+;; For the semantic-find-tags-by-name-regexp macro.
+(eval-when-compile (require 'semantic/find))
+
+(defmethod semanticdb-add-reference ((dbt semanticdb-abstract-table)
+ include-tag)
+ "Add a reference for the database table DBT based on INCLUDE-TAG.
+DBT is the database table that owns the INCLUDE-TAG. The reference
+will be added to the database that INCLUDE-TAG refers to."
+ ;; NOTE: I should add a check to make sure include-tag is in DB.
+ ;; but I'm too lazy.
+ (let* ((semanticdb-find-default-throttle
+ (if (featurep 'semantic/db-find)
+ (remq 'unloaded semanticdb-find-default-throttle)
+ nil))
+ (refdbt (semanticdb-find-table-for-include include-tag dbt))
+ ;;(fullfile (semanticdb-full-filename dbt))
+ )
+ (when refdbt
+ ;; Add our filename (full path)
+ ;; (object-add-to-list refdbt 'file-refs fullfile)
+
+ ;; Add our database.
+ (object-add-to-list refdbt 'db-refs dbt)
+ t)))
+
+(defmethod semanticdb-check-references ((dbt semanticdb-abstract-table))
+ "Check and cleanup references in the database DBT.
+Abstract tables would be difficult to reference."
+ ;; Not sure how an abstract table can have references.
+ nil)
+
+(defmethod semanticdb-includes-in-table ((dbt semanticdb-abstract-table))
+ "Return a list of direct includes in table DBT."
+ (semantic-find-tags-by-class 'include (semanticdb-get-tags dbt)))
+
+
+(defmethod semanticdb-check-references ((dbt semanticdb-table))
+ "Check and cleanup references in the database DBT.
+Any reference to a file that cannot be found, or whos file no longer
+refers to DBT will be removed."
+ (let ((refs (oref dbt db-refs))
+ (myexpr (concat "\\<" (oref dbt file)))
+ )
+ (while refs
+ (let* ((ok t)
+ (db (car refs))
+ (f (when (semanticdb-table-child-p db)
+ (semanticdb-full-filename db)))
+ )
+
+ ;; The file was deleted
+ (when (and f (not (file-exists-p f)))
+ (setq ok nil))
+
+ ;; The reference no longer includes the textual reference?
+ (let* ((refs (semanticdb-includes-in-table db))
+ (inc (semantic-find-tags-by-name-regexp
+ myexpr refs)))
+ (when (not inc)
+ (setq ok nil)))
+
+ ;; Remove not-ok databases from the list.
+ (when (not ok)
+ (object-remove-from-list dbt 'db-refs db)
+ ))
+ (setq refs (cdr refs)))))
+
+(defmethod semanticdb-refresh-references ((dbt semanticdb-abstract-table))
+ "Refresh references to DBT in other files."
+ ;; alternate tables can't be edited, so can't be changed.
+ nil
+ )
+
+(defmethod semanticdb-refresh-references ((dbt semanticdb-table))
+ "Refresh references to DBT in other files."
+ (let ((refs (semanticdb-includes-in-table dbt))
+ )
+ (while refs
+ (if (semanticdb-add-reference dbt (car refs))
+ nil
+ ;; If we succeeded, then do... nothing?
+ nil
+ )
+ (setq refs (cdr refs)))
+ ))
+
+(defmethod semanticdb-notify-references ((dbt semanticdb-table)
+ method)
+ "Notify all references of the table DBT using method.
+METHOD takes two arguments.
+ (METHOD TABLE-TO-NOTIFY DBT)
+TABLE-TO-NOTIFY is a semanticdb-table which is being notified.
+DBT, the second argument is DBT."
+ (mapc (lambda (R) (funcall method R dbt))
+ (oref dbt db-refs)))
+
+;;; DEBUG
+;;
+(defclass semanticdb-ref-adebug ()
+ ((i-depend-on :initarg :i-depend-on)
+ (local-table :initarg :local-table)
+ (i-include :initarg :i-include))
+ "Simple class to allow ADEBUG to show a nice list.")
+
+(declare-function data-debug-new-buffer "data-debug")
+(declare-function data-debug-insert-object-slots "eieio-datadebug")
+
+(defun semanticdb-ref-test (refresh)
+ "Dump out the list of references for the current buffer.
+If REFRESH is non-nil, cause the current table to have its references
+refreshed before dumping the result."
+ (interactive "p")
+ (require 'eieio-datadebug)
+ ;; If we need to refresh... then do so.
+ (when refresh
+ (semanticdb-refresh-references semanticdb-current-table))
+ ;; Do the debug system
+ (let* ((tab semanticdb-current-table)
+ (myrefs (oref tab db-refs))
+ (myinc (semanticdb-includes-in-table tab))
+ (adbc (semanticdb-ref-adebug "DEBUG"
+ :i-depend-on myrefs
+ :local-table tab
+ :i-include myinc)))
+ (data-debug-new-buffer "*References ADEBUG*")
+ (data-debug-insert-object-slots adbc "!"))
+ )
+
+(provide 'semantic/db-ref)
+;;; semantic/db-ref.el ends here
Index: cedet/semantic/db-typecache.el
===================================================================
RCS file: cedet/semantic/db-typecache.el
diff -N cedet/semantic/db-typecache.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/db-typecache.el 28 Sep 2009 15:15:08 -0000 1.2
@@ -0,0 +1,606 @@
+;;; db-typecache.el --- Manage Datatypes
+
+;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Manage a datatype cache.
+;;
+;; For typed languages like C++ collect all known types from various
+;; headers, merge namespaces, and expunge duplicates.
+;;
+;; It is likely this feature will only be needed for C/C++.
+
+(require 'semantic)
+(require 'semantic/db)
+(require 'semantic/db-find)
+(require 'semantic/analyze/fcn)
+
+;; For semantic-find-tags-by-* macros
+(eval-when-compile (require 'semantic/find))
+
+(declare-function data-debug-insert-thing "data-debug")
+(declare-function data-debug-new-buffer "data-debug")
+(declare-function semantic-sort-tags-by-name-then-type-increasing
"semantic/sort")
+(declare-function semantic-scope-tag-clone-with-scope "semantic/scope")
+
+;;; Code:
+
+
+;;; TABLE TYPECACHE
+;;;###autoload
+(defclass semanticdb-typecache ()
+ ((filestream :initform nil
+ :documentation
+ "Fully sorted/merged list of tags within this buffer.")
+ (includestream :initform nil
+ :documentation
+ "Fully sorted/merged list of tags from this file's includes
list.")
+ (stream :initform nil
+ :documentation
+ "The searchable tag stream for this cache.
+NOTE: Can I get rid of this? Use a hashtable instead?")
+ (dependants :initform nil
+ :documentation
+ "Any other object that is dependent on typecache results.
+Said object must support `semantic-reset' methods.")
+ ;; @todo - add some sort of fast-hash.
+ ;; @note - Rebuilds in large projects already take a while, and the
+ ;; actual searches are pretty fast. Really needed?
+ )
+ "Structure for maintaining a typecache.")
+
+(defmethod semantic-reset ((tc semanticdb-typecache))
+ "Reset the object IDX."
+ (oset tc filestream nil)
+ (oset tc includestream nil)
+
+ (oset tc stream nil)
+
+ (mapc 'semantic-reset (oref tc dependants))
+ (oset tc dependants nil)
+ )
+
+(defmethod semanticdb-typecache-notify-reset ((tc semanticdb-typecache))
+ "Do a reset from a notify from a table we depend on."
+ (oset tc includestream nil)
+ (mapc 'semantic-reset (oref tc dependants))
+ (oset tc dependants nil)
+ )
+
+(defmethod semanticdb-partial-synchronize ((tc semanticdb-typecache)
+ new-tags)
+ "Reset the typecache based on a partial reparse."
+ (when (semantic-find-tags-by-class 'include new-tags)
+ (oset tc includestream nil)
+ (mapc 'semantic-reset (oref tc dependants))
+ (oset tc dependants nil)
+ )
+
+ (when (semantic-find-tags-by-class 'type new-tags)
+ ;; Reset our index
+ (oset tc filestream nil)
+ t ;; Return true, our core file tags have changed in a relavant way.
+ )
+
+ ;; NO CODE HERE
+ )
+
+(defun semanticdb-typecache-add-dependant (dep)
+ "Add into the local typecache a dependant DEP."
+ (let* ((table semanticdb-current-table)
+ ;;(idx (semanticdb-get-table-index table))
+ (cache (semanticdb-get-typecache table))
+ )
+ (object-add-to-list cache 'dependants dep)))
+
+(defun semanticdb-typecache-length(thing)
+ "How long is THING?
+Debugging function."
+ (cond ((semanticdb-typecache-child-p thing)
+ (length (oref thing stream)))
+ ((semantic-tag-p thing)
+ (length (semantic-tag-type-members thing)))
+ ((and (listp thing) (semantic-tag-p (car thing)))
+ (length thing))
+ ((null thing)
+ 0)
+ (t -1) ))
+
+
+(defmethod semanticdb-get-typecache ((table semanticdb-abstract-table))
+ "Retrieve the typecache from the semanticdb TABLE.
+If there is no table, create one, and fill it in."
+ (semanticdb-refresh-table table)
+ (let* ((idx (semanticdb-get-table-index table))
+ (cache (oref idx type-cache))
+ )
+
+ ;; Make sure we have a cache object in the DB index.
+ (when (not cache)
+ ;; The object won't change as we fill it with stuff.
+ (setq cache (semanticdb-typecache (semanticdb-full-filename table)))
+ (oset idx type-cache cache))
+
+ cache))
+
+(defmethod semanticdb-have-typecache-p ((table semanticdb-abstract-table))
+ "Return non-nil (the typecache) if TABLE has a pre-calculated typecache."
+ (let* ((idx (semanticdb-get-table-index table)))
+ (oref idx type-cache)))
+
+
+;;; DATABASE TYPECACHE
+;;
+;; A full database can cache the types across its files.
+;;
+;; Unlike file based caches, this one is a bit simpler, and just needs
+;; to get reset when a table gets updated.
+
+;;;###autoload
+(defclass semanticdb-database-typecache (semanticdb-abstract-db-cache)
+ ((stream :initform nil
+ :documentation
+ "The searchable tag stream for this cache.")
+ )
+ "Structure for maintaining a typecache.")
+
+(defmethod semantic-reset ((tc semanticdb-database-typecache))
+ "Reset the object IDX."
+ (oset tc stream nil)
+ )
+
+(defmethod semanticdb-synchronize ((cache semanticdb-database-typecache)
+ new-tags)
+ "Synchronize a CACHE with some NEW-TAGS."
+ )
+
+(defmethod semanticdb-partial-synchronize ((cache
semanticdb-database-typecache)
+ new-tags)
+ "Synchronize a CACHE with some changed NEW-TAGS."
+ )
+
+(defmethod semanticdb-get-typecache ((db semanticdb-project-database))
+ "Retrieve the typecache from the semantic database DB.
+If there is no table, create one, and fill it in."
+ (semanticdb-cache-get db semanticdb-database-typecache)
+ )
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; MERGING
+;;
+;; Managing long streams of tags representing data types.
+;;
+(defun semanticdb-typecache-apply-filename (file stream)
+ "Apply the filename FILE to all tags in STREAM."
+ (let ((new nil))
+ (while stream
+ (setq new (cons (semantic-tag-copy (car stream) nil file)
+ new))
+ ;The below is handled by the tag-copy fcn.
+ ;(semantic--tag-put-property (car new) :filename file)
+ (setq stream (cdr stream)))
+ (nreverse new)))
+
+
+(defsubst semanticdb-typecache-safe-tag-members (tag)
+ "Return a list of members for TAG that are safe to permute."
+ (let ((mem (semantic-tag-type-members tag))
+ (fname (semantic-tag-file-name tag)))
+ (if fname
+ (setq mem (semanticdb-typecache-apply-filename fname mem))
+ (copy-sequence mem))))
+
+(defsubst semanticdb-typecache-safe-tag-list (tags table)
+ "Make the tag list TAGS found in TABLE safe for the typecache.
+Adds a filename and copies the tags."
+ (semanticdb-typecache-apply-filename
+ (semanticdb-full-filename table)
+ tags))
+
+(defun semanticdb-typecache-merge-streams (cache1 cache2)
+ "Merge into CACHE1 and CACHE2 together. The Caches will be merged in place."
+ (if (or (and (not cache1) (not cache2))
+ (and (not (cdr cache1)) (not cache2))
+ (and (not cache1) (not (cdr cache2))))
+ ;; If all caches are empty OR
+ ;; cache1 is length 1 and no cache2 OR
+ ;; no cache1 and length 1 cache2
+ ;;
+ ;; then just return the cache, and skip all this merging stuff.
+ (or cache1 cache2)
+
+ ;; Assume we always have datatypes, as this typecache isn't really
+ ;; useful without a typed language.
+ (require 'semantic/sort)
+ (let ((S (semantic-sort-tags-by-name-then-type-increasing
+ ;; I used to use append, but it copied cache1 but not cache2.
+ ;; Since sort was permuting cache2, I already had to make sure
+ ;; the caches were permute-safe. Might as well use nconc here.
+ (nconc cache1 cache2)))
+ (ans nil)
+ (next nil)
+ (prev nil)
+ (type nil))
+ ;; With all the tags in order, we can loop over them, and when
+ ;; two have the same name, we can either throw one away, or construct
+ ;; a fresh new tag merging the items together.
+ (while S
+ (setq prev (car ans))
+ (setq next (car S))
+ (if (or
+ ;; CASE 1 - First item
+ (null prev)
+ ;; CASE 2 - New name
+ (not (string= (semantic-tag-name next)
+ (semantic-tag-name prev))))
+ (setq ans (cons next ans))
+ ;; ELSE - We have a NAME match.
+ (setq type (semantic-tag-type next))
+ (if (semantic-tag-of-type-p prev type) ; Are they the same datatype
+ ;; Same Class, we can do a merge.
+ (cond
+ ((and (semantic-tag-of-class-p next 'type)
+ (string= type "namespace"))
+ ;; Namespaces - merge the children together.
+ (setcar ans
+ (semantic-tag-new-type
+ (semantic-tag-name prev) ; - they are the same
+ "namespace" ; - we know this as fact
+ (semanticdb-typecache-merge-streams
+ (semanticdb-typecache-safe-tag-members prev)
+ (semanticdb-typecache-safe-tag-members next))
+ nil ; - no attributes
+ ))
+ ;; Make sure we mark this as a fake tag.
+ (semantic-tag-set-faux (car ans))
+ )
+ ((semantic-tag-prototype-p next)
+ ;; NEXT is a prototype... so keep previous.
+ nil ; - keep prev, do nothing
+ )
+ ((semantic-tag-prototype-p prev)
+ ;; PREV is a prototype, but not next.. so keep NEXT.
+ ;; setcar - set by side-effect on top of prev
+ (setcar ans next)
+ )
+ (t
+ ;;(message "Don't know how to merge %s. Keeping first entry."
(semantic-tag-name next))
+ ))
+ ;; Not same class... but same name
+ ;(message "Same name, different type:
%s, %s!=%s"
+ ; (semantic-tag-name next)
+ ; (semantic-tag-type next)
+ ; (semantic-tag-type prev))
+ (setq ans (cons next ans))
+ ))
+ (setq S (cdr S)))
+ (nreverse ans))))
+
+;;; Refresh / Query API
+;;
+;; Queries that can be made for the typecache.
+(defmethod semanticdb-typecache-file-tags ((table semanticdb-abstract-table))
+ "No tags available from non-file based tables."
+ nil)
+
+(defmethod semanticdb-typecache-file-tags ((table semanticdb-table))
+ "Update the typecache for TABLE, and return the file-tags.
+File-tags are those that belong to this file only, and excludes
+all included files."
+ (let* (;(idx (semanticdb-get-table-index table))
+ (cache (semanticdb-get-typecache table))
+ )
+
+ ;; Make sure our file-tags list is up to date.
+ (when (not (oref cache filestream))
+ (let ((tags (semantic-find-tags-by-class 'type table)))
+ (when tags
+ (setq tags (semanticdb-typecache-safe-tag-list tags table))
+ (oset cache filestream (semanticdb-typecache-merge-streams tags
nil)))))
+
+ ;; Return our cache.
+ (oref cache filestream)
+ ))
+
+(defmethod semanticdb-typecache-include-tags ((table
semanticdb-abstract-table))
+ "No tags available from non-file based tables."
+ nil)
+
+(defmethod semanticdb-typecache-include-tags ((table semanticdb-table))
+ "Update the typecache for TABLE, and return the merged types from the
include tags.
+Include-tags are the tags brought in via includes, all merged together into
+a master list."
+ (let* ((cache (semanticdb-get-typecache table))
+ )
+
+ ;; Make sure our file-tags list is up to date.
+ (when (not (oref cache includestream))
+ (let (;; Calc the path first. This will have a nice side -effect of
+ ;; getting the cache refreshed if a refresh is needed. Most of the
+ ;; time this value is itself cached, so the query is fast.
+ (incpath (semanticdb-find-translate-path table nil))
+ (incstream nil))
+ ;; Get the translated path, and extract all the type tags, then merge
+ ;; them all together.
+ (dolist (i incpath)
+ ;; don't include ourselves in this crazy list.
+ (when (and i (not (eq i table))
+ ;; @todo - This eieio fcn can be slow! Do I need it?
+ ;; (semanticdb-table-child-p i)
+ )
+ (setq incstream
+ (semanticdb-typecache-merge-streams
+ incstream
+ ;; Getting the cache from this table will also cause this
+ ;; file to update it's cache from it's decendants.
+ ;;
+ ;; In theory, caches are only built for most includes
+ ;; only once (in the loop before this one), so this ends
+ ;; up being super fast as we edit our file.
+ (copy-sequence
+ (semanticdb-typecache-file-tags i))))
+ ))
+
+ ;; Save...
+ (oset cache includestream incstream)))
+
+ ;; Return our cache.
+ (oref cache includestream)
+ ))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Search Routines
+;;;###autoload
+(define-overloadable-function semanticdb-typecache-find (type &optional path
find-file-match)
+ "Search the typecache for TYPE in PATH.
+If type is a string, split the string, and search for the parts.
+If type is a list, treat the type as a pre-split string.
+PATH can be nil for the current buffer, or a semanticdb table.
+FIND-FILE-MATCH is non-nil to force all found tags to be loaded into a
buffer.")
+
+(defun semanticdb-typecache-find-default (type &optional path find-file-match)
+ "Default implementation of `semanticdb-typecache-find'.
+TYPE is the datatype to find.
+PATH is the search path.. which should be one table object.
+If FIND-FILE-MATCH is non-nil, then force the file belonging to the
+found tag to be loaded."
+ (semanticdb-typecache-find-method (or path semanticdb-current-table)
+ type find-file-match))
+
+(defun semanticdb-typecache-find-by-name-helper (name table)
+ "Find the tag with NAME in TABLE, which is from a typecache.
+If more than one tag has NAME in TABLE, we will prefer the tag that
+is of class 'type."
+ (let* ((names (semantic-find-tags-by-name name table))
+ (types (semantic-find-tags-by-class 'type names)))
+ (or (car-safe types) (car-safe names))))
+
+(defmethod semanticdb-typecache-find-method ((table semanticdb-abstract-table)
+ type find-file-match)
+ "Search the typecache in TABLE for the datatype TYPE.
+If type is a string, split the string, and search for the parts.
+If type is a list, treat the type as a pre-split string.
+If FIND-FILE-MATCH is non-nil, then force the file belonging to the
+found tag to be loaded."
+ ;; convert string to a list.
+ (when (stringp type) (setq type (semantic-analyze-split-name type)))
+ (when (stringp type) (setq type (list type)))
+
+ ;; Search for the list in our typecache.
+ (let* ((file (semanticdb-typecache-file-tags table))
+ (inc (semanticdb-typecache-include-tags table))
+ (stream nil)
+ (f-ans nil)
+ (i-ans nil)
+ (ans nil)
+ (notdone t)
+ (lastfile nil)
+ (thisfile nil)
+ (lastans nil)
+ (calculated-scope nil)
+ )
+ ;; 1) Find first symbol in the two master lists and then merge
+ ;; the found streams.
+
+ ;; We stripped duplicates, so these will be super-fast!
+ (setq f-ans (semantic-find-first-tag-by-name (car type) file))
+ (setq i-ans (semantic-find-first-tag-by-name (car type) inc))
+ (if (and f-ans i-ans)
+ (progn
+ ;; This trick merges the two identified tags, making sure our lists
are
+ ;; complete. The second find then gets the new 'master' from the
list of 2.
+ (setq ans (semanticdb-typecache-merge-streams (list f-ans) (list
i-ans)))
+ (setq ans (semantic-find-first-tag-by-name (car type) ans))
+ )
+
+ ;; The answers are already sorted and merged, so if one misses,
+ ;; no need to do any special work.
+ (setq ans (or f-ans i-ans)))
+
+ ;; 2) Loop over the remaining parts.
+ (while (and type notdone)
+
+ ;; For pass > 1, stream will be non-nil, so do a search, otherwise
+ ;; ans is from outside the loop.
+ (when stream
+ (setq ans (semanticdb-typecache-find-by-name-helper (car type) stream))
+
+ ;; NOTE: The below test to make sure we get a type is only relevant
+ ;; for the SECOND pass or later. The first pass can only ever
+ ;; find a type/namespace because everything else is excluded.
+
+ ;; If this is not the last entry from the list, then it
+ ;; must be a type or a namespace. Lets double check.
+ (when (cdr type)
+
+ ;; From above, there is only one tag in ans, and we prefer
+ ;; types.
+ (when (not (semantic-tag-of-class-p ans 'type))
+
+ (setq ans nil)))
+ )
+
+ (push ans calculated-scope)
+
+ ;; Track most recent file.
+ (setq thisfile (semantic-tag-file-name ans))
+ (when (and thisfile (stringp thisfile))
+ (setq lastfile thisfile))
+
+ ;; If we have a miss, exit, otherwise, update the stream to
+ ;; the next set of members.
+ (if (not ans)
+ (setq notdone nil)
+ (setq stream (semantic-tag-type-members ans)))
+
+ (setq lastans ans
+ ans nil
+ type (cdr type)))
+
+ (if (or type (not notdone))
+ ;; If there is stuff left over, then we failed. Just return
+ ;; nothing.
+ nil
+
+ ;; We finished, so return everything.
+
+ (if (and find-file-match lastfile)
+ ;; This won't liven up the tag since we have a copy, but
+ ;; we ought to be able to get there and go to the right line.
+ (find-file-noselect lastfile)
+ ;; We don't want to find-file match, so instead lets
+ ;; push the filename onto the return tag.
+ (when lastans
+ (setq lastans (semantic-tag-copy lastans nil lastfile))
+ ;; We used to do the below, but we would erroneously be putting
+ ;; attributes on tags being shred with other lists.
+ ;;(semantic--tag-put-property lastans :filename lastfile)
+ )
+ )
+
+ (if (and lastans calculated-scope)
+
+ ;; Put our discovered scope into the tag if we have a tag
+ (progn
+ (require 'semantic/scope)
+ (semantic-scope-tag-clone-with-scope
+ lastans (reverse (cdr calculated-scope))))
+
+ ;; Else, just return
+ lastans
+ ))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; BRUTISH Typecache
+;;
+;; Routines for a typecache that crosses all tables in a given database
+;; for a matching major-mode.
+(defmethod semanticdb-typecache-for-database ((db semanticdb-project-database)
+ &optional mode)
+ "Return the typecache for the project database DB.
+If there isn't one, create it.
+"
+ (let ((lmode (or mode major-mode))
+ (cache (semanticdb-get-typecache db))
+ (stream nil)
+ )
+ (dolist (table (semanticdb-get-database-tables db))
+ (when (eq lmode (oref table :major-mode))
+ (setq stream
+ (semanticdb-typecache-merge-streams
+ stream
+ (copy-sequence
+ (semanticdb-typecache-file-tags table))))
+ ))
+ (oset cache stream stream)
+ cache))
+
+(defun semanticdb-typecache-refresh-for-buffer (buffer)
+ "Refresh the typecache for BUFFER."
+ (save-excursion
+ (set-buffer buffer)
+ (let* ((tab semanticdb-current-table)
+ ;(idx (semanticdb-get-table-index tab))
+ (tc (semanticdb-get-typecache tab)))
+ (semanticdb-typecache-file-tags tab)
+ (semanticdb-typecache-include-tags tab)
+ tc)))
+
+
+;;; DEBUG
+;;
+(defun semanticdb-typecache-complete-flush ()
+ "Flush all typecaches referenced by the current buffer."
+ (interactive)
+ (let* ((path (semanticdb-find-translate-path nil nil)))
+ (dolist (P path)
+ (oset P pointmax nil)
+ (semantic-reset (semanticdb-get-typecache P)))))
+
+(defun semanticdb-typecache-dump ()
+ "Dump the typecache for the current buffer."
+ (interactive)
+ (require 'data-debug)
+ (let* ((start (current-time))
+ (tc (semanticdb-typecache-refresh-for-buffer (current-buffer)))
+ (end (current-time))
+ )
+ (data-debug-new-buffer "*TypeCache ADEBUG*")
+ (message "Calculating Cache took %.2f seconds."
+ (semantic-elapsed-time start end))
+
+ (data-debug-insert-thing tc "]" "")
+
+ ))
+
+(defun semanticdb-db-typecache-dump ()
+ "Dump the typecache for the current buffer's database."
+ (interactive)
+ (require 'data-debug)
+ (let* ((tab semanticdb-current-table)
+ (idx (semanticdb-get-table-index tab))
+ (junk (oset idx type-cache nil)) ;; flush!
+ (start (current-time))
+ (tc (semanticdb-typecache-for-database (oref tab parent-db)))
+ (end (current-time))
+ )
+ (data-debug-new-buffer "*TypeCache ADEBUG*")
+ (message "Calculating Cache took %.2f seconds."
+ (semantic-elapsed-time start end))
+
+ (data-debug-insert-thing tc "]" "")
+
+ ))
+
+(provide 'semantic/db-typecache)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/db-typecache"
+;; End:
+
+;;; semanticdb-typecache.el ends here
Index: cedet/semantic/db.el
===================================================================
RCS file: cedet/semantic/db.el
diff -N cedet/semantic/db.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/db.el 28 Sep 2009 15:15:08 -0000 1.2
@@ -0,0 +1,1026 @@
+;;; semantic/db.el --- Semantic tag database manager
+
+;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;;; 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: tags
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Maintain a database of tags for a group of files and enable
+;; queries into the database.
+;;
+;; By default, assume one database per directory.
+;;
+
+;;; Code:
+
+(require 'eieio-base)
+(require 'semantic)
+
+(declare-function semantic-lex-spp-save-table "semantic/lex-spp")
+
+;;; Variables:
+(defgroup semanticdb nil
+ "Parser Generator Persistent Database interface."
+ :group 'semantic)
+
+(defvar semanticdb-database-list nil
+ "List of all active databases.")
+
+(defvar semanticdb-new-database-class 'semanticdb-project-database-file
+ "The default type of database created for new files.
+This can be changed on a per file basis, so that some directories
+are saved using one mechanism, and some directories via a different
+mechanism.")
+(make-variable-buffer-local 'semanticdb-new-database-class)
+
+(defvar semanticdb-default-find-index-class 'semanticdb-find-search-index
+ "The default type of search index to use for a `semanticdb-table's.
+This can be changed to try out new types of search indicies.")
+(make-variable-buffer-local 'semanticdb-default-find=index-class)
+
+;;;###autoload
+(defvar semanticdb-current-database nil
+ "For a given buffer, this is the currently active database.")
+(make-variable-buffer-local 'semanticdb-current-database)
+
+;;;###autoload
+(defvar semanticdb-current-table nil
+ "For a given buffer, this is the currently active database table.")
+(make-variable-buffer-local 'semanticdb-current-table)
+
+;;; ABSTRACT CLASSES
+;;
+(defclass semanticdb-abstract-table ()
+ ((parent-db ;; :initarg :parent-db
+ ;; Do not set an initarg, or you get circular writes to disk.
+ :documentation "Database Object containing this table.")
+ (major-mode :initarg :major-mode
+ :initform nil
+ :documentation "Major mode this table belongs to.
+Sometimes it is important for a program to know if a given table has the
+same major mode as the current buffer.")
+ (tags :initarg :tags
+ :accessor semanticdb-get-tags
+ :printer semantic-tag-write-list-slot-value
+ :documentation "The tags belonging to this table.")
+ (index :type semanticdb-abstract-search-index
+ :documentation "The search index.
+Used by semanticdb-find to store additional information about
+this table for searching purposes.
+
+Note: This index will not be saved in a persistent file.")
+ (cache :type list
+ :initform nil
+ :documentation "List of cache information for tools.
+Any particular tool can cache data to a database at runtime
+with `semanticdb-cache-get'.
+
+Using a semanticdb cache does not save any information to a file,
+so your cache will need to be recalculated at runtime. Caches can be
+referenced even when the file is not in a buffer.
+
+Note: This index will not be saved in a persistent file.")
+ )
+ "A simple table for semantic tags.
+This table is the root of tables, and contains the minimum needed
+for a new table not associated with a buffer."
+ :abstract t)
+
+(defmethod semanticdb-in-buffer-p ((obj semanticdb-abstract-table))
+ "Return a nil, meaning abstract table OBJ is not in a buffer."
+ nil)
+
+(defmethod semanticdb-get-buffer ((obj semanticdb-abstract-table))
+ "Return a buffer associated with OBJ.
+If the buffer is not in memory, load it with `find-file-noselect'."
+ nil)
+
+(defmethod semanticdb-full-filename ((obj semanticdb-abstract-table))
+ "Fetch the full filename that OBJ refers to.
+Abstract tables do not have file names associated with them."
+ nil)
+
+(defmethod semanticdb-dirty-p ((obj semanticdb-abstract-table))
+ "Return non-nil if OBJ is 'dirty'."
+ nil)
+
+(defmethod semanticdb-set-dirty ((obj semanticdb-abstract-table))
+ "Mark the abstract table OBJ dirty.
+Abstract tables can not be marked dirty, as there is nothing
+for them to synchronize against."
+ ;; The abstract table can not be dirty.
+ nil)
+
+(defmethod semanticdb-normalize-tags ((obj semanticdb-abstract-table) tags)
+ "For the table OBJ, convert a list of TAGS, into standardized form.
+The default is to return TAGS.
+Some databases may default to searching and providing simplified tags
+based on whichever technique used. This method provides a hook for
+them to convert TAG into a more complete form."
+ tags)
+
+(defmethod semanticdb-normalize-one-tag ((obj semanticdb-abstract-table) tag)
+ "For the table OBJ, convert a TAG, into standardized form.
+This method returns a list of the form (DATABASE . NEWTAG).
+
+The default is to just return (OBJ TAG).
+
+Some databases may default to searching and providing simplified tags
+based on whichever technique used. This method provides a hook for
+them to convert TAG into a more complete form."
+ (cons obj tag))
+
+(defmethod object-print ((obj semanticdb-abstract-table) &rest strings)
+ "Pretty printer extension for `semanticdb-table'.
+Adds the number of tags in this file to the object print name."
+ (apply 'call-next-method obj
+ (cons (format " (%d tags)"
+ (length (semanticdb-get-tags obj))
+ )
+ strings)))
+
+;;; Index Cache
+;;
+(defclass semanticdb-abstract-search-index ()
+ ((table :initarg :table
+ :type semanticdb-abstract-table
+ :documentation "XRef to the table this belongs to.")
+ )
+ "A place where semanticdb-find can store search index information.
+The search index will store data about which other tables might be
+needed, or perhaps create hash or index tables for the current buffer."
+ :abstract t)
+
+(defmethod semanticdb-get-table-index ((obj semanticdb-abstract-table))
+ "Return the search index for the table OBJ.
+If one doesn't exist, create it."
+ (if (slot-boundp obj 'index)
+ (oref obj index)
+ (let ((idx nil))
+ (setq idx (funcall semanticdb-default-find-index-class
+ (concat (object-name obj) " index")
+ ;; Fill in the defaults
+ :table obj
+ ))
+ (oset obj index idx)
+ idx)))
+
+(defmethod semanticdb-synchronize ((idx semanticdb-abstract-search-index)
+ new-tags)
+ "Synchronize the search index IDX with some NEW-TAGS."
+ ;; The abstract class will do... NOTHING!
+ )
+
+(defmethod semanticdb-partial-synchronize ((idx
semanticdb-abstract-search-index)
+ new-tags)
+ "Synchronize the search index IDX with some changed NEW-TAGS."
+ ;; The abstract class will do... NOTHING!
+ )
+
+
+;;; SEARCH RESULTS TABLE
+;;
+;; Needed for system databases that may not provide
+;; a semanticdb-table associated with a file.
+;;
+(defclass semanticdb-search-results-table (semanticdb-abstract-table)
+ (
+ )
+ "Table used for search results when there is no file or table association.
+Examples include search results from external sources such as from
+Emacs' own symbol table, or from external libraries.")
+
+(defmethod semanticdb-refresh-table ((obj semanticdb-search-results-table)
&optional force)
+ "If the tag list associated with OBJ is loaded, refresh it.
+This will call `semantic-fetch-tags' if that file is in memory."
+ nil)
+
+;;; CONCRETE TABLE CLASSES
+;;
+(defclass semanticdb-table (semanticdb-abstract-table)
+ ((file :initarg :file
+ :documentation "File name relative to the parent database.
+This is for the file whose tags are stored in this TABLE object.")
+ (buffer :initform nil
+ :documentation "The buffer associated with this table.
+If nil, the table's buffer is no in Emacs. If it has a value, then
+it is in Emacs.")
+ (dirty :initform nil
+ :documentation
+ "Non nil if this table needs to be `Saved'.")
+ (db-refs :initform nil
+ :documentation
+ "List of `semanticdb-table' objects refering to this one.
+These aren't saved, but are instead recalculated after load.
+See the file semanticdb-ref.el for how this slot is used.")
+ (pointmax :initarg :pointmax
+ :initform nil
+ :documentation "Size of buffer when written to disk.
+Checked on retrieval to make sure the file is the same.")
+ (fsize :initarg :fsize
+ :initform nil
+ :documentation "Size of the file when it was last referenced.
+Checked when deciding if a loaded table needs updating from changes
+outside of Semantic's control.")
+ (lastmodtime :initarg :lastmodtime
+ :initform nil
+ :documentation "Last modification time of the file referenced.
+Checked when deciding if a loaded table needs updating from changes outside of
+Semantic's control.")
+ ;; @todo - need to add `last parsed time', so we can also have
+ ;; refresh checks if spp tables or the parser gets rebuilt.
+ (unmatched-syntax :initarg :unmatched-syntax
+ :documentation
+ "List of vectors specifying unmatched syntax.")
+
+ (lexical-table :initarg :lexical-table
+ :initform nil
+ :printer semantic-lex-spp-table-write-slot-value
+ :documentation
+ "Table that might be needed by the lexical analyzer.
+For C/C++, the C preprocessor macros can be saved here.")
+ )
+ "A single table of tags derived from file.")
+
+(defmethod semanticdb-in-buffer-p ((obj semanticdb-table))
+ "Return a buffer associated with OBJ.
+If the buffer is in memory, return that buffer."
+ (let ((buff (oref obj buffer)))
+ (if (buffer-live-p buff)
+ buff
+ (oset obj buffer nil))))
+
+(defmethod semanticdb-get-buffer ((obj semanticdb-table))
+ "Return a buffer associated with OBJ.
+If the buffer is in memory, return that buffer.
+If the buffer is not in memory, load it with `find-file-noselect'."
+ (or (semanticdb-in-buffer-p obj)
+ ;; Save match data to protect against odd stuff in mode hooks.
+ (save-match-data
+ (find-file-noselect (semanticdb-full-filename obj) t))))
+
+(defmethod semanticdb-set-buffer ((obj semanticdb-table))
+ "Set the current buffer to be a buffer owned by OBJ.
+If OBJ's file is not loaded, read it in first."
+ (set-buffer (semanticdb-get-buffer obj)))
+
+(defmethod semanticdb-full-filename ((obj semanticdb-table))
+ "Fetch the full filename that OBJ refers to."
+ (expand-file-name (oref obj file)
+ (oref (oref obj parent-db) reference-directory)))
+
+(defmethod semanticdb-dirty-p ((obj semanticdb-table))
+ "Return non-nil if OBJ is 'dirty'."
+ (oref obj dirty))
+
+(defmethod semanticdb-set-dirty ((obj semanticdb-table))
+ "Mark the abstract table OBJ dirty."
+ (oset obj dirty t)
+ )
+
+(defmethod object-print ((obj semanticdb-table) &rest strings)
+ "Pretty printer extension for `semanticdb-table'.
+Adds the number of tags in this file to the object print name."
+ (apply 'call-next-method obj
+ (cons (if (oref obj dirty) ", DIRTY" "") strings)))
+
+;;; DATABASE BASE CLASS
+;;
+(defclass semanticdb-project-database (eieio-instance-tracker)
+ ((tracking-symbol :initform semanticdb-database-list)
+ (reference-directory :type string
+ :documentation "Directory this database refers to.
+When a cache directory is specified, then this refers to the directory
+this database contains symbols for.")
+ (new-table-class :initform semanticdb-table
+ :type class
+ :documentation
+ "New tables created for this database are of this class.")
+ (cache :type list
+ :initform nil
+ :documentation "List of cache information for tools.
+Any particular tool can cache data to a database at runtime
+with `semanticdb-cache-get'.
+
+Using a semanticdb cache does not save any information to a file,
+so your cache will need to be recalculated at runtime.
+
+Note: This index will not be saved in a persistent file.")
+ (tables :initarg :tables
+ :type list
+ ;; Need this protection so apps don't try to access
+ ;; the tables without using the accessor.
+ :accessor semanticdb-get-database-tables
+ :protection :protected
+ :documentation "List of `semantic-db-table' objects."))
+ "Database of file tables.")
+
+(defmethod semanticdb-full-filename ((obj semanticdb-project-database))
+ "Fetch the full filename that OBJ refers to.
+Abstract tables do not have file names associated with them."
+ nil)
+
+(defmethod semanticdb-dirty-p ((DB semanticdb-project-database))
+ "Return non-nil if DB is 'dirty'.
+A database is dirty if the state of the database changed in a way
+where it may need to resynchronize with some persistent storage."
+ (let ((dirty nil)
+ (tabs (oref DB tables)))
+ (while (and (not dirty) tabs)
+ (setq dirty (semanticdb-dirty-p (car tabs)))
+ (setq tabs (cdr tabs)))
+ dirty))
+
+(defmethod object-print ((obj semanticdb-project-database) &rest strings)
+ "Pretty printer extension for `semanticdb-project-database'.
+Adds the number of tables in this file to the object print name."
+ (apply 'call-next-method obj
+ (cons (format " (%d tables%s)"
+ (length (semanticdb-get-database-tables obj))
+ (if (semanticdb-dirty-p obj)
+ " DIRTY" "")
+ )
+ strings)))
+
+(defmethod semanticdb-create-database :STATIC ((dbc
semanticdb-project-database) directory)
+ "Create a new semantic database of class DBC for DIRECTORY and return it.
+If a database for DIRECTORY has already been created, return it.
+If DIRECTORY doesn't exist, create a new one."
+ (let ((db (semanticdb-directory-loaded-p directory)))
+ (unless db
+ (setq db (semanticdb-project-database
+ (file-name-nondirectory directory)
+ :tables nil))
+ ;; Set this up here. We can't put it in the constructor because it
+ ;; would be saved, and we want DB files to be portable.
+ (oset db reference-directory (file-truename directory)))
+ db))
+
+(defmethod semanticdb-flush-database-tables ((db semanticdb-project-database))
+ "Reset the tables in DB to be empty."
+ (oset db tables nil))
+
+(defmethod semanticdb-create-table ((db semanticdb-project-database) file)
+ "Create a new table in DB for FILE and return it.
+The class of DB contains the class name for the type of table to create.
+If the table for FILE exists, return it.
+If the table for FILE does not exist, create one."
+ (let ((newtab (semanticdb-file-table db file)))
+ (unless newtab
+ ;; This implementation will satisfy autoloaded classes
+ ;; for tables.
+ (setq newtab (funcall (oref db new-table-class)
+ (file-name-nondirectory file)
+ :file (file-name-nondirectory file)
+ ))
+ (oset newtab parent-db db)
+ (object-add-to-list db 'tables newtab t))
+ newtab))
+
+(defmethod semanticdb-file-table ((obj semanticdb-project-database) filename)
+ "From OBJ, return FILENAME's associated table object."
+ (object-assoc (file-relative-name (file-truename filename)
+ (oref obj reference-directory))
+ 'file (oref obj tables)))
+
+;; DATABASE FUNCTIONS
+(defun semanticdb-get-database (filename)
+ "Get a database for FILENAME.
+If one isn't found, create one."
+ (semanticdb-create-database semanticdb-new-database-class (file-truename
filename)))
+
+(defun semanticdb-directory-loaded-p (path)
+ "Return the project belonging to PATH if it was already loaded."
+ (eieio-instance-tracker-find path 'reference-directory
'semanticdb-database-list))
+
+(defun semanticdb-create-table-for-file (filename)
+ "Initialize a database table for FILENAME, and return it.
+If FILENAME exists in the database already, return that.
+If there is no database for the table to live in, create one."
+ (let ((cdb nil)
+ (tbl nil)
+ (dd (file-name-directory filename))
+ )
+ ;; Allow a database override function
+ (setq cdb (semanticdb-create-database semanticdb-new-database-class
+ dd))
+ ;; Get a table for this file.
+ (setq tbl (semanticdb-create-table cdb filename))
+
+ ;; Return the pair.
+ (cons cdb tbl)
+ ))
+
+;;; Cache Cache.
+;;
+(defclass semanticdb-abstract-cache ()
+ ((table :initarg :table
+ :type semanticdb-abstract-table
+ :documentation
+ "Cross reference to the table this belongs to.")
+ )
+ "Abstract baseclass for tools to use to cache information in semanticdb.
+Tools needing a per-file cache must subclass this, and then get one as
+needed. Cache objects are identified in semanticdb by subclass.
+In order to keep your cache up to date, be sure to implement
+`semanticdb-synchronize', and `semanticdb-partial-synchronize'.
+See the file semantic-scope.el for an example."
+ :abstract t)
+
+(defmethod semanticdb-cache-get ((table semanticdb-abstract-table)
+ desired-class)
+ "Get a cache object on TABLE of class DESIRED-CLASS.
+This method will create one if none exists with no init arguments
+other than :table."
+ (assert (child-of-class-p desired-class 'semanticdb-abstract-cache))
+ (let ((cache (oref table cache))
+ (obj nil))
+ (while (and (not obj) cache)
+ (if (eq (object-class-fast (car cache)) desired-class)
+ (setq obj (car cache)))
+ (setq cache (cdr cache)))
+ (if obj
+ obj ;; Just return it.
+ ;; No object, lets create a new one and return that.
+ (setq obj (funcall desired-class "Cache" :table table))
+ (object-add-to-list table 'cache obj)
+ obj)))
+
+(defmethod semanticdb-cache-remove ((table semanticdb-abstract-table)
+ cache)
+ "Remove from TABLE the cache object CACHE."
+ (object-remove-from-list table 'cache cache))
+
+(defmethod semanticdb-synchronize ((cache semanticdb-abstract-cache)
+ new-tags)
+ "Synchronize a CACHE with some NEW-TAGS."
+ ;; The abstract class will do... NOTHING!
+ )
+
+(defmethod semanticdb-partial-synchronize ((cache semanticdb-abstract-cache)
+ new-tags)
+ "Synchronize a CACHE with some changed NEW-TAGS."
+ ;; The abstract class will do... NOTHING!
+ )
+
+(defclass semanticdb-abstract-db-cache ()
+ ((db :initarg :db
+ :type semanticdb-project-database
+ :documentation
+ "Cross reference to the database this belongs to.")
+ )
+ "Abstract baseclass for tools to use to cache information in semanticdb.
+Tools needing a database cache must subclass this, and then get one as
+needed. Cache objects are identified in semanticdb by subclass.
+In order to keep your cache up to date, be sure to implement
+`semanticdb-synchronize', and `semanticdb-partial-synchronize'.
+See the file semantic-scope.el for an example."
+ :abstract t)
+
+(defmethod semanticdb-cache-get ((db semanticdb-project-database)
+ desired-class)
+ "Get a cache object on DB of class DESIRED-CLASS.
+This method will create one if none exists with no init arguments
+other than :table."
+ (assert (child-of-class-p desired-class 'semanticdb-abstract-db-cache))
+ (let ((cache (oref db cache))
+ (obj nil))
+ (while (and (not obj) cache)
+ (if (eq (object-class-fast (car cache)) desired-class)
+ (setq obj (car cache)))
+ (setq cache (cdr cache)))
+ (if obj
+ obj ;; Just return it.
+ ;; No object, lets create a new one and return that.
+ (setq obj (funcall desired-class "Cache" :db db))
+ (object-add-to-list db 'cache obj)
+ obj)))
+
+(defmethod semanticdb-cache-remove ((db semanticdb-project-database)
+ cache)
+ "Remove from TABLE the cache object CACHE."
+ (object-remove-from-list db 'cache cache))
+
+
+(defmethod semanticdb-synchronize ((cache semanticdb-abstract-db-cache)
+ new-tags)
+ "Synchronize a CACHE with some NEW-TAGS."
+ ;; The abstract class will do... NOTHING!
+ )
+
+(defmethod semanticdb-partial-synchronize ((cache semanticdb-abstract-db-cache)
+ new-tags)
+ "Synchronize a CACHE with some changed NEW-TAGS."
+ ;; The abstract class will do... NOTHING!
+ )
+
+;;; REFRESH
+
+(defmethod semanticdb-refresh-table ((obj semanticdb-table) &optional force)
+ "If the tag list associated with OBJ is loaded, refresh it.
+Optional argument FORCE will force a refresh even if the file in question
+is not in a buffer. Avoid using FORCE for most uses, as an old cache
+may be sufficient for the general case. Forced updates can be slow.
+This will call `semantic-fetch-tags' if that file is in memory."
+ (when (or (semanticdb-in-buffer-p obj) force)
+ (save-excursion
+ (semanticdb-set-buffer obj)
+ (semantic-fetch-tags))))
+
+(defmethod semanticdb-needs-refresh-p ((obj semanticdb-table))
+ "Return non-nil of OBJ's tag list is out of date.
+The file associated with OBJ does not need to be in a buffer."
+ (let* ((ff (semanticdb-full-filename obj))
+ (buff (semanticdb-in-buffer-p obj))
+ )
+ (if buff
+ (save-excursion
+ (set-buffer buff)
+ ;; Use semantic's magic tracker to determine of the buffer is up
+ ;; to date or not.
+ (not (semantic-parse-tree-up-to-date-p))
+ ;; We assume that semanticdb is keeping itself up to date.
+ ;; via all the clever hooks
+ )
+ ;; Buffer isn't loaded. The only clue we have is if the file
+ ;; is somehow different from our mark in the semanticdb table.
+ (let* ((stats (file-attributes ff))
+ (actualsize (nth 7 stats))
+ (actualmod (nth 5 stats))
+ )
+
+ (or (not (slot-boundp obj 'tags))
+ ;; (not (oref obj tags)) --> not needed anymore?
+ (/= (or (oref obj fsize) 0) actualsize)
+ (not (equal (oref obj lastmodtime) actualmod))
+ )
+ ))))
+
+
+;;; Synchronization
+;;
+(defmethod semanticdb-synchronize ((table semanticdb-abstract-table)
+ new-tags)
+ "Synchronize the table TABLE with some NEW-TAGS."
+ (oset table tags new-tags)
+ (oset table pointmax (point-max))
+ (let ((fattr (file-attributes (semanticdb-full-filename table))))
+ (oset table fsize (nth 7 fattr))
+ (oset table lastmodtime (nth 5 fattr))
+ )
+ ;; Assume it is now up to date.
+ (oset table unmatched-syntax semantic-unmatched-syntax-cache)
+ ;; The lexical table should be good too.
+ (when (featurep 'semantic/lex-spp)
+ (oset table lexical-table (semantic-lex-spp-save-table)))
+ ;; this implies dirtyness
+ (semanticdb-set-dirty table)
+
+ ;; Synchronize the index
+ (when (slot-boundp table 'index)
+ (let ((idx (oref table index)))
+ (when idx (semanticdb-synchronize idx new-tags))))
+
+ ;; Synchronize application caches.
+ (dolist (C (oref table cache))
+ (semanticdb-synchronize C new-tags)
+ )
+
+ ;; Update cross references
+ ;; (semanticdb-refresh-references table)
+ )
+
+(defmethod semanticdb-partial-synchronize ((table semanticdb-abstract-table)
+ new-tags)
+ "Synchronize the table TABLE where some NEW-TAGS changed."
+ ;; You might think we need to reset the tags, but since the partial
+ ;; parser splices the lists, we don't need to do anything
+ ;;(oset table tags new-tags)
+ ;; We do need to mark ourselves dirty.
+ (semanticdb-set-dirty table)
+
+ ;; The lexical table may be modified.
+ (when (featurep 'semantic/lex-spp)
+ (oset table lexical-table (semantic-lex-spp-save-table)))
+
+ ;; Incremental parser doesn't mokey around with this.
+ (oset table unmatched-syntax semantic-unmatched-syntax-cache)
+
+ ;; Synchronize the index
+ (when (slot-boundp table 'index)
+ (let ((idx (oref table index)))
+ (when idx (semanticdb-partial-synchronize idx new-tags))))
+
+ ;; Synchronize application caches.
+ (dolist (C (oref table cache))
+ (semanticdb-synchronize C new-tags)
+ )
+
+ ;; Update cross references
+ ;;(when (semantic-find-tags-by-class 'include new-tags)
+ ;; (semanticdb-refresh-references table))
+ )
+
+;;; SAVE/LOAD
+;;
+(defmethod semanticdb-save-db ((DB semanticdb-project-database)
+ &optional supress-questions)
+ "Cause a database to save itself.
+The database base class does not save itself persistently.
+Subclasses could save themselves to a file, or to a database, or other
+form."
+ nil)
+
+(defun semanticdb-save-current-db ()
+ "Save the current tag database."
+ (interactive)
+ (message "Saving current tag summaries...")
+ (semanticdb-save-db semanticdb-current-database)
+ (message "Saving current tag summaries...done"))
+
+;; This prevents Semanticdb from querying multiple times if the users
+;; answers "no" to creating the Semanticdb directory.
+(defvar semanticdb--inhibit-create-file-directory)
+
+(defun semanticdb-save-all-db ()
+ "Save all semantic tag databases."
+ (interactive)
+ (message "Saving tag summaries...")
+ (let ((semanticdb--inhibit-make-directory nil))
+ (mapc 'semanticdb-save-db semanticdb-database-list))
+ (message "Saving tag summaries...done"))
+
+(defun semanticdb-save-all-db-idle ()
+ "Save all semantic tag databases from idle time.
+Exit the save between databases if there is user input."
+ (semantic-safe "Auto-DB Save: %S"
+ (semantic-exit-on-input 'semanticdb-idle-save
+ (mapc (lambda (db)
+ (semantic-throw-on-input 'semanticdb-idle-save)
+ (semanticdb-save-db db t))
+ semanticdb-database-list))
+ ))
+
+;;; Directory Project support
+;;
+(defvar semanticdb-project-predicate-functions nil
+ "List of predicates to try that indicate a directory belongs to a project.
+This list is used when `semanticdb-persistent-path' contains the value
+'project. If the predicate list is nil, then presume all paths are valid.
+
+Project Management software (such as EDE and JDE) should add their own
+predicates with `add-hook' to this variable, and semanticdb will save tag
+caches in directories controlled by them.")
+
+(defmethod semanticdb-write-directory-p ((obj semanticdb-project-database))
+ "Return non-nil if OBJ should be written to disk.
+Uses `semanticdb-persistent-path' to determine the return value."
+ nil)
+
+;;; Utilities
+;;
+;; What is the current database, are two tables of an equivalent mode,
+;; and what databases are a part of the same project.
+(defun semanticdb-current-database ()
+ "Return the currently active database."
+ (or semanticdb-current-database
+ (and default-directory
+ (semanticdb-create-database semanticdb-new-database-class
+ default-directory)
+ )
+ nil))
+
+(defvar semanticdb-match-any-mode nil
+ "Non-nil to temporarilly search any major mode for a tag.
+If a particular major mode wants to search any mode, put the
+`semantic-match-any-mode' symbol onto the symbol of that major mode.
+Do not set the value of this variable permanently.")
+
+(defmacro semanticdb-with-match-any-mode (&rest body)
+ "A Semanticdb search occuring withing BODY will search tags in all modes.
+This temporarilly sets `semanticdb-match-any-mode' while executing BODY."
+ `(let ((semanticdb-match-any-mode t))
+ ,@body))
+(put 'semanticdb-with-match-any-mode 'lisp-indent-function 0)
+
+(defmethod semanticdb-equivalent-mode-for-search (table &optional buffer)
+ "Return non-nil if TABLE's mode is equivalent to BUFFER.
+See `semanticdb-equivalent-mode' for details.
+This version is used during searches. Major-modes that opt
+to set the `semantic-match-any-mode' property will be able to search
+all files of any type."
+ (or (get major-mode 'semantic-match-any-mode)
+ semanticdb-match-any-mode
+ (semanticdb-equivalent-mode table buffer))
+ )
+
+(defmethod semanticdb-equivalent-mode ((table semanticdb-abstract-table)
&optional buffer)
+ "Return non-nil if TABLE's mode is equivalent to BUFFER.
+Equivalent modes are specified by by `semantic-equivalent-major-modes'
+local variable."
+ nil)
+
+(defmethod semanticdb-equivalent-mode ((table semanticdb-table) &optional
buffer)
+ "Return non-nil if TABLE's mode is equivalent to BUFFER.
+Equivalent modes are specified by by `semantic-equivalent-major-modes'
+local variable."
+ (save-excursion
+ (if buffer (set-buffer buffer))
+ (or
+ ;; nil major mode in table means we don't know yet. Assume yes for now?
+ (null (oref table major-mode))
+ ;; nil means the same as major-mode
+ (and (not semantic-equivalent-major-modes)
+ (mode-local-use-bindings-p major-mode (oref table major-mode)))
+ (and semantic-equivalent-major-modes
+ (member (oref table major-mode) semantic-equivalent-major-modes))
+ )
+ ))
+
+
+;;; Associations
+;;
+;; These routines determine associations between a file, and multiple
+;; associated databases.
+
+(defcustom semanticdb-project-roots nil
+ "*List of directories, where each directory is the root of some project.
+All subdirectories of a root project are considered a part of one project.
+Values in this string can be overriden by project management programs
+via the `semanticdb-project-root-functions' variable."
+ :group 'semanticdb
+ :type '(repeat string))
+
+(defvar semanticdb-project-root-functions nil
+ "List of functions used to determine a given directories project root.
+Functions in this variable can override `semanticdb-project-roots'.
+Functions set in the variable are given one argument (a directory) and
+must return a string, (the root directory) or a list of strings (multiple
+root directories in a more complex system). This variable should be used
+by project management programs like EDE or JDE.")
+
+(defvar semanticdb-project-system-databases nil
+ "List of databases containing system library information.
+Mode authors can create their own system databases which know
+detailed information about the system libraries for querying purposes.
+Put those into this variable as a buffer-local, or mode-local
+value.")
+(make-variable-buffer-local 'semanticdb-project-system-databases)
+
+(defvar semanticdb-search-system-databases t
+ "Non nil if search routines are to include a system database.")
+
+(defun semanticdb-current-database-list (&optional dir)
+ "Return a list of databases associated with the current buffer.
+If optional argument DIR is non-nil, then use DIR as the starting directory.
+If this buffer has a database, but doesn't have a project associated
+with it, return nil.
+First, it checks `semanticdb-project-root-functions', and if that
+has no results, it checks `semanticdb-project-roots'. If that fails,
+it returns the results of function `semanticdb-current-database'.
+Always append `semanticdb-project-system-databases' if
+`semanticdb-search-system' is non-nil."
+ (let ((root nil) ; found root directory
+ (dbs nil) ; collected databases
+ (roots semanticdb-project-roots) ;all user roots
+ (dir (file-truename (or dir default-directory)))
+ )
+ ;; Find the root based on project functions.
+ (setq root (run-hook-with-args-until-success
+ 'semanticdb-project-root-functions
+ dir))
+ ;; Find roots based on strings
+ (while (and roots (not root))
+ (let ((r (file-truename (car roots))))
+ (if (string-match (concat "^" (regexp-quote r)) dir)
+ (setq root r)))
+ (setq roots (cdr roots)))
+
+ ;; If no roots are found, use this directory.
+ (unless root (setq root dir))
+
+ ;; Find databases based on the root directory.
+ (when root
+ ;; The rootlist allows the root functions to possibly
+ ;; return several roots which are in different areas but
+ ;; all apart of the same system.
+ (let ((regexp (concat "^" (regexp-quote root)))
+ (adb semanticdb-database-list) ; all databases
+ )
+ (while adb
+ ;; I don't like this part, but close enough.
+ (if (and (slot-boundp (car adb) 'reference-directory)
+ (string-match regexp (oref (car adb) reference-directory)))
+ (setq dbs (cons (car adb) dbs)))
+ (setq adb (cdr adb))))
+ )
+ ;; Add in system databases
+ (when semanticdb-search-system-databases
+ (setq dbs (nconc dbs semanticdb-project-system-databases)))
+ ;; Return
+ dbs))
+
+
+;;; Generic Accessor Routines
+;;
+;; These routines can be used to get at tags in files w/out
+;; having to know a lot about semanticDB.
+(defvar semanticdb-file-table-hash (make-hash-table :test 'equal)
+ "Hash table mapping file names to database tables.")
+
+(defun semanticdb-file-table-object-from-hash (file)
+ "Retrieve a DB table from the hash for FILE.
+Does not use `file-truename'."
+ (gethash file semanticdb-file-table-hash 'no-hit))
+
+(defun semanticdb-file-table-object-put-hash (file dbtable)
+ "For FILE, associate DBTABLE in the hash table."
+ (puthash file dbtable semanticdb-file-table-hash))
+
+;;;###autoload
+(defun semanticdb-file-table-object (file &optional dontload)
+ "Return a semanticdb table belonging to FILE, make it up to date.
+If file has database tags available in the database, return it.
+If file does not have tags available, and DONTLOAD is nil,
+then load the tags for FILE, and create a new table object for it.
+DONTLOAD does not affect the creation of new database objects."
+ ;; (message "Object Translate: %s" file)
+ (when (file-exists-p file)
+ (let* ((default-directory (file-name-directory file))
+ (tab (semanticdb-file-table-object-from-hash file))
+ (fullfile nil))
+
+ ;; If it is not in the cache, then extract the more traditional
+ ;; way by getting the database, and finding a table in that database.
+ ;; Once we have a table, add it to the hash.
+ (when (eq tab 'no-hit)
+ (setq fullfile (file-truename file))
+ (let ((db (or ;; This line will pick up system databases.
+ (semanticdb-directory-loaded-p default-directory)
+ ;; this line will make a new one if needed.
+ (semanticdb-get-database default-directory))))
+ (setq tab (semanticdb-file-table db fullfile))
+ (when tab
+ (semanticdb-file-table-object-put-hash file tab)
+ (when (not (string= fullfile file))
+ (semanticdb-file-table-object-put-hash fullfile tab)
+ ))
+ ))
+
+ (cond
+ ((and tab
+ ;; Is this in a buffer?
+ ;;(find-buffer-visiting (semanticdb-full-filename tab))
+ (semanticdb-in-buffer-p tab)
+ )
+ (save-excursion
+ ;;(set-buffer (find-buffer-visiting (semanticdb-full-filename tab)))
+ (semanticdb-set-buffer tab)
+ (semantic-fetch-tags)
+ ;; Return the table.
+ tab))
+ ((and tab dontload)
+ ;; If we have table, and we don't want to load it, just return it.
+ tab)
+ ((and tab
+ ;; Is table fully loaded, or just a proxy?
+ (number-or-marker-p (oref tab pointmax))
+ ;; Is this table up to date with the file?
+ (not (semanticdb-needs-refresh-p tab)))
+ ;; A-ok!
+ tab)
+ ((or (and fullfile (get-file-buffer fullfile))
+ (get-file-buffer file))
+ ;; are these two calls this faster than `find-buffer-visiting'?
+
+ ;; If FILE is being visited, but none of the above state is
+ ;; true (meaning, there is no table object associated with it)
+ ;; then it is a file not supported by Semantic, and can be safely
+ ;; ignored.
+ nil)
+ ((not dontload) ;; We must load the file.
+ ;; Full file should have been set by now. Debug why not?
+ (when (and (not tab) (not fullfile))
+ ;; This case is if a 'nil is erroneously put into the hash table.
This
+ ;; would need fixing
+ (setq fullfile (file-truename file))
+ )
+
+ ;; If we have a table, but no fullfile, that's ok. Lets get the
filename
+ ;; from the table which is pre-truenamed.
+ (when (and (not fullfile) tab)
+ (setq fullfile (semanticdb-full-filename tab)))
+
+ (setq tab (semanticdb-create-table-for-file-not-in-buffer fullfile))
+
+ ;; Save the new table.
+ (semanticdb-file-table-object-put-hash file tab)
+ (when (not (string= fullfile file))
+ (semanticdb-file-table-object-put-hash fullfile tab)
+ )
+ ;; Done!
+ tab)
+ (t
+ ;; Full file should have been set by now. Debug why not?
+ ;; One person found this. Is it a file that failed to parse
+ ;; in the past?
+ (when (not fullfile)
+ (setq fullfile (file-truename file)))
+
+ ;; We were asked not to load the file in and parse it.
+ ;; Instead just create a database table with no tags
+ ;; and a claim of being empty.
+ ;;
+ ;; This will give us a starting point for storing
+ ;; database cross-references so when it is loaded,
+ ;; the cross-references will fire and caches will
+ ;; be cleaned.
+ (let ((ans (semanticdb-create-table-for-file file)))
+ (setq tab (cdr ans))
+
+ ;; Save the new table.
+ (semanticdb-file-table-object-put-hash file tab)
+ (when (not (string= fullfile file))
+ (semanticdb-file-table-object-put-hash fullfile tab)
+ )
+ ;; Done!
+ tab))
+ )
+ )))
+
+(defvar semanticdb-out-of-buffer-create-table-fcn nil
+ "When non-nil, a function for creating a semanticdb table.
+This should take a filename to be parsed.")
+(make-variable-buffer-local 'semanticdb-out-of-buffer-create-table-fcn)
+
+(defun semanticdb-create-table-for-file-not-in-buffer (filename)
+ "Create a table for the file FILENAME.
+If there are no language specific configurations, this
+function will read in the buffer, parse it, and kill the buffer."
+ (if (and semanticdb-out-of-buffer-create-table-fcn
+ (not (file-remote-p filename)))
+ ;; Use external parser only of the file is accessible to the
+ ;; local file system.
+ (funcall semanticdb-out-of-buffer-create-table-fcn filename)
+ (save-excursion
+ (let* ( ;; Remember the buffer to kill
+ (kill-buffer-flag (find-buffer-visiting filename))
+ (buffer-to-kill (or kill-buffer-flag
+ (semantic-find-file-noselect filename t))))
+
+ ;; This shouldn't ever be set. Debug some issue here?
+ ;; (when kill-buffer-flag (debug))
+
+ (set-buffer buffer-to-kill)
+ ;; Find file should automatically do this for us.
+ ;; Sometimes the DB table doesn't contains tags and needs
+ ;; a refresh. For example, when the file is loaded for
+ ;; the first time, and the idle scheduler didn't get a
+ ;; chance to trigger a parse before the file buffer is
+ ;; killed.
+ (when semanticdb-current-table
+ (semantic-fetch-tags))
+ (prog1
+ semanticdb-current-table
+ (when (not kill-buffer-flag)
+ ;; If we had to find the file, then we should kill it
+ ;; to keep the master buffer list clean.
+ (kill-buffer buffer-to-kill)
+ )))))
+ )
+
+(defun semanticdb-file-stream (file)
+ "Return a list of tags belonging to FILE.
+If file has database tags available in the database, return them.
+If file does not have tags available, then load the file, and create them."
+ (let ((table (semanticdb-file-table-object file)))
+ (when table
+ (semanticdb-get-tags table))))
+
+(provide 'semantic/db)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/db"
+;; End:
+
+;;; semantic/db.el ends here
Index: cedet/semantic/debug.el
===================================================================
RCS file: cedet/semantic/debug.el
diff -N cedet/semantic/debug.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/debug.el 28 Sep 2009 15:15:08 -0000 1.2
@@ -0,0 +1,576 @@
+;;; semantic/debug.el --- Language Debugger framework
+
+;;; Copyright (C) 2003, 2004, 2005, 2008 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; To provide better support for debugging parsers, this framework
+;; provides the interface for debugging. The work of parsing and
+;; controlling and stepping through the parsing work must be implemented
+;; by the parser.
+;;
+;; Fortunatly, the nature of language support files means that the parser
+;; may not need to be instrumented first.
+;;
+;; The debugger uses EIEIO objects. One object controls the user
+;; interface, including stepping, data-view, queries. A second
+;; object implemented here represents the parser itself. A third represents
+;; a parser independent frame which knows how to highlight the parser buffer.
+;; Each parser must implement the interface and override any methods as needed.
+;;
+
+(require 'semantic)
+(require 'eieio)
+(eval-when-compile (require 'semantic/find))
+
+;;; Code:
+
+;;;###autoload
+(defvar semantic-debug-parser-source nil
+ "For any buffer, the file name (no path) of the parser.
+This would be a parser for a specific language, not the source
+to one of the parser generators.")
+;;;###autoload
+(make-variable-buffer-local 'semantic-debug-parser-source)
+
+;;;###autoload
+(defvar semantic-debug-parser-class nil
+ "Class to create when building a debug parser object.")
+;;;###autoload
+(make-variable-buffer-local 'semantic-debug-parser-class)
+
+(defvar semantic-debug-enabled nil
+ "Non-nil when debugging a parser.")
+
+;;; Variables used during a debug session.
+(defvar semantic-debug-current-interface nil
+ "The debugger interface currently active for this buffer.")
+
+(defvar semantic-debug-current-parser nil
+ "The parser current active for this buffer.")
+
+;;; User Interface Portion
+;;
+(defclass semantic-debug-interface ()
+ ((parser-buffer :initarg :parser-buffer
+ :type buffer
+ :documentation
+ "The buffer containing the parser we are debugging.")
+ (parser-local-map :initarg :parser-local-map
+ :type keymap
+ :documentation
+ "The local keymap originally in the PARSER buffer.")
+ (parser-location :type marker
+ :documentation
+ "A marker representing where we are in the parser buffer.")
+ (source-buffer :initarg :source-buffer
+ :type buffer
+ :documentation
+ "The buffer containing the source we are parsing.
+The :parser-buffer defines a parser that can parse the text in the
+:source-buffer.")
+ (source-local-map :initarg :source-local-map
+ :type keymap
+ :documentation
+ "The local keymap originally in the SOURCE buffer.")
+ (source-location :type marker
+ :documentation
+ "A marker representing where we are in the parser buffer.")
+ (data-buffer :initarg :data-buffer
+ :type buffer
+ :documentation
+ "Buffer being used to display some useful data.
+These buffers are brought into view when layout occurs.")
+ (current-frame :type semantic-debug-frame
+ :documentation
+ "The currently displayed frame.")
+ (overlays :type list
+ :initarg nil
+ :documentation
+ "Any active overlays being used to show the debug position.")
+ )
+ "Controls action when in `semantic-debug-mode'")
+
+;; Methods
+(defmethod semantic-debug-set-frame ((iface semantic-debug-interface) frame)
+ "Set the current frame on IFACE to FRAME."
+ (if frame
+ (oset iface current-frame frame)
+ (slot-makeunbound iface 'current-frame)))
+
+(defmethod semantic-debug-set-parser-location ((iface
semantic-debug-interface) point)
+ "Set the parser location in IFACE to POINT."
+ (save-excursion
+ (set-buffer (oref iface parser-buffer))
+ (if (not (slot-boundp iface 'parser-location))
+ (oset iface parser-location (make-marker)))
+ (move-marker (oref iface parser-location) point))
+ )
+
+(defmethod semantic-debug-set-source-location ((iface
semantic-debug-interface) point)
+ "Set the source location in IFACE to POINT."
+ (save-excursion
+ (set-buffer (oref iface source-buffer))
+ (if (not (slot-boundp iface 'source-location))
+ (oset iface source-location (make-marker)))
+ (move-marker (oref iface source-location) point))
+ )
+
+(defmethod semantic-debug-interface-layout ((iface semantic-debug-interface))
+ "Layout windows in the current frame to facilitate debugging."
+ (delete-other-windows)
+ ;; Deal with the data buffer
+ (when (slot-boundp iface 'data-buffer)
+ (let ((lines (/ (frame-height (selected-frame)) 3))
+ (cnt (save-excursion
+ (set-buffer (oref iface data-buffer))
+ (count-lines (point-min) (point-max))))
+ )
+ ;; Set the number of lines to 1/3, or the size of the data buffer.
+ (if (< cnt lines) (setq cnt lines))
+
+ (split-window-vertically cnt)
+ (switch-to-buffer (oref iface data-buffer))
+ )
+ (other-window 1))
+ ;; Parser
+ (switch-to-buffer (oref iface parser-buffer))
+ (when (slot-boundp iface 'parser-location)
+ (goto-char (oref iface parser-location)))
+ (split-window-vertically)
+ (other-window 1)
+ ;; Source
+ (switch-to-buffer (oref iface source-buffer))
+ (when (slot-boundp iface 'source-location)
+ (goto-char (oref iface source-location)))
+ )
+
+(defmethod semantic-debug-highlight-lexical-token ((iface
semantic-debug-interface) token)
+ "For IFACE, highlight TOKEN in the source buffer .
+TOKEN is a lexical token."
+ (set-buffer (oref iface :source-buffer))
+
+ (object-add-to-list iface 'overlays
+ (semantic-lex-highlight-token token))
+
+ (semantic-debug-set-source-location iface (semantic-lex-token-start token))
+ )
+
+(defmethod semantic-debug-highlight-rule ((iface semantic-debug-interface)
nonterm &optional rule match)
+ "For IFACE, highlight NONTERM in the parser buffer.
+NONTERM is the name of the rule currently being processed that shows up
+as a nonterminal (or tag) in the source buffer.
+If RULE and MATCH indicies are specified, highlight those also."
+ (set-buffer (oref iface :parser-buffer))
+
+ (let* ((rules (semantic-find-tags-by-class 'nonterminal (current-buffer)))
+ (nt (semantic-find-first-tag-by-name nonterm rules))
+ (o nil)
+ )
+ (when nt
+ ;; I know it is the first symbol appearing in the body of this token.
+ (goto-char (semantic-tag-start nt))
+
+ (setq o (semantic-make-overlay (point) (progn (forward-sexp 1) (point))))
+ (semantic-overlay-put o 'face 'highlight)
+
+ (object-add-to-list iface 'overlays o)
+
+ (semantic-debug-set-parser-location iface (semantic-overlay-start o))
+
+ (when (and rule match)
+
+ ;; Rule, an int, is the rule inside the nonterminal we are following.
+ (re-search-forward ":\\s-*")
+ (while (/= 0 rule)
+ (re-search-forward "^\\s-*|\\s-*")
+ (setq rule (1- rule)))
+
+ ;; Now find the match inside the rule
+ (while (/= 0 match)
+ (forward-sexp 1)
+ (skip-chars-forward " \t")
+ (setq match (1- match)))
+
+ ;; Now highlight the thingy we find there.
+ (setq o (semantic-make-overlay (point) (progn (forward-sexp 1)
(point))))
+ (semantic-overlay-put o 'face 'highlight)
+
+ (object-add-to-list iface 'overlays o)
+
+ ;; If we have a match for a sub-rule, have the parser position
+ ;; move so we can see it in the output window for very long rules.
+ (semantic-debug-set-parser-location iface (semantic-overlay-start o))
+
+ ))))
+
+(defmethod semantic-debug-unhighlight ((iface semantic-debug-interface))
+ "Remove all debugging overlays."
+ (mapc 'semantic-overlay-delete (oref iface overlays))
+ (oset iface overlays nil))
+
+;; Call from the parser at a breakpoint
+(defvar semantic-debug-user-command nil
+ "The command the user is requesting.")
+
+(defun semantic-debug-break (frame)
+ "Stop parsing now at FRAME.
+FRAME is an object that represents the parser's view of the
+current state of the world.
+This function enters a recursive edit. It returns
+on an `exit-recursive-edit', or if someone uses one
+of the `semantic-debug-mode' commands.
+It returns the command specified. Parsers need to take action
+on different types of return values."
+ (save-window-excursion
+ ;; Set up displaying information
+ (semantic-debug-mode t)
+ (unwind-protect
+ (progn
+ (semantic-debug-frame-highlight frame)
+ (semantic-debug-interface-layout semantic-debug-current-interface)
+ (condition-case nil
+ ;; Enter recursive edit... wait for user command.
+ (recursive-edit)
+ (error nil)))
+ (semantic-debug-unhighlight semantic-debug-current-interface)
+ (semantic-debug-mode nil))
+ ;; Find the requested user state. Do something.
+ (let ((returnstate semantic-debug-user-command))
+ (setq semantic-debug-user-command nil)
+ returnstate)
+ ))
+
+;;; Frame
+;;
+;; A frame can represent the state at a break point.
+(defclass semantic-debug-frame ()
+ (
+ )
+ "One frame representation.")
+
+(defmethod semantic-debug-frame-highlight ((frame semantic-debug-frame))
+ "Highlight one parser frame."
+
+ )
+
+(defmethod semantic-debug-frame-info ((frame semantic-debug-frame))
+ "Display info about this one parser frame."
+
+ )
+
+;;; Major Mode
+;;
+(defvar semantic-debug-mode-map
+ (let ((km (make-sparse-keymap)))
+ (define-key km "n" 'semantic-debug-next)
+ (define-key km " " 'semantic-debug-next)
+ (define-key km "s" 'semantic-debug-step)
+ (define-key km "u" 'semantic-debug-up)
+ (define-key km "d" 'semantic-debug-down)
+ (define-key km "f" 'semantic-debug-fail-match)
+ (define-key km "h" 'semantic-debug-print-state)
+ (define-key km "s" 'semantic-debug-jump-to-source)
+ (define-key km "p" 'semantic-debug-jump-to-parser)
+ (define-key km "q" 'semantic-debug-quit)
+ (define-key km "a" 'semantic-debug-abort)
+ (define-key km "g" 'semantic-debug-go)
+ (define-key km "b" 'semantic-debug-set-breakpoint)
+ ;; Some boring bindings.
+ (define-key km "e" 'eval-expression)
+
+ km)
+ "Keymap used when in semantic-debug-node.")
+
+(defun semantic-debug-mode (onoff)
+ "Turn `semantic-debug-mode' on and off.
+Argument ONOFF is non-nil when we are entering debug mode.
+\\{semantic-debug-mode-map}"
+ (let ((iface semantic-debug-current-interface))
+ (if onoff
+ ;; Turn it on
+ (save-excursion
+ (set-buffer (oref iface parser-buffer))
+ ;; Install our map onto this buffer
+ (use-local-map semantic-debug-mode-map)
+ ;; Make the buffer read only
+ (toggle-read-only 1)
+
+ (set-buffer (oref iface source-buffer))
+ ;; Use our map in the source buffer also
+ (use-local-map semantic-debug-mode-map)
+ ;; Make the buffer read only
+ (toggle-read-only 1)
+ ;; Hooks
+ (run-hooks 'semantic-debug-mode-hook)
+ )
+ ;; Restore old mode information
+ (save-excursion
+ (set-buffer
+ (oref semantic-debug-current-interface parser-buffer))
+ (use-local-map
+ (oref semantic-debug-current-interface parser-local-map))
+ )
+ (save-excursion
+ (set-buffer
+ (oref semantic-debug-current-interface source-buffer))
+ (use-local-map
+ (oref semantic-debug-current-interface source-local-map))
+ )
+ (run-hooks 'semantic-debug-exit-hook)
+ )))
+
+(defun semantic-debug ()
+ "Parse the current buffer and run in debug mode."
+ (interactive)
+ (if semantic-debug-current-interface
+ (error "You are already in a debug session"))
+ (if (not semantic-debug-parser-class)
+ (error "This major mode does not support parser debugging"))
+ ;; Clear the cache to force a full reparse.
+ (semantic-clear-toplevel-cache)
+ ;; Do the parse
+ (let ((semantic-debug-enabled t)
+ ;; Create an interface
+ (semantic-debug-current-interface
+ (let ((parserb (semantic-debug-find-parser-source)))
+ (semantic-debug-interface
+ "Debug Interface"
+ :parser-buffer parserb
+ :parser-local-map (save-excursion
+ (set-buffer parserb)
+ (current-local-map))
+ :source-buffer (current-buffer)
+ :source-local-map (current-local-map)
+ )))
+ ;; Create a parser debug interface
+ (semantic-debug-current-parser
+ (funcall semantic-debug-parser-class "parser"))
+ )
+ ;; We could recurse into a parser while debugging.
+ ;; Is that a problem?
+ (semantic-fetch-tags)
+ ;; We should turn the auto-parser back on, but don't do it for
+ ;; now until the debugger is working well.
+ ))
+
+(defun semantic-debug-find-parser-source ()
+ "Return a buffer containing the parser source file for the current buffer.
+The parser needs to be on the load path, or this routine returns nil."
+ (if (not semantic-debug-parser-source)
+ (error "No parser is associated with this buffer"))
+ (let ((parser (locate-library semantic-debug-parser-source t)))
+ (if parser
+ (find-file-noselect parser)
+ (error "Cannot find parser source. It should be on the load-path"))))
+
+;;; Debugger commands
+;;
+(defun semantic-debug-next ()
+ "Perform one parser operation.
+In the recursive parser, this steps past one match rule.
+In other parsers, this may be just like `semantic-debug-step'."
+ (interactive)
+ (let ((parser semantic-debug-current-parser))
+ (semantic-debug-parser-next parser)
+ (exit-recursive-edit)
+ )
+ )
+
+(defun semantic-debug-step ()
+ "Perform one parser operation."
+ (interactive)
+ (let ((parser semantic-debug-current-parser))
+ (semantic-debug-parser-step parser)
+ (exit-recursive-edit)
+ )
+ )
+
+(defun semantic-debug-up ()
+ "Move highlighting representation up one level."
+ (interactive)
+ (message "Not implemented yet.")
+ )
+
+(defun semantic-debug-down ()
+ "Move highlighting representation down one level."
+ (interactive)
+ (message "Not implemented yet.")
+ )
+
+(defun semantic-debug-fail-match ()
+ "Artificially fail the current match."
+ (interactive)
+ (let ((parser semantic-debug-current-parser))
+ (semantic-debug-parser-fail parser)
+ (exit-recursive-edit)
+ )
+ )
+
+(defun semantic-debug-print-state ()
+ "Show interesting parser state."
+ (interactive)
+ (let ((parser semantic-debug-current-parser))
+ (semantic-debug-parser-print-state parser)
+ )
+ )
+
+(defun semantic-debug-jump-to-source ()
+ "Move cursor to the source code being parsed at the current lexical token."
+ (interactive)
+ (let* ((interface semantic-debug-current-interface)
+ (buf (oref interface source-buffer)))
+ (if (get-buffer-window buf)
+ (progn
+ (select-frame (window-frame (get-buffer-window buf)))
+ (select-window (get-buffer-window buf)))
+ ;; Technically, this should do a window layout operation
+ (switch-to-buffer buf))
+ )
+ )
+
+(defun semantic-debug-jump-to-parser ()
+ "Move cursor to the parser being debugged."
+ (interactive)
+ (let* ((interface semantic-debug-current-interface)
+ (buf (oref interface parser-buffer)))
+ (if (get-buffer-window buf)
+ (progn
+ (select-frame (window-frame (get-buffer-window buf)))
+ (select-window (get-buffer-window buf)))
+ ;; Technically, this should do a window layout operation
+ (switch-to-buffer buf))
+ )
+ )
+
+(defun semantic-debug-quit ()
+ "Exit debug mode, blowing all stack, and leaving the parse incomplete.
+Do not update any tokens already parsed."
+ (interactive)
+ (let ((parser semantic-debug-current-parser))
+ (semantic-debug-parser-quit parser)
+ (exit-recursive-edit)
+ )
+ )
+
+(defun semantic-debug-abort ()
+ "Abort one level of debug mode, blowing all stack."
+ (interactive)
+ (let ((parser semantic-debug-current-parser))
+ (semantic-debug-parser-abort parser)
+ (exit-recursive-edit)
+ )
+ )
+
+(defun semantic-debug-go ()
+ "Continue parsing till finish or breakpoint."
+ (interactive)
+ (let ((parser semantic-debug-current-parser))
+ (semantic-debug-parser-go parser)
+ (exit-recursive-edit)
+ )
+ )
+
+(defun semantic-debug-set-breakpoint ()
+ "Set a breakpoint at the current rule location."
+ (interactive)
+ (let ((parser semantic-debug-current-parser)
+ ;; Get the location as semantic tokens.
+ (location (semantic-current-tag))
+ )
+ (if location
+ (semantic-debug-parser-break parser location)
+ (error "Not on a rule"))
+ )
+ )
+
+
+;;; Debugger superclass
+;;
+(defclass semantic-debug-parser ()
+ (
+ )
+ "Represents a parser and its state.
+When implementing the debug parser you can add extra functionality
+by overriding one of the command methods. Be sure to use
+`call-next-method' so that the debug command is saved, and passed
+down to your parser later."
+ :abstract t)
+
+(defmethod semantic-debug-parser-next ((parser semantic-debug-parser))
+ "Execute next for this PARSER."
+ (setq semantic-debug-user-command 'next)
+ )
+
+(defmethod semantic-debug-parser-step ((parser semantic-debug-parser))
+ "Execute a step for this PARSER."
+ (setq semantic-debug-user-command 'step)
+ )
+
+(defmethod semantic-debug-parser-go ((parser semantic-debug-parser))
+ "Continue executiong in this PARSER until the next breakpoint."
+ (setq semantic-debug-user-command 'go)
+ )
+
+(defmethod semantic-debug-parser-fail ((parser semantic-debug-parser))
+ "Continue executiong in this PARSER until the next breakpoint."
+ (setq semantic-debug-user-command 'fail)
+ )
+
+(defmethod semantic-debug-parser-quit ((parser semantic-debug-parser))
+ "Continue executiong in this PARSER until the next breakpoint."
+ (setq semantic-debug-user-command 'quit)
+ )
+
+(defmethod semantic-debug-parser-abort ((parser semantic-debug-parser))
+ "Continue executiong in this PARSER until the next breakpoint."
+ (setq semantic-debug-user-command 'abort)
+ )
+
+(defmethod semantic-debug-parser-print-state ((parser semantic-debug-parser))
+ "Print state for this PARSER at the current breakpoint."
+ (with-slots (current-frame) semantic-debug-current-interface
+ (when current-frame
+ (semantic-debug-frame-info current-frame)
+ )))
+
+(defmethod semantic-debug-parser-break ((parser semantic-debug-parser))
+ "Set a breakpoint for this PARSER."
+ )
+
+;; Stack stuff
+(defmethod semantic-debug-parser-frames ((parser semantic-debug-parser))
+ "Return a list of frames for the current parser.
+A frame is of the form:
+ ( .. .what ? .. )
+"
+ (error "Parser has not implemented frame values")
+ )
+
+
+(provide 'semantic/debug)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/debug"
+;; End:
+
+;;; semantic/debug.el ends here
Index: cedet/semantic/decorate.el
===================================================================
RCS file: cedet/semantic/decorate.el
diff -N cedet/semantic/decorate.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/decorate.el 28 Sep 2009 15:15:08 -0000 1.2
@@ -0,0 +1,299 @@
+;;; semantic/decorate.el --- Utilities for decorating/highlighting tokens.
+
+;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2005, 2006, 2007, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Text representing a semantic tag is wrapped in an overlay.
+;; This overlay can be used for highlighting, or setting other
+;; editing properties on a tag, such as "read only."
+;;
+
+(require 'semantic)
+(require 'pulse)
+
+;;; Code:
+
+;;; Highlighting Basics
+(defun semantic-highlight-tag (tag &optional face)
+ "Specify that TAG should be highlighted.
+Optional FACE specifies the face to use."
+ (let ((o (semantic-tag-overlay tag)))
+ (semantic-overlay-put o 'old-face
+ (cons (semantic-overlay-get o 'face)
+ (semantic-overlay-get o 'old-face)))
+ (semantic-overlay-put o 'face (or face 'semantic-tag-highlight-face))
+ ))
+
+(defun semantic-unhighlight-tag (tag)
+ "Unhighlight TAG, restoring it's previous face."
+ (let ((o (semantic-tag-overlay tag)))
+ (semantic-overlay-put o 'face (car (semantic-overlay-get o 'old-face)))
+ (semantic-overlay-put o 'old-face (cdr (semantic-overlay-get o 'old-face)))
+ ))
+
+;;; Momentary Highlighting - One line
+(defun semantic-momentary-highlight-one-tag-line (tag &optional face)
+ "Highlight the first line of TAG, unhighlighting before next command.
+Optional argument FACE specifies the face to do the highlighting."
+ (save-excursion
+ ;; Go to first line in tag
+ (semantic-go-to-tag tag)
+ (pulse-momentary-highlight-one-line (point))))
+
+;;; Momentary Highlighting - Whole Tag
+(defun semantic-momentary-highlight-tag (tag &optional face)
+ "Highlight TAG, removing highlighting when the user hits a key.
+Optional argument FACE is the face to use for highlighting.
+If FACE is not specified, then `highlight' will be used."
+ (when (semantic-tag-with-position-p tag)
+ (if (not (semantic-overlay-p (semantic-tag-overlay tag)))
+ ;; No overlay, but a position. Highlight the first line only.
+ (semantic-momentary-highlight-one-tag-line tag face)
+ ;; The tag has an overlay, highlight the whole thing
+ (pulse-momentary-highlight-overlay (semantic-tag-overlay tag)
+ face)
+ )))
+
+(defun semantic-set-tag-face (tag face)
+ "Specify that TAG should use FACE for display."
+ (semantic-overlay-put (semantic-tag-overlay tag) 'face face))
+
+(defun semantic-set-tag-invisible (tag &optional visible)
+ "Enable the text in TAG to be made invisible.
+If VISIBLE is non-nil, make the text visible."
+ (semantic-overlay-put (semantic-tag-overlay tag) 'invisible
+ (not visible)))
+
+(defun semantic-tag-invisible-p (tag)
+ "Return non-nil if TAG is invisible."
+ (semantic-overlay-get (semantic-tag-overlay tag) 'invisible))
+
+(defun semantic-set-tag-intangible (tag &optional tangible)
+ "Enable the text in TAG to be made intangible.
+If TANGIBLE is non-nil, make the text visible.
+This function does not have meaning in XEmacs because it seems that
+the extent 'intangible' property does not exist."
+ (semantic-overlay-put (semantic-tag-overlay tag) 'intangible
+ (not tangible)))
+
+(defun semantic-tag-intangible-p (tag)
+ "Return non-nil if TAG is intangible.
+This function does not have meaning in XEmacs because it seems that
+the extent 'intangible' property does not exist."
+ (semantic-overlay-get (semantic-tag-overlay tag) 'intangible))
+
+(defun semantic-overlay-signal-read-only
+ (overlay after start end &optional len)
+ "Hook used in modification hooks to prevent modification.
+Allows deletion of the entire text.
+Argument OVERLAY, AFTER, START, END, and LEN are passed in by the system."
+ ;; Stolen blithly from cpp.el in Emacs 21.1
+ (if (and (not after)
+ (or (< (semantic-overlay-start overlay) start)
+ (> (semantic-overlay-end overlay) end)))
+ (error "This text is read only")))
+
+(defun semantic-set-tag-read-only (tag &optional writable)
+ "Enable the text in TAG to be made read-only.
+Optional argument WRITABLE should be non-nil to make the text writable
+instead of read-only."
+ (let ((o (semantic-tag-overlay tag))
+ (hook (if writable nil '(semantic-overlay-signal-read-only))))
+ (if (featurep 'xemacs)
+ ;; XEmacs extents have a 'read-only' property.
+ (semantic-overlay-put o 'read-only (not writable))
+ (semantic-overlay-put o 'modification-hooks hook)
+ (semantic-overlay-put o 'insert-in-front-hooks hook)
+ (semantic-overlay-put o 'insert-behind-hooks hook))))
+
+(defun semantic-tag-read-only-p (tag)
+ "Return non-nil if the current TAG is marked read only."
+ (let ((o (semantic-tag-overlay tag)))
+ (if (featurep 'xemacs)
+ ;; XEmacs extents have a 'read-only' property.
+ (semantic-overlay-get o 'read-only)
+ (member 'semantic-overlay-signal-read-only
+ (semantic-overlay-get o 'modification-hooks)))))
+
+;;; Secondary overlays
+;;
+;; Some types of decoration require a second overlay to be made.
+;; It could be for images, arrows, or whatever.
+;; We need a way to create such an overlay, and make sure it
+;; gets whacked, but doesn't show up in the master list
+;; of overlays used for searching.
+(defun semantic-tag-secondary-overlays (tag)
+ "Return a list of secondary overlays active on TAG."
+ (semantic--tag-get-property tag 'secondary-overlays))
+
+(defun semantic-tag-create-secondary-overlay (tag &optional link-hook)
+ "Create a secondary overlay for TAG.
+Returns an overlay. The overlay is also saved in TAG.
+LINK-HOOK is a function called whenever TAG is to be linked into
+a buffer. It should take TAG and OVERLAY as arguments.
+The LINK-HOOK should be used to position and set properties on the
+generated secondary overlay."
+ (if (not (semantic-tag-overlay tag))
+ ;; do nothing if there is no overlay
+ nil
+ (let* ((os (semantic-tag-start tag))
+ (oe (semantic-tag-end tag))
+ (o (semantic-make-overlay os oe (semantic-tag-buffer tag) t))
+ (attr (semantic-tag-secondary-overlays tag))
+ )
+ (semantic--tag-put-property tag 'secondary-overlays (cons o attr))
+ (semantic-overlay-put o 'semantic-secondary t)
+ (semantic-overlay-put o 'semantic-link-hook link-hook)
+ (semantic-tag-add-hook tag 'link-hook
'semantic--tag-link-secondary-overlays)
+ (semantic-tag-add-hook tag 'unlink-hook
'semantic--tag-unlink-secondary-overlays)
+ (semantic-tag-add-hook tag 'unlink-copy-hook
'semantic--tag-unlink-copy-secondary-overlays)
+ (run-hook-with-args link-hook tag o)
+ o)))
+
+(defun semantic-tag-get-secondary-overlay (tag property)
+ "Return secondary overlays from TAG with PROPERTY.
+PROPERTY is a symbol and all overlays with that symbol are returned.."
+ (let* ((olsearch (semantic-tag-secondary-overlays tag))
+ (o nil))
+ (while olsearch
+ (when (semantic-overlay-get (car olsearch) property)
+ (setq o (cons (car olsearch) o)))
+ (setq olsearch (cdr olsearch)))
+ o))
+
+(defun semantic-tag-delete-secondary-overlay (tag overlay-or-property)
+ "Delete from TAG the secondary overlay OVERLAY-OR-PROPERTY.
+If OVERLAY-OR-PROPERTY is an overlay, delete that overlay.
+If OVERLAY-OR-PROPERTY is a symbol, find the overlay with that property."
+ (let* ((o overlay-or-property))
+ (if (semantic-overlay-p o)
+ (setq o (list o))
+ (setq o (semantic-tag-get-secondary-overlay tag overlay-or-property)))
+ (while (semantic-overlay-p (car o))
+ ;; We don't really need to worry about the hooks.
+ ;; They will clean themselves up eventually ??
+ (semantic--tag-put-property
+ tag 'secondary-overlays
+ (delete (car o) (semantic-tag-secondary-overlays tag)))
+ (semantic-overlay-delete (car o))
+ (setq o (cdr o)))))
+
+(defun semantic--tag-unlink-copy-secondary-overlays (tag)
+ "Unlink secondary overlays from TAG which is a copy.
+This means we don't destroy the overlays, only remove reference
+from them in TAG."
+ (let ((ol (semantic-tag-secondary-overlays tag)))
+ (while ol
+ ;; Else, remove all traces of ourself from the tag
+ ;; Note to self: Does this prevent multiple types of secondary
+ ;; overlays per tag?
+ (semantic-tag-remove-hook tag 'link-hook
'semantic--tag-link-secondary-overlays)
+ (semantic-tag-remove-hook tag 'unlink-hook
'semantic--tag-unlink-secondary-overlays)
+ (semantic-tag-remove-hook tag 'unlink-copy-hook
'semantic--tag-unlink-copy-secondary-overlays)
+ ;; Next!
+ (setq ol (cdr ol)))
+ (semantic--tag-put-property tag 'secondary-overlays nil)
+ ))
+
+(defun semantic--tag-unlink-secondary-overlays (tag)
+ "Unlink secondary overlays from TAG."
+ (let ((ol (semantic-tag-secondary-overlays tag))
+ (nl nil))
+ (while ol
+ (if (semantic-overlay-get (car ol) 'semantic-link-hook)
+ ;; Only put in a proxy if there is a link-hook. If there is no
link-hook
+ ;; the decorating mode must know when tags are unlinked on its own.
+ (setq nl (cons (semantic-overlay-get (car ol) 'semantic-link-hook)
+ nl))
+ ;; Else, remove all traces of ourself from the tag
+ ;; Note to self: Does this prevent multiple types of secondary
+ ;; overlays per tag?
+ (semantic-tag-remove-hook tag 'link-hook
'semantic--tag-link-secondary-overlays)
+ (semantic-tag-remove-hook tag 'unlink-hook
'semantic--tag-unlink-secondary-overlays)
+ (semantic-tag-remove-hook tag 'unlink-copy-hook
'semantic--tag-unlink-copy-secondary-overlays)
+ )
+ (semantic-overlay-delete (car ol))
+ (setq ol (cdr ol)))
+ (semantic--tag-put-property tag 'secondary-overlays (nreverse nl))
+ ))
+
+(defun semantic--tag-link-secondary-overlays (tag)
+ "Unlink secondary overlays from TAG."
+ (let ((ol (semantic-tag-secondary-overlays tag)))
+ ;; Wipe out old values.
+ (semantic--tag-put-property tag 'secondary-overlays nil)
+ ;; Run all the link hooks.
+ (while ol
+ (semantic-tag-create-secondary-overlay tag (car ol))
+ (setq ol (cdr ol)))
+ ))
+
+;;; Secondary Overlay Uses
+;;
+;; States to put on tags that depend on a secondary overlay.
+(defun semantic-set-tag-folded (tag &optional folded)
+ "Fold TAG, such that only the first line of text is shown.
+Optional argument FOLDED should be non-nil to fold the tag.
+nil implies the tag should be fully shown."
+ ;; If they are different, do the deed.
+ (let ((o (semantic-tag-folded-p tag)))
+ (if (not folded)
+ ;; We unfold.
+ (when o
+ (semantic-tag-delete-secondary-overlay tag 'semantic-folded))
+ (unless o
+ ;; Add the foldn
+ (setq o (semantic-tag-create-secondary-overlay tag))
+ ;; mark as folded
+ (semantic-overlay-put o 'semantic-folded t)
+ ;; Move to cover end of tag
+ (save-excursion
+ (goto-char (semantic-tag-start tag))
+ (end-of-line)
+ (semantic-overlay-move o (point) (semantic-tag-end tag)))
+ ;; We need to modify the invisibility spec for this to
+ ;; work.
+ (if (or (eq buffer-invisibility-spec t)
+ (not (assoc 'semantic-fold buffer-invisibility-spec)))
+ (add-to-invisibility-spec '(semantic-fold . t)))
+ (semantic-overlay-put o 'invisible 'semantic-fold)
+ (overlay-put o 'isearch-open-invisible
+ 'semantic-set-tag-folded-isearch)))
+ ))
+
+(declare-function semantic-current-tag "semantic/find")
+
+(defun semantic-set-tag-folded-isearch (overlay)
+ "Called by isearch if it discovers text in the folded region.
+OVERLAY is passed in by isearch."
+ (semantic-set-tag-folded (semantic-current-tag) nil)
+ )
+
+(defun semantic-tag-folded-p (tag)
+ "Non-nil if TAG is currently folded."
+ (semantic-tag-get-secondary-overlay tag 'semantic-folded)
+ )
+
+(provide 'semantic/decorate)
+
+;;; semantic/decorate.el ends here
Index: cedet/semantic/dep.el
===================================================================
RCS file: cedet/semantic/dep.el
diff -N cedet/semantic/dep.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/dep.el 28 Sep 2009 15:15:08 -0000 1.2
@@ -0,0 +1,234 @@
+;;; semantic/dep.el --- Methods for tracking dependencies (include files)
+
+;;; Copyright (C) 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Include tags (dependencies for a given source file) usually have
+;; some short name. The target file that it is dependent on is
+;; generally found on some sort of path controlled by the compiler or
+;; project.
+;;
+;; EDE or even ECB can control our project dependencies, and help us
+;; find file within the setting of a given project. For system
+;; dependencies, we need to depend on user supplied lists, which can
+;; manifest themselves in the form of system datatabases (from
+;; semanticdb.)
+;;
+;; Provide ways to track these different files here.
+
+(require 'semantic/tag)
+
+;;; Code:
+
+(defvar semantic-dependency-include-path nil
+ "Defines the include path used when searching for files.
+This should be a list of directories to search which is specific
+to the file being included.
+
+If `semantic-dependency-tag-file' is overridden for a given
+language, this path is most likely ignored.
+
+The above function, reguardless of being overriden, caches the
+located dependency file location in the tag property
+`dependency-file'. If you override this function, you do not
+need to implement your own cache. Each time the buffer is fully
+reparsed, the cache will be reset.
+
+TODO: use ffap.el to locate such items?
+
+NOTE: Obsolete this, or use as special user")
+(make-variable-buffer-local `semantic-dependency-include-path)
+
+(defvar semantic-dependency-system-include-path nil
+ "Defines the system include path.
+This should be set with either `defvar-mode-local', or with
+`semantic-add-system-include'.
+
+For mode authors, use
+`defcustom-mode-local-semantic-dependency-system-include-path'
+to create a mode-specific variable to control this.
+
+When searching for a file associated with a name found in an tag of
+class include, this path will be inspected for includes of type
+`system'. Some include tags are agnostic to this setting and will
+check both the project and system directories.")
+(make-variable-buffer-local `semantic-dependency-system-include-path)
+
+(defmacro defcustom-mode-local-semantic-dependency-system-include-path
+ (mode name value &optional docstring)
+ "Create a mode-local value of the system-dependency include path.
+MODE is the `major-mode' this name/value pairs is for.
+NAME is the name of the customizable value users will use.
+VALUE is the path (a list of strings) to add.
+DOCSTRING is a documentation string applied to the variable NAME
+users will customize.
+
+Creates a customizable variable users can customize that will
+keep semantic data structures up to date."
+ `(progn
+ ;; Create a variable users can customize.
+ (defcustom ,name ,value
+ ,docstring
+ :group (quote ,(intern (car (split-string (symbol-name mode) "-"))))
+ :group 'semantic
+ :type '(repeat (directory :tag "Directory"))
+ :set (lambda (sym val)
+ (set-default sym val)
+ (setq-mode-local ,mode
+ semantic-dependency-system-include-path
+ val)
+ (when (fboundp
+ 'semantic-decoration-unparsed-include-do-reset)
+ (mode-local-map-mode-buffers
+ 'semantic-decoration-unparsed-include-do-reset
+ (quote ,mode))))
+ )
+ ;; Set the variable to the default value.
+ (defvar-mode-local ,mode semantic-dependency-system-include-path
+ ,name
+ "System path to search for include files.")
+ ;; Bind NAME onto our variable so tools can customize it
+ ;; without knowing about it.
+ (put 'semantic-dependency-system-include-path
+ (quote ,mode) (quote ,name))
+ ))
+
+;;; PATH MANAGEMENT
+;;
+;; Some fcns to manage paths for a give mode.
+;;;###autoload
+(defun semantic-add-system-include (dir &optional mode)
+ "Add a system include DIR to path for MODE.
+Modifies a mode-local version of `semantic-dependency-system-include-path'.
+
+Changes made by this function are not persistent."
+ (interactive "DNew Include Directory: ")
+ (if (not mode) (setq mode major-mode))
+ (let ((dirtmp (file-name-as-directory dir))
+ (value
+ (mode-local-value mode 'semantic-dependency-system-include-path))
+ )
+ (add-to-list 'value dirtmp t)
+ (eval `(setq-mode-local ,mode
+ semantic-dependency-system-include-path value))
+ ))
+
+;;;###autoload
+(defun semantic-remove-system-include (dir &optional mode)
+ "Add a system include DIR to path for MODE.
+Modifies a mode-local version of`semantic-dependency-system-include-path'.
+
+Changes made by this function are not persistent."
+ (interactive (list
+ (completing-read
+ "Include Directory to Remove: "
+ semantic-dependency-system-include-path))
+ )
+ (if (not mode) (setq mode major-mode))
+ (let ((dirtmp (file-name-as-directory dir))
+ (value
+ (mode-local-value mode 'semantic-dependency-system-include-path))
+ )
+ (setq value (delete dirtmp value))
+ (eval `(setq-mode-local ,mode semantic-dependency-system-include-path
+ value))
+ ))
+
+;;;###autoload
+(defun semantic-reset-system-include (&optional mode)
+ "Reset the system include list to empty for MODE.
+Modifies a mode-local version of
+`semantic-dependency-system-include-path'."
+ (interactive)
+ (if (not mode) (setq mode major-mode))
+ (eval `(setq-mode-local ,mode semantic-dependency-system-include-path
+ nil))
+ )
+
+;;;###autoload
+(defun semantic-customize-system-include-path (&optional mode)
+ "Customize the include path for this `major-mode'.
+To create a customizable include path for a major MODE, use the
+macro `defcustom-mode-local-semantic-dependency-system-include-path'."
+ (interactive)
+ (let ((ips (get 'semantic-dependency-system-include-path
+ (or mode major-mode))))
+ ;; Do we have one?
+ (when (not ips)
+ (error "There is no customizable includepath variable for %s"
+ (or mode major-mode)))
+ ;; Customize it.
+ (customize-variable ips)))
+
+;;; PATH SEARCH
+;;
+;; methods for finding files on a provided path.
+(defmacro semantic--dependency-find-file-on-path (file path)
+ (if (fboundp 'locate-file)
+ `(locate-file ,file ,path)
+ `(let ((p ,path)
+ (found nil))
+ (while (and p (not found))
+ (let ((f (expand-file-name ,file (car p))))
+ (if (file-exists-p f)
+ (setq found f)))
+ (setq p (cdr p)))
+ found)))
+
+(defvar ede-minor-mode)
+(defvar ede-object)
+(declare-function ede-system-include-path "ede")
+
+(defun semantic-dependency-find-file-on-path (file systemp &optional mode)
+ "Return an expanded file name for FILE on available paths.
+If SYSTEMP is true, then only search system paths.
+If optional argument MODE is non-nil, then derive paths from the
+provided mode, not from the current major mode."
+ (if (not mode) (setq mode major-mode))
+ (let ((sysp (mode-local-value
+ mode 'semantic-dependency-system-include-path))
+ (edesys (when (and (featurep 'ede) ede-minor-mode
+ ede-object)
+ (ede-system-include-path ede-object)))
+ (locp (mode-local-value
+ mode 'semantic-dependency-include-path))
+ (found nil))
+ (when (file-exists-p file)
+ (setq found file))
+ (when (and (not found) (not systemp))
+ (setq found (semantic--dependency-find-file-on-path file locp)))
+ (when (and (not found) edesys)
+ (setq found (semantic--dependency-find-file-on-path file edesys)))
+ (when (not found)
+ (setq found (semantic--dependency-find-file-on-path file sysp)))
+ (if found (expand-file-name found))))
+
+
+(provide 'semantic/dep)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/dep"
+;; End:
+
+;;; semantic/dep.el ends here
Index: cedet/semantic/doc.el
===================================================================
RCS file: cedet/semantic/doc.el
diff -N cedet/semantic/doc.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/doc.el 28 Sep 2009 15:15:08 -0000 1.2
@@ -0,0 +1,129 @@
+;;; semantic/doc.el --- Routines for documentation strings
+
+;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2005, 2008, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; It is good practice to write documenation for your functions and
+;; variables. These core routines deal with these documentation
+;; comments or strings. They can exist either as a tag property
+;; (:documentation) or as a comment just before the symbol, or after
+;; the symbol on the same line.
+
+(require 'semantic/tag)
+
+;;; Code:
+
+;;;###autoload
+(define-overloadable-function semantic-documentation-for-tag (&optional tag
nosnarf)
+ "Find documentation from TAG and return it as a clean string.
+TAG might have DOCUMENTATION set in it already. If not, there may be
+some documentation in a comment preceding TAG's definition which we
+can look for. When appropriate, this can be overridden by a language specific
+enhancement.
+Optional argument NOSNARF means to only return the lexical analyzer token for
it.
+If nosnarf if 'lex, then only return the lex token."
+ (if (not tag) (setq tag (semantic-current-tag)))
+ (save-excursion
+ (when (semantic-tag-with-position-p tag)
+ (set-buffer (semantic-tag-buffer tag)))
+ (:override
+ ;; No override. Try something simple to find documentation nearby
+ (save-excursion
+ (semantic-go-to-tag tag)
+ (let ((doctmp (semantic-tag-docstring tag (current-buffer))))
+ (or
+ ;; Is there doc in the tag???
+ doctmp
+ ;; Check just before the definition.
+ (when (semantic-tag-with-position-p tag)
+ (semantic-documentation-comment-preceeding-tag tag nosnarf))
+ ;; Lets look for comments either after the definition, but before
code:
+ ;; Not sure yet. Fill in something clever later....
+ nil))))))
+
+(defun semantic-documentation-comment-preceeding-tag (&optional tag nosnarf)
+ "Find a comment preceeding TAG.
+If TAG is nil. use the tag under point.
+Searches the space between TAG and the preceeding tag for a comment,
+and converts the comment into clean documentation.
+Optional argument NOSNARF with a value of 'lex means to return
+just the lexical token and not the string."
+ (if (not tag) (setq tag (semantic-current-tag)))
+ (save-excursion
+ ;; Find this tag.
+ (semantic-go-to-tag tag)
+ (let* ((starttag (semantic-find-tag-by-overlay-prev
+ (semantic-tag-start tag)))
+ (start (if starttag
+ (semantic-tag-end starttag)
+ (point-min))))
+ (when (re-search-backward comment-start-skip start t)
+ ;; We found a comment that doesn't belong to the body
+ ;; of a function.
+ (semantic-doc-snarf-comment-for-tag nosnarf)))
+ ))
+
+(defun semantic-doc-snarf-comment-for-tag (nosnarf)
+ "Snarf up the comment at POINT for `semantic-documentation-for-tag'.
+Attempt to strip out comment syntactic sugar.
+Argument NOSNARF means don't modify the found text.
+If NOSNARF is 'lex, then return the lex token."
+ (let* ((semantic-ignore-comments nil)
+ (semantic-lex-analyzer #'semantic-comment-lexer))
+ (if (memq nosnarf '(lex flex)) ;; keep `flex' for compatibility
+ (car (semantic-lex (point) (1+ (point))))
+ (let ((ct (semantic-lex-token-text
+ (car (semantic-lex (point) (1+ (point)))))))
+ (if nosnarf
+ nil
+ ;; ok, try to clean the text up.
+ ;; Comment start thingy
+ (while (string-match (concat "^\\s-*" comment-start-skip) ct)
+ (setq ct (concat (substring ct 0 (match-beginning 0))
+ (substring ct (match-end 0)))))
+ ;; Arbitrary punctuation at the beginning of each line.
+ (while (string-match "^\\s-*\\s.+\\s-*" ct)
+ (setq ct (concat (substring ct 0 (match-beginning 0))
+ (substring ct (match-end 0)))))
+ ;; End of a block comment.
+ (if (and (boundp 'block-comment-end)
+ block-comment-end
+ (string-match block-comment-end ct))
+ (setq ct (concat (substring ct 0 (match-beginning 0))
+ (substring ct (match-end 0)))))
+ ;; In case it's a real string, STRIPIT.
+ (while (string-match "\\s-*\\s\"+\\s-*" ct)
+ (setq ct (concat (substring ct 0 (match-beginning 0))
+ (substring ct (match-end 0))))))
+ ;; Now return the text.
+ ct))))
+
+(provide 'semantic/doc)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/doc"
+;; End:
+
+;;; semantic/doc.el ends here
Index: cedet/semantic/ede-grammar.el
===================================================================
RCS file: cedet/semantic/ede-grammar.el
diff -N cedet/semantic/ede-grammar.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/ede-grammar.el 28 Sep 2009 15:15:08 -0000 1.2
@@ -0,0 +1,202 @@
+;;; semantic/ede-grammar.el --- EDE support for Semantic Grammar Files
+
+;;; Copyright (C) 2003, 2004, 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: project, make
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Handle .by or .wy files.
+
+(require 'semantic)
+(require 'ede/proj)
+(require 'ede/pmake)
+(require 'ede/pconf)
+(require 'ede/proj-elisp)
+(require 'semantic/grammar)
+
+;;; Code:
+(defclass semantic-ede-proj-target-grammar (ede-proj-target-makefile)
+ ((menu :initform nil)
+ (keybindings :initform nil)
+ (phony :initform t)
+ (sourcetype :initform
+ (semantic-ede-source-grammar-wisent
+ semantic-ede-source-grammar-bovine
+ ))
+ (availablecompilers :initform
+ (semantic-ede-grammar-compiler-wisent
+ semantic-ede-grammar-compiler-bovine
+ ))
+ )
+ "This target consists of a group of grammar files.
+A grammar target consists of grammar files that build Emacs Lisp programs for
+parsing different languages.")
+
+(defvar semantic-ede-source-grammar-wisent
+ (ede-sourcecode "semantic-ede-grammar-source-wisent"
+ :name "Wisent Grammar"
+ :sourcepattern "\\.wy$"
+ )
+ "Semantic Grammar source code definition for wisent.")
+
+(defclass semantic-ede-grammar-compiler-class (ede-compiler)
+ nil
+ "Specialized compiler for semantic grammars.")
+
+(defvar semantic-ede-grammar-compiler-wisent
+ (semantic-ede-grammar-compiler-class
+ "ede-emacs-wisent-compiler"
+ :name "emacs"
+ :variables '(("EMACS" . "emacs"))
+ :commands
+ '(
+ "@echo \"(add-to-list 'load-path nil)\" > grammar-make-script"
+ "@for loadpath in . ${LOADPATH}; do \\"
+ " echo \"(add-to-list 'load-path \\\"$$loadpath\\\")\" >>
grammar-make-script; \\"
+ "done;"
+ "@echo \"(require 'semantic-load)\" >> grammar-make-script"
+ "@echo \"(require 'semantic-grammar)\" >> grammar-make-script"
+ ;; "@echo \"(setq debug-on-error t)\" >> grammar-make-script"
+ "\"$(EMACS)\" -batch --no-site-file -l grammar-make-script -f
semantic-grammar-batch-build-packages $^"
+ )
+ ;; :autoconf '("AM_PATH_LISPDIR")
+ :sourcetype '(semantic-ede-source-grammar-wisent)
+ :objectextention "-wy.elc"
+ )
+ "Compile Emacs Lisp programs.")
+
+
+(defvar semantic-ede-source-grammar-bovine
+ (ede-sourcecode "semantic-ede-grammar-source-bovine"
+ :name "Bovine Grammar"
+ :sourcepattern "\\.by$"
+ )
+ "Semantic Grammar source code definition for the bovinator.")
+
+(defvar semantic-ede-grammar-compiler-bovine
+ (semantic-ede-grammar-compiler-class
+ "ede-emacs-wisent-compiler"
+ :name "emacs"
+ :variables '(("EMACS" . "emacs"))
+ :commands
+ '(
+ "@echo \"(add-to-list 'load-path nil)\" > grammar-make-script"
+ "@for loadpath in . ${LOADPATH}; do \\"
+ " echo \"(add-to-list 'load-path \\\"$$loadpath\\\")\" >>
grammar-make-script; \\"
+ "done;"
+ "@echo \"(require 'semantic-load)\" >> grammar-make-script"
+ "@echo \"(require 'semantic-grammar)\" >> grammar-make-script"
+ ;; "@echo \"(setq debug-on-error t)\" >> grammar-make-script"
+ "\"$(EMACS)\" -batch --no-site-file -l grammar-make-script -f
semantic-grammar-batch-build-packages $^"
+ )
+ ;; :autoconf '("AM_PATH_LISPDIR")
+ :sourcetype '(semantic-ede-source-grammar-bovine)
+ :objectextention "-by.elc"
+ )
+ "Compile Emacs Lisp programs.")
+
+;;; Target options.
+(defmethod ede-buffer-mine ((this semantic-ede-proj-target-grammar) buffer)
+ "Return t if object THIS lays claim to the file in BUFFER.
+Lays claim to all -by.el, and -wy.el files."
+ ;; We need to be a little more careful than this, but at the moment it
+ ;; is common to have only one target of this class per directory.
+ (if (string-match "-[bw]y\\.elc?$" (buffer-file-name buffer))
+ t
+ (call-next-method) ; The usual thing.
+ ))
+
+(defmethod project-compile-target ((obj semantic-ede-proj-target-grammar))
+ "Compile all sources in a Lisp target OBJ."
+ (let* ((cb (current-buffer))
+ (proj (ede-target-parent obj))
+ (default-directory (oref proj directory)))
+ (mapc (lambda (src)
+ (save-excursion
+ (set-buffer (find-file-noselect src))
+ (save-excursion
+ (semantic-grammar-create-package))
+ (save-buffer)
+ (let ((cf (concat (semantic-grammar-package) ".el")))
+ (if (or (not (file-exists-p cf))
+ (file-newer-than-file-p src cf))
+ (byte-compile-file cf)))))
+ (oref obj source)))
+ (message "All Semantic Grammar sources are up to date in %s" (object-name
obj)))
+
+;;; Makefile generation functions
+;;
+(defmethod ede-proj-makefile-sourcevar ((this
semantic-ede-proj-target-grammar))
+ "Return the variable name for THIS's sources."
+ (cond ((ede-proj-automake-p)
+ (error "No Automake support for Semantic Grammars"))
+ (t (concat (ede-pmake-varname this) "_SEMANTIC_GRAMMAR"))))
+
+(defmethod ede-proj-makefile-insert-variables :AFTER ((this
semantic-ede-proj-target-grammar))
+ "Insert variables needed by target THIS."
+ (ede-proj-makefile-insert-loadpath-items
+ (ede-proj-elisp-packages-to-loadpath
+ (list "eieio" "semantic" "inversion" "ede")))
+ ;; eieio for object system needed in ede
+ ;; semantic because it is
+ ;; Inversion for versioning system.
+ ;; ede for project regeneration
+ (ede-pmake-insert-variable-shared
+ (concat (ede-pmake-varname this) "_SEMANTIC_GRAMMAR_EL")
+ (insert
+ (mapconcat (lambda (src)
+ (save-excursion
+ (set-buffer (find-file-noselect src))
+ (concat (semantic-grammar-package) ".el")))
+ (oref this source)
+ " ")))
+ )
+
+(defmethod ede-proj-makefile-insert-rules ((this
semantic-ede-proj-target-grammar))
+ "Insert rules needed by THIS target."
+ ;; Add in some dependencies.
+;; (mapc (lambda (src)
+;; (let ((nm (file-name-sans-extension src)))
+;; (insert nm "-wy.el: " src "\n"
+;; nm "-wy.elc: " nm "-wy.el\n\n")
+;; ))
+;; (oref this source))
+ ;; Call the normal insertion of rules.
+ (call-next-method)
+ )
+
+(defmethod ede-proj-makefile-insert-dist-dependencies ((this
semantic-ede-proj-target-grammar))
+ "Insert dist dependencies, or intermediate targets.
+This makes sure that all grammar lisp files are created before the dist
+runs, so they are always up to date.
+Argument THIS is the target that should insert stuff."
+ (call-next-method)
+ (insert " $(" (ede-pmake-varname this) "_SEMANTIC_GRAMMAR_EL)")
+ )
+
+;; (autoload 'ede-proj-target-elisp "ede/proj-elisp"
+;; "Target class for Emacs/Semantic grammar files." nil nil)
+
+(ede-proj-register-target "semantic grammar"
+ semantic-ede-proj-target-grammar)
+
+(provide 'semantic/ede-grammar)
+
+;;; semantic/ede-grammar.el ends here
Index: cedet/semantic/edit.el
===================================================================
RCS file: cedet/semantic/edit.el
diff -N cedet/semantic/edit.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/edit.el 28 Sep 2009 15:15:08 -0000 1.2
@@ -0,0 +1,972 @@
+;;; semantic/edit.el --- Edit Management for Semantic
+
+;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+;;; 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; In Semantic 1.x, changes were handled in a simplistic manner, where
+;; tags that changed were reparsed one at a time. Any other form of
+;; edit were managed through a full reparse.
+;;
+;; This code attempts to minimize the number of times a full reparse
+;; needs to occur. While overlays and tags will continue to be
+;; recycled in the simple case, new cases where tags are inserted
+;; or old tags removed from the original list are handled.
+;;
+
+;;; NOTES FOR IMPROVEMENT
+;;
+;; Work done by the incremental parser could be improved by the
+;; following:
+;;
+;; 1. Tags created could have as a property an overlay marking a region
+;; of themselves that can be edited w/out affecting the definition of
+;; that tag.
+;;
+;; 2. Tags w/ positioned children could have a property of an
+;; overlay marking the region in themselves that contain the
+;; children. This could be used to better improve splicing near
+;; the beginning and end of the child lists.
+;;
+
+;;; BUGS IN INCREMENTAL PARSER
+;;
+;; 1. Changes in the whitespace between tags could extend a
+;; following tag. These will be marked as merely unmatched
+;; syntax instead.
+;;
+;; 2. Incremental parsing while a new function is being typed in
+;; somtimes gets a chance only when lists are incomplete,
+;; preventing correct context identification.
+
+;;
+(require 'semantic)
+
+;;; Code:
+(defvar semantic-after-partial-cache-change-hook nil
+ "Normal hook run after the buffer cache has been updated.
+
+This hook will run when the cache has been partially reparsed.
+Partial reparses are incurred when a user edits a buffer, and only the
+modified sections are rescanned.
+
+Hook functions must take one argument, which is the list of tags
+updated in the current buffer.
+
+For language specific hooks, make sure you define this as a local hook.")
+
+(defvar semantic-change-hooks
+ '(semantic-edits-change-function-handle-changes)
+ "Abnormal hook run when semantic detects a change in a buffer.
+Each hook function must take three arguments, identical to the
+common hook `after-change-functions'.")
+
+(defvar semantic-reparse-needed-change-hook nil
+ "Hooks run when a user edit is detected as needing a reparse.
+For language specific hooks, make sure you define this as a local
+hook.
+Not used yet; part of the next generation reparse mechanism")
+
+(defvar semantic-no-reparse-needed-change-hook nil
+ "Hooks run when a user edit is detected as not needing a reparse.
+If the hook returns non-nil, then declare that a reparse is needed.
+For language specific hooks, make sure you define this as a local
+hook.
+Not used yet; part of the next generation reparse mechanism.")
+
+(defvar semantic-edits-new-change-hooks nil
+ "Abnormal hook run when a new change is found.
+Functions must take one argument representing an overlay on that change.")
+
+(defvar semantic-edits-delete-change-hooks nil
+ "Abnormal hook run before a change overlay is deleted.
+Deleted changes occur when multiple changes are merged.
+Functions must take one argument representing an overlay being deleted.")
+
+(defvar semantic-edits-move-change-hook nil
+ "Abnormal hook run after a change overlay is moved.
+Changes move when a new change overlaps an old change. The old change
+will be moved.
+Functions must take one argument representing an overlay being moved.")
+
+(defvar semantic-edits-reparse-change-hooks nil
+ "Abnormal hook run after a change results in a reparse.
+Functions are called before the overlay is deleted, and after the
+incremental reparse.")
+
+(defvar semantic-edits-incremental-reparse-failed-hook nil
+ "Hook run after the incremental parser fails.
+When this happens, the buffer is marked as needing a full reprase.")
+
+(semantic-varalias-obsolete 'semantic-edits-incremental-reparse-failed-hooks
+ 'semantic-edits-incremental-reparse-failed-hook)
+
+(defcustom semantic-edits-verbose-flag nil
+ "Non-nil means the incremental perser is verbose.
+If nil, errors are still displayed, but informative messages are not."
+ :group 'semantic
+ :type 'boolean)
+
+;;; Change State management
+;;
+;; Manage a series of overlays that define changes recently
+;; made to the current buffer.
+;;;###autoload
+(defun semantic-change-function (start end length)
+ "Provide a mechanism for semantic tag management.
+Argument START, END, and LENGTH specify the bounds of the change."
+ (setq semantic-unmatched-syntax-cache-check t)
+ (let ((inhibit-point-motion-hooks t)
+ )
+ (run-hook-with-args 'semantic-change-hooks start end length)
+ ))
+
+(defun semantic-changes-in-region (start end &optional buffer)
+ "Find change overlays which exist in whole or in part between START and END.
+Optional argument BUFFER is the buffer to search for changes in."
+ (save-excursion
+ (if buffer (set-buffer buffer))
+ (let ((ol (semantic-overlays-in (max start (point-min))
+ (min end (point-max))))
+ (ret nil))
+ (while ol
+ (when (semantic-overlay-get (car ol) 'semantic-change)
+ (setq ret (cons (car ol) ret)))
+ (setq ol (cdr ol)))
+ (sort ret #'(lambda (a b) (< (semantic-overlay-start a)
+ (semantic-overlay-start b)))))))
+
+(defun semantic-edits-change-function-handle-changes (start end length)
+ "Run whenever a buffer controlled by `semantic-mode' change.
+Tracks when and how the buffer is re-parsed.
+Argument START, END, and LENGTH specify the bounds of the change."
+ ;; We move start/end by one so that we can merge changes that occur
+ ;; just before, or just after. This lets simple typing capture everything
+ ;; into one overlay.
+ (let ((changes-in-change (semantic-changes-in-region (1- start) (1+ end)))
+ )
+ (semantic-parse-tree-set-needs-update)
+ (if (not changes-in-change)
+ (let ((o (semantic-make-overlay start end)))
+ (semantic-overlay-put o 'semantic-change t)
+ ;; Run the hooks safely. When hooks blow it, our dirty
+ ;; function will be removed from the list of active change
+ ;; functions.
+ (condition-case nil
+ (run-hook-with-args 'semantic-edits-new-change-hooks o)
+ (error nil)))
+ (let ((tmp changes-in-change))
+ ;; Find greatest bounds of all changes
+ (while tmp
+ (when (< (semantic-overlay-start (car tmp)) start)
+ (setq start (semantic-overlay-start (car tmp))))
+ (when (> (semantic-overlay-end (car tmp)) end)
+ (setq end (semantic-overlay-end (car tmp))))
+ (setq tmp (cdr tmp)))
+ ;; Move the first found overlay, recycling that overlay.
+ (semantic-overlay-move (car changes-in-change) start end)
+ (condition-case nil
+ (run-hook-with-args 'semantic-edits-move-change-hooks
+ (car changes-in-change))
+ (error nil))
+ (setq changes-in-change (cdr changes-in-change))
+ ;; Delete other changes. They are now all bound here.
+ (while changes-in-change
+ (condition-case nil
+ (run-hook-with-args 'semantic-edits-delete-change-hooks
+ (car changes-in-change))
+ (error nil))
+ (semantic-overlay-delete (car changes-in-change))
+ (setq changes-in-change (cdr changes-in-change))))
+ )))
+
+(defsubst semantic-edits-flush-change (change)
+ "Flush the CHANGE overlay."
+ (condition-case nil
+ (run-hook-with-args 'semantic-edits-delete-change-hooks
+ change)
+ (error nil))
+ (semantic-overlay-delete change))
+
+(defun semantic-edits-flush-changes ()
+ "Flush the changes in the current buffer."
+ (let ((changes (semantic-changes-in-region (point-min) (point-max))))
+ (while changes
+ (semantic-edits-flush-change (car changes))
+ (setq changes (cdr changes))))
+ )
+
+(defun semantic-edits-change-in-one-tag-p (change hits)
+ "Return non-nil of the overlay CHANGE exists solely in one leaf tag.
+HITS is the list of tags that CHANGE is in. It can have more than
+one tag in it if the leaf tag is within a parent tag."
+ (and (< (semantic-tag-start (car hits))
+ (semantic-overlay-start change))
+ (> (semantic-tag-end (car hits))
+ (semantic-overlay-end change))
+ ;; Recurse on the rest. If this change is inside all
+ ;; of these tags, then they are all leaves or parents
+ ;; of the smallest tag.
+ (or (not (cdr hits))
+ (semantic-edits-change-in-one-tag-p change (cdr hits))))
+ )
+
+;;; Change/Tag Query functions
+;;
+;; A change (region of space) can effect tags in different ways.
+;; These functions perform queries on a buffer to determine different
+;; ways that a change effects a buffer.
+;;
+;; NOTE: After debugging these, replace below to no longer look
+;; at point and mark (via comments I assume.)
+(defsubst semantic-edits-os (change)
+ "For testing: Start of CHANGE, or smaller of (point) and (mark)."
+ (if change (semantic-overlay-start change)
+ (if (< (point) (mark)) (point) (mark))))
+
+(defsubst semantic-edits-oe (change)
+ "For testing: End of CHANGE, or larger of (point) and (mark)."
+ (if change (semantic-overlay-end change)
+ (if (> (point) (mark)) (point) (mark))))
+
+(defun semantic-edits-change-leaf-tag (change)
+ "A leaf tag which completely encompasses CHANGE.
+If change overlaps a tag, but is not encompassed in it, return nil.
+Use `semantic-edits-change-overlap-leaf-tag'.
+If CHANGE is completely encompassed in a tag, but overlaps sub-tags,
+return nil."
+ (let* ((start (semantic-edits-os change))
+ (end (semantic-edits-oe change))
+ (tags (nreverse
+ (semantic-find-tag-by-overlay-in-region
+ start end))))
+ ;; A leaf is always first in this list
+ (if (and tags
+ (<= (semantic-tag-start (car tags)) start)
+ (> (semantic-tag-end (car tags)) end))
+ ;; Ok, we have a match. If this tag has children,
+ ;; we have to do more tests.
+ (let ((chil (semantic-tag-components (car tags))))
+ (if (not chil)
+ ;; Simple leaf.
+ (car tags)
+ ;; For this type, we say that we encompass it if the
+ ;; change occurs outside the range of the children.
+ (if (or (not (semantic-tag-with-position-p (car chil)))
+ (> start (semantic-tag-end (nth (1- (length chil)) chil)))
+ (< end (semantic-tag-start (car chil))))
+ ;; We have modifications to the definition of this parent
+ ;; so we have to reparse the whole thing.
+ (car tags)
+ ;; We actually modified an area between some children.
+ ;; This means we should return nil, as that case is
+ ;; calculated by someone else.
+ nil)))
+ nil)))
+
+(defun semantic-edits-change-between-tags (change)
+ "Return a cache list of tags surrounding CHANGE.
+The returned list is the CONS cell in the master list pointing to
+a tag just before CHANGE. The CDR will have the tag just after CHANGE.
+CHANGE cannot encompass or overlap a leaf tag.
+If CHANGE is fully encompassed in a tag that has children, and
+this change occurs between those children, this returns non-nil.
+See `semantic-edits-change-leaf-tag' for details on parents."
+ (let* ((start (semantic-edits-os change))
+ (end (semantic-edits-oe change))
+ (tags (nreverse
+ (semantic-find-tag-by-overlay-in-region
+ start end)))
+ (list-to-search nil)
+ (found nil))
+ (if (not tags)
+ (setq list-to-search semantic--buffer-cache)
+ ;; A leaf is always first in this list
+ (if (and (< (semantic-tag-start (car tags)) start)
+ (> (semantic-tag-end (car tags)) end))
+ ;; We are completely encompassed in a tag.
+ (if (setq list-to-search
+ (semantic-tag-components (car tags)))
+ ;; Ok, we are completely encompassed within the first tag
+ ;; entry, AND that tag has children. This means that change
+ ;; occured outside of all children, but inside some tag
+ ;; with children.
+ (if (or (not (semantic-tag-with-position-p (car list-to-search)))
+ (> start (semantic-tag-end
+ (nth (1- (length list-to-search))
+ list-to-search)))
+ (< end (semantic-tag-start (car list-to-search))))
+ ;; We have modifications to the definition of this parent
+ ;; and not between it's children. Clear the search list.
+ (setq list-to-search nil)))
+ ;; Search list is nil.
+ ))
+ ;; If we have a search list, lets go. Otherwise nothing.
+ (while (and list-to-search (not found))
+ (if (cdr list-to-search)
+ ;; We end when the start of the CDR is after the end of our
+ ;; asked change.
+ (if (< (semantic-tag-start (cadr list-to-search)) end)
+ (setq list-to-search (cdr list-to-search))
+ (setq found t))
+ (setq list-to-search nil)))
+ ;; Return it. If it is nil, there is a logic bug, and we need
+ ;; to avoid this bit of logic anyway.
+ list-to-search
+ ))
+
+(defun semantic-edits-change-over-tags (change)
+ "Return a cache list of tags surrounding a CHANGE encompassing tags.
+CHANGE must not only include all overlapped tags (excepting possible
+parent tags) in their entirety. In this case, the change may be deleting
+or moving whole tags.
+The return value is a vector.
+Cell 0 is a list of all tags completely encompassed in change.
+Cell 1 is the cons cell into a master parser cache starting with
+the cell which occurs BEFORE the first position of CHANGE.
+Cell 2 is the parent of cell 1, or nil for the buffer cache.
+This function returns nil if any tag covered by change is not
+completely encompassed.
+See `semantic-edits-change-leaf-tag' for details on parents."
+ (let* ((start (semantic-edits-os change))
+ (end (semantic-edits-oe change))
+ (tags (nreverse
+ (semantic-find-tag-by-overlay-in-region
+ start end)))
+ (parent nil)
+ (overlapped-tags nil)
+ inner-start inner-end
+ (list-to-search nil))
+ ;; By the time this is already called, we know that it is
+ ;; not a leaf change, nor a between tag change. That leaves
+ ;; an overlap, and this condition.
+
+ ;; A leaf is always first in this list.
+ ;; Is the leaf encompassed in this change?
+ (if (and tags
+ (>= (semantic-tag-start (car tags)) start)
+ (<= (semantic-tag-end (car tags)) end))
+ (progn
+ ;; We encompass one whole change.
+ (setq overlapped-tags (list (car tags))
+ inner-start (semantic-tag-start (car tags))
+ inner-end (semantic-tag-end (car tags))
+ tags (cdr tags))
+ ;; Keep looping while tags are inside the change.
+ (while (and tags
+ (>= (semantic-tag-start (car tags)) start)
+ (<= (semantic-tag-end (car tags)) end))
+
+ ;; Check if this new all-encompassing tag is a parent
+ ;; of that which went before. Only check end because
+ ;; we know that start is less than inner-start since
+ ;; tags was sorted on that.
+ (if (> (semantic-tag-end (car tags)) inner-end)
+ ;; This is a parent. Drop the children found
+ ;; so far.
+ (setq overlapped-tags (list (car tags))
+ inner-start (semantic-tag-start (car tags))
+ inner-end (semantic-tag-end (car tags))
+ )
+ ;; It is not a parent encompassing tag
+ (setq overlapped-tags (cons (car tags)
+ overlapped-tags)
+ inner-start (semantic-tag-start (car tags))))
+ (setq tags (cdr tags)))
+ (if (not tags)
+ ;; There are no tags left, and all tags originally
+ ;; found are encompassed by the change. Setup our list
+ ;; from the cache
+ (setq list-to-search semantic--buffer-cache);; We have a tag
ouside the list. Check for
+ ;; We know we have a parent because it would
+ ;; completely cover the change. A tag can only
+ ;; do that if it is a parent after we get here.
+ (when (and tags
+ (< (semantic-tag-start (car tags)) start)
+ (> (semantic-tag-end (car tags)) end))
+ ;; We have a parent. Stuff in the search list.
+ (setq parent (car tags)
+ list-to-search (semantic-tag-components parent))
+ ;; If the first of TAGS is a parent (see above)
+ ;; then clear out the list. All other tags in
+ ;; here must therefore be parents of the car.
+ (setq tags nil)
+ ;; One last check, If start is before the first
+ ;; tag or after the last, we may have overlap into
+ ;; the characters that make up the definition of
+ ;; the tag we are parsing.
+ (when (or (semantic-tag-with-position-p (car list-to-search))
+ (< start (semantic-tag-start
+ (car list-to-search)))
+ (> end (semantic-tag-end
+ (nth (1- (length list-to-search))
+ list-to-search))))
+ ;; We have a problem
+ (setq list-to-search nil
+ parent nil))))
+
+ (when list-to-search
+
+ ;; Ok, return the vector only if all TAGS are
+ ;; confirmed as the lineage of `overlapped-tags'
+ ;; which must have a value by now.
+
+ ;; Loop over the search list to find the preceeding CDR.
+ ;; Fortunatly, (car overlapped-tags) happens to be
+ ;; the first tag positionally.
+ (let ((tokstart (semantic-tag-start (car overlapped-tags))))
+ (while (and list-to-search
+ ;; Assume always (car (cdr list-to-search)).
+ ;; A thrown error will be captured nicely, but
+ ;; that case shouldn't happen.
+
+ ;; We end when the start of the CDR is after the
+ ;; end of our asked change.
+ (cdr list-to-search)
+ (< (semantic-tag-start (car (cdr list-to-search)))
+ tokstart)
+ (setq list-to-search (cdr list-to-search)))))
+ ;; Create the return vector
+ (vector overlapped-tags
+ list-to-search
+ parent)
+ ))
+ nil)))
+
+;;; Default Incremental Parser
+;;
+;; Logic about how to group changes for effective reparsing and splicing.
+
+(defun semantic-parse-changes-failed (&rest args)
+ "Signal that Semantic failed to parse changes.
+That is, display a message by passing all ARGS to `format', then throw
+a 'semantic-parse-changes-failed exception with value t."
+ (when semantic-edits-verbose-flag
+ (message "Semantic parse changes failed: %S"
+ (apply 'format args)))
+ (throw 'semantic-parse-changes-failed t))
+
+(defsubst semantic-edits-incremental-fail ()
+ "When the incremental parser fails, we mark that we need a full reparse."
+ ;;(debug)
+ (semantic-parse-tree-set-needs-rebuild)
+ (when semantic-edits-verbose-flag
+ (message "Force full reparse (%s)"
+ (buffer-name (current-buffer))))
+ (run-hooks 'semantic-edits-incremental-reparse-failed-hook))
+
+(defun semantic-edits-incremental-parser ()
+ "Incrementally reparse the current buffer.
+Incremental parser allows semantic to only reparse those sections of
+the buffer that have changed. This function depends on
+`semantic-edits-change-function-handle-changes' setting up change
+overlays in the current buffer. Those overlays are analyzed against
+the semantic cache to see what needs to be changed."
+ (let ((changed-tags
+ ;; Don't use `semantic-safe' here to explicitly catch errors
+ ;; and reset the parse tree.
+ (catch 'semantic-parse-changes-failed
+ (if debug-on-error
+ (semantic-edits-incremental-parser-1)
+ (condition-case err
+ (semantic-edits-incremental-parser-1)
+ (error
+ (message "incremental parser error: %S"
+ (error-message-string err))
+ t))))))
+ (when (eq changed-tags t)
+ ;; Force a full reparse.
+ (semantic-edits-incremental-fail)
+ (setq changed-tags nil))
+ changed-tags))
+
+(defmacro semantic-edits-assert-valid-region ()
+ "Asert that parse-start and parse-end are sorted correctly."
+;;; (if (> parse-start parse-end)
+;;; (error "Bug is %s !> %d! Buff min/max = [ %d %d ]"
+;;; parse-start parse-end
+;;; (point-min) (point-max)))
+ )
+
+(defun semantic-edits-incremental-parser-1 ()
+ "Incrementally reparse the current buffer.
+Return the list of tags that changed.
+If the incremental parse fails, throw a 'semantic-parse-changes-failed
+exception with value t, that can be caught to schedule a full reparse.
+This function is for internal use by `semantic-edits-incremental-parser'."
+ (let* ((changed-tags nil)
+ (debug-on-quit t) ; try to find this annoying bug!
+ (changes (semantic-changes-in-region
+ (point-min) (point-max)))
+ (tags nil) ;tags found at changes
+ (newf-tags nil) ;newfound tags in change
+ (parse-start nil) ;location to start parsing
+ (parse-end nil) ;location to end parsing
+ (parent-tag nil) ;parent of the cache list.
+ (cache-list nil) ;list of children within which
+ ;we incrementally reparse.
+ (reparse-symbol nil) ;The ruled we start at for reparse.
+ (change-group nil) ;changes grouped in this reparse
+ (last-cond nil) ;track the last case used.
+ ;query this when debugging to find
+ ;source of bugs.
+ )
+ (or changes
+ ;; If we were called, and there are no changes, then we
+ ;; don't know what to do. Force a full reparse.
+ (semantic-parse-changes-failed "Don't know what to do"))
+ ;; Else, we have some changes. Loop over them attempting to
+ ;; patch things up.
+ (while changes
+ ;; Calculate the reparse boundary.
+ ;; We want to take some set of changes, and group them
+ ;; together into a small change group. One change forces
+ ;; a reparse of a larger region (the size of some set of
+ ;; tags it encompases.) It may contain several tags.
+ ;; That region may have other changes in it (several small
+ ;; changes in one function, for example.)
+ ;; Optimize for the simple cases here, but try to handle
+ ;; complex ones too.
+
+ (while (and changes ; we still have changes
+ (or (not parse-start)
+ ;; Below, if the change we are looking at
+ ;; is not the first change for this
+ ;; iteration, and it starts before the end
+ ;; of current parse region, then it is
+ ;; encompased within the bounds of tags
+ ;; modified by the previous iteration's
+ ;; change.
+ (< (semantic-overlay-start (car changes))
+ parse-end)))
+
+ ;; REMOVE LATER
+ (if (eq (car changes) (car change-group))
+ (semantic-parse-changes-failed
+ "Possible infinite loop detected"))
+
+ ;; Store this change in this change group.
+ (setq change-group (cons (car changes) change-group))
+
+ (cond
+ ;; Is this is a new parse group?
+ ((not parse-start)
+ (setq last-cond "new group")
+ (let (tmp)
+ (cond
+
+;;;; Are we encompassed all in one tag?
+ ((setq tmp (semantic-edits-change-leaf-tag (car changes)))
+ (setq last-cond "Encompassed in tag")
+ (setq tags (list tmp)
+ parse-start (semantic-tag-start tmp)
+ parse-end (semantic-tag-end tmp)
+ )
+ (semantic-edits-assert-valid-region))
+
+;;;; Did the change occur between some tags?
+ ((setq cache-list (semantic-edits-change-between-tags
+ (car changes)))
+ (setq last-cond "Between and not overlapping tags")
+ ;; The CAR of cache-list is the tag just before
+ ;; our change, but wasn't modified. Hmmm.
+ ;; Bound our reparse between these two tags
+ (setq tags nil
+ parent-tag
+ (car (semantic-find-tag-by-overlay
+ parse-start)))
+ (cond
+ ;; A change at the beginning of the buffer.
+ ;; Feb 06 -
+ ;; IDed when the first cache-list tag is after
+ ;; our change, meaning there is nothing before
+ ;; the chnge.
+ ((> (semantic-tag-start (car cache-list))
+ (semantic-overlay-end (car changes)))
+ (setq last-cond "Beginning of buffer")
+ (setq parse-start
+ ;; Don't worry about parents since
+ ;; there there would be an exact
+ ;; match in the tag list otherwise
+ ;; and the routine would fail.
+ (point-min)
+ parse-end
+ (semantic-tag-start (car cache-list)))
+ (semantic-edits-assert-valid-region)
+ )
+ ;; A change stuck on the first surrounding tag.
+ ((= (semantic-tag-end (car cache-list))
+ (semantic-overlay-start (car changes)))
+ (setq last-cond "Beginning of Tag")
+ ;; Reparse that first tag.
+ (setq parse-start
+ (semantic-tag-start (car cache-list))
+ parse-end
+ (semantic-overlay-end (car changes))
+ tags
+ (list (car cache-list)))
+ (semantic-edits-assert-valid-region)
+ )
+ ;; A change at the end of the buffer.
+ ((not (car (cdr cache-list)))
+ (setq last-cond "End of buffer")
+ (setq parse-start (semantic-tag-end
+ (car cache-list))
+ parse-end (point-max))
+ (semantic-edits-assert-valid-region)
+ )
+ (t
+ (setq last-cond "Default")
+ (setq parse-start
+ (semantic-tag-end (car cache-list))
+ parse-end
+ (semantic-tag-start (car (cdr cache-list)))
+ )
+ (semantic-edits-assert-valid-region))))
+
+;;;; Did the change completely overlap some number of tags?
+ ((setq tmp (semantic-edits-change-over-tags
+ (car changes)))
+ (setq last-cond "Overlap multiple tags")
+ ;; Extract the information
+ (setq tags (aref tmp 0)
+ cache-list (aref tmp 1)
+ parent-tag (aref tmp 2))
+ ;; We can calculate parse begin/end by checking
+ ;; out what is in TAGS. The one near start is
+ ;; always first. Make sure the reprase includes
+ ;; the `whitespace' around the snarfed tags.
+ ;; Since cache-list is positioned properly, use it
+ ;; to find that boundary.
+ (if (eq (car tags) (car cache-list))
+ ;; Beginning of the buffer!
+ (let ((end-marker (nth (length tags)
+ cache-list)))
+ (setq parse-start (point-min))
+ (if end-marker
+ (setq parse-end
+ (semantic-tag-start end-marker))
+ (setq parse-end (semantic-overlay-end
+ (car changes))))
+ (semantic-edits-assert-valid-region)
+ )
+ ;; Middle of the buffer.
+ (setq parse-start
+ (semantic-tag-end (car cache-list)))
+ ;; For the end, we need to scoot down some
+ ;; number of tags. We 1+ the length of tags
+ ;; because we want to skip the first tag
+ ;; (remove 1-) then want the tag after the end
+ ;; of the list (1+)
+ (let ((end-marker (nth (1+ (length tags)) cache-list)))
+ (if end-marker
+ (setq parse-end (semantic-tag-start end-marker))
+ ;; No marker. It is the last tag in our
+ ;; list of tags. Only possible if END
+ ;; already matches the end of that tag.
+ (setq parse-end
+ (semantic-overlay-end (car changes)))))
+ (semantic-edits-assert-valid-region)
+ ))
+
+;;;; Unhandled case.
+ ;; Throw error, and force full reparse.
+ ((semantic-parse-changes-failed "Unhandled change group")))
+ ))
+ ;; Is this change inside the previous parse group?
+ ;; We already checked start.
+ ((< (semantic-overlay-end (car changes)) parse-end)
+ (setq last-cond "in bounds")
+ nil)
+ ;; This change extends the current parse group.
+ ;; Find any new tags, and see how to append them.
+ ((semantic-parse-changes-failed
+ (setq last-cond "overlap boundary")
+ "Unhandled secondary change overlapping boundary"))
+ )
+ ;; Prepare for the next iteration.
+ (setq changes (cdr changes)))
+
+ ;; By the time we get here, all TAGS are children of
+ ;; some parent. They should all have the same start symbol
+ ;; since that is how the multi-tag parser works. Grab
+ ;; the reparse symbol from the first of the returned tags.
+ ;;
+ ;; Feb '06 - If repase-symbol is nil, then they are top level
+ ;; tags. (I'm guessing.) Is this right?
+ (setq reparse-symbol
+ (semantic--tag-get-property (car (or tags cache-list))
+ 'reparse-symbol))
+ ;; Find a parent if not provided.
+ (and (not parent-tag) tags
+ (setq parent-tag
+ (semantic-find-tag-parent-by-overlay
+ (car tags))))
+ ;; We can do the same trick for our parent and resulting
+ ;; cache list.
+ (unless cache-list
+ (if parent-tag
+ (setq cache-list
+ ;; We need to get all children in case we happen
+ ;; to have a mix of positioned and non-positioned
+ ;; children.
+ (semantic-tag-components parent-tag))
+ ;; Else, all the tags since there is no parent.
+ ;; It sucks to have to use the full buffer cache in
+ ;; this case because it can be big. Failure to provide
+ ;; however results in a crash.
+ (setq cache-list semantic--buffer-cache)
+ ))
+ ;; Use the boundary to calculate the new tags found.
+ (setq newf-tags (semantic-parse-region
+ parse-start parse-end reparse-symbol))
+ ;; Make sure all these tags are given overlays.
+ ;; They have already been cooked by the parser and just
+ ;; need the overlays.
+ (let ((tmp newf-tags))
+ (while tmp
+ (semantic--tag-link-to-buffer (car tmp))
+ (setq tmp (cdr tmp))))
+
+ ;; See how this change lays out.
+ (cond
+
+;;;; Whitespace change
+ ((and (not tags) (not newf-tags))
+ ;; A change that occured outside of any existing tags
+ ;; and there are no new tags to replace it.
+ (when semantic-edits-verbose-flag
+ (message "White space changes"))
+ nil
+ )
+
+;;;; New tags in old whitespace area.
+ ((and (not tags) newf-tags)
+ ;; A change occured outside existing tags which added
+ ;; a new tag. We need to splice these tags back
+ ;; into the cache at the right place.
+ (semantic-edits-splice-insert newf-tags parent-tag cache-list)
+
+ (setq changed-tags
+ (append newf-tags changed-tags))
+
+ (when semantic-edits-verbose-flag
+ (message "Inserted tags: (%s)"
+ (semantic-format-tag-name (car newf-tags))))
+ )
+
+;;;; Old tags removed
+ ((and tags (not newf-tags))
+ ;; A change occured where pre-existing tags were
+ ;; deleted! Remove the tag from the cache.
+ (semantic-edits-splice-remove tags parent-tag cache-list)
+
+ (setq changed-tags
+ (append tags changed-tags))
+
+ (when semantic-edits-verbose-flag
+ (message "Deleted tags: (%s)"
+ (semantic-format-tag-name (car tags))))
+ )
+
+;;;; One tag was updated.
+ ((and (= (length tags) 1) (= (length newf-tags) 1))
+ ;; One old tag was modified, and it is replaced by
+ ;; One newfound tag. Splice the new tag into the
+ ;; position of the old tag.
+ ;; Do the splice.
+ (semantic-edits-splice-replace (car tags) (car newf-tags))
+ ;; Add this tag to our list of changed toksns
+ (setq changed-tags (cons (car tags) changed-tags))
+ ;; Debug
+ (when semantic-edits-verbose-flag
+ (message "Update Tag Table: %s"
+ (semantic-format-tag-name (car tags) nil t)))
+ ;; Flush change regardless of above if statement.
+ )
+
+;;;; Some unhandled case.
+ ((semantic-parse-changes-failed "Don't know what to do")))
+
+ ;; We got this far, and we didn't flag a full reparse.
+ ;; Clear out this change group.
+ (while change-group
+ (semantic-edits-flush-change (car change-group))
+ (setq change-group (cdr change-group)))
+
+ ;; Don't increment change here because an earlier loop
+ ;; created change-groups.
+ (setq parse-start nil)
+ )
+ ;; Mark that we are done with this glop
+ (semantic-parse-tree-set-up-to-date)
+ ;; Return the list of tags that changed. The caller will
+ ;; use this information to call hooks which can fix themselves.
+ changed-tags))
+
+;; Make it the default changes parser
+;;;###autoload
+(defalias 'semantic-parse-changes-default
+ 'semantic-edits-incremental-parser)
+
+;;; Cache Splicing
+;;
+;; The incremental parser depends on the ability to parse up sections
+;; of the file, and splice the results back into the cache. There are
+;; three types of splices. A REPLACE, an ADD, and a REMOVE. REPLACE
+;; is one of the simpler cases, as the starting cons cell representing
+;; the old tag can be used to auto-splice in. ADD and REMOVE
+;; require scanning the cache to find the correct location so that the
+;; list can be fiddled.
+(defun semantic-edits-splice-remove (oldtags parent cachelist)
+ "Remove OLDTAGS from PARENT's CACHELIST.
+OLDTAGS are tags in the currenet buffer, preferably linked
+together also in CACHELIST.
+PARENT is the parent tag containing OLDTAGS.
+CACHELIST should be the children from PARENT, but may be
+pre-positioned to a convenient location."
+ (let* ((first (car oldtags))
+ (last (nth (1- (length oldtags)) oldtags))
+ (chil (if parent
+ (semantic-tag-components parent)
+ semantic--buffer-cache))
+ (cachestart cachelist)
+ (cacheend nil)
+ )
+ ;; First in child list?
+ (if (eq first (car chil))
+ ;; First tags in the cache are being deleted.
+ (progn
+ (when semantic-edits-verbose-flag
+ (message "To Remove First Tag: (%s)"
+ (semantic-format-tag-name first)))
+ ;; Find the last tag
+ (setq cacheend chil)
+ (while (and cacheend (not (eq last (car cacheend))))
+ (setq cacheend (cdr cacheend)))
+ ;; The splicable part is after cacheend.. so move cacheend
+ ;; one more tag.
+ (setq cacheend (cdr cacheend))
+ ;; Splice the found end tag into the cons cell
+ ;; owned by the current top child.
+ (setcar chil (car cacheend))
+ (setcdr chil (cdr cacheend))
+ (when (not cacheend)
+ ;; No cacheend.. then the whole system is empty.
+ ;; The best way to deal with that is to do a full
+ ;; reparse
+ (semantic-parse-changes-failed "Splice-remove failed. Empty
buffer?")
+ ))
+ (message "To Remove Middle Tag: (%s)"
+ (semantic-format-tag-name first)))
+ ;; Find in the cache the preceeding tag
+ (while (and cachestart (not (eq first (car (cdr cachestart)))))
+ (setq cachestart (cdr cachestart)))
+ ;; Find the last tag
+ (setq cacheend cachestart)
+ (while (and cacheend (not (eq last (car cacheend))))
+ (setq cacheend (cdr cacheend)))
+ ;; Splice the end position into the start position.
+ ;; If there is no start, then this whole section is probably
+ ;; gone.
+ (if cachestart
+ (setcdr cachestart (cdr cacheend))
+ (semantic-parse-changes-failed "Splice-remove failed."))
+
+ ;; Remove old overlays of these deleted tags
+ (while oldtags
+ (semantic--tag-unlink-from-buffer (car oldtags))
+ (setq oldtags (cdr oldtags)))
+ ))
+
+(defun semantic-edits-splice-insert (newtags parent cachelist)
+ "Insert NEWTAGS into PARENT using CACHELIST.
+PARENT could be nil, in which case CACHLIST is the buffer cache
+which must be updated.
+CACHELIST must be searched to find where NEWTAGS are to be inserted.
+The positions of NEWTAGS must be synchronized with those in
+CACHELIST for this to work. Some routines pre-position CACHLIST at a
+convenient location, so use that."
+ (let* ((start (semantic-tag-start (car newtags)))
+ (newtagendcell (nthcdr (1- (length newtags)) newtags))
+ (end (semantic-tag-end (car newtagendcell)))
+ )
+ (if (> (semantic-tag-start (car cachelist)) start)
+ ;; We are at the beginning.
+ (let* ((pc (if parent
+ (semantic-tag-components parent)
+ semantic--buffer-cache))
+ (nc (cons (car pc) (cdr pc))) ; new cons cell.
+ )
+ ;; Splice the new cache cons cell onto the end of our list.
+ (setcdr newtagendcell nc)
+ ;; Set our list into parent.
+ (setcar pc (car newtags))
+ (setcdr pc (cdr newtags)))
+ ;; We are at the end, or in the middle. Find our match first.
+ (while (and (cdr cachelist)
+ (> end (semantic-tag-start (car (cdr cachelist)))))
+ (setq cachelist (cdr cachelist)))
+ ;; Now splice into the list!
+ (setcdr newtagendcell (cdr cachelist))
+ (setcdr cachelist newtags))))
+
+(defun semantic-edits-splice-replace (oldtag newtag)
+ "Replace OLDTAG with NEWTAG in the current cache.
+Do this by recycling OLDTAG's first CONS cell. This effectivly
+causes the new tag to completely replace the old one.
+Make sure that all information in the overlay is transferred.
+It is presumed that OLDTAG and NEWTAG are both cooked.
+When this routine returns, OLDTAG is raw, and the data will be
+lost if not transferred into NEWTAG."
+ (let* ((oo (semantic-tag-overlay oldtag))
+ (o (semantic-tag-overlay newtag))
+ (oo-props (semantic-overlay-properties oo)))
+ (while oo-props
+ (semantic-overlay-put o (car oo-props) (car (cdr oo-props)))
+ (setq oo-props (cdr (cdr oo-props)))
+ )
+ ;; Free the old overlay(s)
+ (semantic--tag-unlink-from-buffer oldtag)
+ ;; Recover properties
+ (semantic--tag-copy-properties oldtag newtag)
+ ;; Splice into the main list.
+ (setcdr oldtag (cdr newtag))
+ (setcar oldtag (car newtag))
+ ;; This important bit is because the CONS cell representing
+ ;; OLDTAG is now pointing to NEWTAG, but the NEWTAG
+ ;; cell is about to be abandoned. Here we update our overlay
+ ;; to point at the updated state of the world.
+ (semantic-overlay-put o 'semantic oldtag)
+ ))
+
+(add-hook 'semantic-before-toplevel-cache-flush-hook
+ #'semantic-edits-flush-changes)
+
+(provide 'semantic/edit)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/edit"
+;; End:
+
+;;; semantic/edit.el ends here
Index: cedet/semantic/find.el
===================================================================
RCS file: cedet/semantic/find.el
diff -N cedet/semantic/find.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/find.el 28 Sep 2009 15:15:08 -0000 1.2
@@ -0,0 +1,705 @@
+;;; semantic/find.el --- Search routines for Semantic
+
+;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2008, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Routines for searching through lists of tags.
+;; There are several groups of tag search routines:
+;;
+;; 1) semantic-brute-find-tag-by-*
+;; These routines use brute force hierarchical search to scan
+;; through lists of tags. They include some parameters
+;; used for compatibility with the semantic 1.x search routines.
+;;
+;; 1.5) semantic-brute-find-first-tag-by-*
+;; Like 1, except seraching stops on the first match for the given
+;; information.
+;;
+;; 2) semantic-find-tag-by-*
+;; These prefered search routines attempt to scan through lists
+;; in an intelligent way based on questions asked.
+;;
+;; 3) semantic-find-*-overlay
+;; These routines use overlays to return tags based on a buffer position.
+;;
+;; 4) ...
+
+;;; Code:
+
+(require 'semantic)
+(require 'semantic/tag)
+
+(declare-function semantic-tag-protected-p "semantic/tag-ls")
+
+;;; Overlay Search Routines
+;;
+;; These routines provide fast access to tokens based on a buffer that
+;; has parsed tokens in it. Uses overlays to perform the hard work.
+;;
+;;;###autoload
+(defun semantic-find-tag-by-overlay (&optional positionormarker buffer)
+ "Find all tags covering POSITIONORMARKER by using overlays.
+If POSITIONORMARKER is nil, use the current point.
+Optional BUFFER is used if POSITIONORMARKER is a number, otherwise the current
+buffer is used. This finds all tags covering the specified position
+by checking for all overlays covering the current spot. They are then sorted
+from largest to smallest via the start location."
+ (save-excursion
+ (when positionormarker
+ (if (markerp positionormarker)
+ (set-buffer (marker-buffer positionormarker))
+ (if (bufferp buffer)
+ (set-buffer buffer))))
+ (let ((ol (semantic-overlays-at (or positionormarker (point))))
+ (ret nil))
+ (while ol
+ (let ((tmp (semantic-overlay-get (car ol) 'semantic)))
+ (when (and tmp
+ ;; We don't need with-position because no tag w/out
+ ;; a position could exist in an overlay.
+ (semantic-tag-p tmp))
+ (setq ret (cons tmp ret))))
+ (setq ol (cdr ol)))
+ (sort ret (lambda (a b) (< (semantic-tag-start a)
+ (semantic-tag-start b)))))))
+
+;;;###autoload
+(defun semantic-find-tag-by-overlay-in-region (start end &optional buffer)
+ "Find all tags which exist in whole or in part between START and END.
+Uses overlays to determine positin.
+Optional BUFFER argument specifies the buffer to use."
+ (save-excursion
+ (if buffer (set-buffer buffer))
+ (let ((ol (semantic-overlays-in start end))
+ (ret nil))
+ (while ol
+ (let ((tmp (semantic-overlay-get (car ol) 'semantic)))
+ (when (and tmp
+ ;; See above about position
+ (semantic-tag-p tmp))
+ (setq ret (cons tmp ret))))
+ (setq ol (cdr ol)))
+ (sort ret (lambda (a b) (< (semantic-tag-start a)
+ (semantic-tag-start b)))))))
+
+;;;###autoload
+(defun semantic-find-tag-by-overlay-next (&optional start buffer)
+ "Find the next tag after START in BUFFER.
+If START is in an overlay, find the tag which starts next,
+not the current tag."
+ (save-excursion
+ (if buffer (set-buffer buffer))
+ (if (not start) (setq start (point)))
+ (let ((os start) (ol nil))
+ (while (and os (< os (point-max)) (not ol))
+ (setq os (semantic-overlay-next-change os))
+ (when os
+ ;; Get overlays at position
+ (setq ol (semantic-overlays-at os))
+ ;; find the overlay that belongs to semantic
+ ;; and starts at the found position.
+ (while (and ol (listp ol))
+ (if (and (semantic-overlay-get (car ol) 'semantic)
+ (semantic-tag-p
+ (semantic-overlay-get (car ol) 'semantic))
+ (= (semantic-overlay-start (car ol)) os))
+ (setq ol (car ol)))
+ (when (listp ol) (setq ol (cdr ol))))))
+ ;; convert ol to a tag
+ (when (and ol (semantic-tag-p (semantic-overlay-get ol 'semantic)))
+ (semantic-overlay-get ol 'semantic)))))
+
+;;;###autoload
+(defun semantic-find-tag-by-overlay-prev (&optional start buffer)
+ "Find the next tag before START in BUFFER.
+If START is in an overlay, find the tag which starts next,
+not the current tag."
+ (save-excursion
+ (if buffer (set-buffer buffer))
+ (if (not start) (setq start (point)))
+ (let ((os start) (ol nil))
+ (while (and os (> os (point-min)) (not ol))
+ (setq os (semantic-overlay-previous-change os))
+ (when os
+ ;; Get overlays at position
+ (setq ol (semantic-overlays-at (1- os)))
+ ;; find the overlay that belongs to semantic
+ ;; and ENDS at the found position.
+ ;;
+ ;; Use end because we are going backward.
+ (while (and ol (listp ol))
+ (if (and (semantic-overlay-get (car ol) 'semantic)
+ (semantic-tag-p
+ (semantic-overlay-get (car ol) 'semantic))
+ (= (semantic-overlay-end (car ol)) os))
+ (setq ol (car ol)))
+ (when (listp ol) (setq ol (cdr ol))))))
+ ;; convert ol to a tag
+ (when (and ol
+ (semantic-tag-p (semantic-overlay-get ol 'semantic)))
+ (semantic-overlay-get ol 'semantic)))))
+
+;;;###autoload
+(defun semantic-find-tag-parent-by-overlay (tag)
+ "Find the parent of TAG by overlays.
+Overlays are a fast way of finding this information for active buffers."
+ (let ((tag (nreverse (semantic-find-tag-by-overlay
+ (semantic-tag-start tag)))))
+ ;; This is a lot like `semantic-current-tag-parent', but
+ ;; it uses a position to do it's work. Assumes two tags don't share
+ ;; the same start unless they are siblings.
+ (car (cdr tag))))
+
+;;;###autoload
+(defun semantic-current-tag ()
+ "Return the current tag in the current buffer.
+If there are more than one in the same location, return the
+smallest tag. Return nil if there is no tag here."
+ (car (nreverse (semantic-find-tag-by-overlay))))
+
+;;;###autoload
+(defun semantic-current-tag-parent ()
+ "Return the current tags parent in the current buffer.
+A tag's parent would be a containing structure, such as a type
+containing a field. Return nil if there is no parent."
+ (car (cdr (nreverse (semantic-find-tag-by-overlay)))))
+
+(defun semantic-current-tag-of-class (class)
+ "Return the current (smallest) tags of CLASS in the current buffer.
+If the smallest tag is not of type CLASS, keep going upwards until one
+is found.
+Uses `semantic-tag-class' for classification."
+ (let ((tags (nreverse (semantic-find-tag-by-overlay))))
+ (while (and tags
+ (not (eq (semantic-tag-class (car tags)) class)))
+ (setq tags (cdr tags)))
+ (car tags)))
+
+;;; Search Routines
+;;
+;; These are routines that search a single tags table.
+;;
+;; The original API (see COMPATIBILITY section below) in semantic 1.4
+;; had these usage statistics:
+;;
+;; semantic-find-nonterminal-by-name 17
+;; semantic-find-nonterminal-by-name-regexp 8 - Most doing completion
+;; semantic-find-nonterminal-by-position 13
+;; semantic-find-nonterminal-by-token 21
+;; semantic-find-nonterminal-by-type 2
+;; semantic-find-nonterminal-standard 1
+;;
+;; semantic-find-nonterminal-by-function (not in other searches) 1
+;;
+;; New API: As above w/out `search-parts' or `search-includes' arguments.
+;; Extra fcn: Specific to completion which is what -name-regexp is
+;; mostly used for
+;;
+;; As for the sarguments "search-parts" and "search-includes" here
+;; are stats:
+;;
+;; search-parts: 4 - charting x2, find-doc, senator (sans db)
+;;
+;; Implement command to flatten a tag table. Call new API Fcn w/
+;; flattened table for same results.
+;;
+;; search-include: 2 - analyze x2 (sans db)
+;;
+;; Not used effectively. Not to be re-implemented here.
+
+(defsubst semantic--find-tags-by-function (predicate &optional table)
+ "Find tags for which PREDICATE is non-nil in TABLE.
+PREDICATE is a lambda expression which accepts on TAG.
+TABLE is a semantic tags table. See `semantic-something-to-tag-table'."
+ (let ((tags (semantic-something-to-tag-table table))
+ (result nil))
+; (mapc (lambda (tag) (and (funcall predicate tag)
+; (setq result (cons tag result))))
+; tags)
+ ;; A while loop is actually faster. Who knew
+ (while tags
+ (and (funcall predicate (car tags))
+ (setq result (cons (car tags) result)))
+ (setq tags (cdr tags)))
+ (nreverse result)))
+
+;; I can shave off some time by removing the funcall (see above)
+;; and having the question be inlined in the while loop.
+;; Strangely turning the upper level fcns into macros had a larger
+;; impact.
+(defmacro semantic--find-tags-by-macro (form &optional table)
+ "Find tags for which FORM is non-nil in TABLE.
+TABLE is a semantic tags table. See `semantic-something-to-tag-table'."
+ `(let ((tags (semantic-something-to-tag-table ,table))
+ (result nil))
+ (while tags
+ (and ,form
+ (setq result (cons (car tags) result)))
+ (setq tags (cdr tags)))
+ (nreverse result)))
+
+;;; Top level Searches
+;;
+;;;###autoload
+(defun semantic-find-first-tag-by-name (name &optional table)
+ "Find the first tag with NAME in TABLE.
+NAME is a string.
+TABLE is a semantic tags table. See `semantic-something-to-tag-table'.
+This routine uses `assoc' to quickly find the first matching entry."
+ (funcall (if semantic-case-fold 'assoc-ignore-case 'assoc)
+ name (semantic-something-to-tag-table table)))
+
+(defmacro semantic-find-tags-by-name (name &optional table)
+ "Find all tags with NAME in TABLE.
+NAME is a string.
+TABLE is a tag table. See `semantic-something-to-tag-table'."
+ `(let ((case-fold-search semantic-case-fold))
+ (semantic--find-tags-by-macro
+ (string= ,name (semantic-tag-name (car tags)))
+ ,table)))
+
+(defmacro semantic-find-tags-for-completion (prefix &optional table)
+ "Find all tags whos name begins with PREFIX in TABLE.
+PREFIX is a string.
+TABLE is a tag table. See `semantic-something-to-tag-table'.
+While it would be nice to use `try-completion' or `all-completions',
+those functions do not return the tags, only a string.
+Uses `compare-strings' for fast comparison."
+ `(let ((l (length ,prefix)))
+ (semantic--find-tags-by-macro
+ (eq (compare-strings ,prefix 0 nil
+ (semantic-tag-name (car tags)) 0 l
+ semantic-case-fold)
+ t)
+ ,table)))
+
+(defmacro semantic-find-tags-by-name-regexp (regexp &optional table)
+ "Find all tags with name matching REGEXP in TABLE.
+REGEXP is a string containing a regular expression,
+TABLE is a tag table. See `semantic-something-to-tag-table'.
+Consider using `semantic-find-tags-for-completion' if you are
+attempting to do completions."
+ `(let ((case-fold-search semantic-case-fold))
+ (semantic--find-tags-by-macro
+ (string-match ,regexp (semantic-tag-name (car tags)))
+ ,table)))
+
+(defmacro semantic-find-tags-by-class (class &optional table)
+ "Find all tags of class CLASS in TABLE.
+CLASS is a symbol representing the class of the token, such as
+'variable, of 'function..
+TABLE is a tag table. See `semantic-something-to-tag-table'."
+ `(semantic--find-tags-by-macro
+ (eq ,class (semantic-tag-class (car tags)))
+ ,table))
+
+(defmacro semantic-find-tags-by-type (type &optional table)
+ "Find all tags of with a type TYPE in TABLE.
+TYPE is a string or tag representing a data type as defined in the
+language the tags were parsed from, such as \"int\", or perhaps
+a tag whose name is that of a struct or class.
+TABLE is a tag table. See `semantic-something-to-tag-table'."
+ `(semantic--find-tags-by-macro
+ (semantic-tag-of-type-p (car tags) ,type)
+ ,table))
+
+(defmacro semantic-find-tags-of-compound-type (&optional table)
+ "Find all tags which are a compound type in TABLE.
+Compound types are structures, or other data type which
+is not of a primitive nature, such as int or double.
+Used in completion."
+ `(semantic--find-tags-by-macro
+ (semantic-tag-type-compound-p (car tags))
+ ,table))
+
+;;;###autoload
+(define-overloadable-function semantic-find-tags-by-scope-protection
(scopeprotection parent &optional table)
+ "Find all tags accessable by SCOPEPROTECTION.
+SCOPEPROTECTION is a symbol which can be returned by the method
+`semantic-tag-protection'. A hard-coded order is used to determine a match.
+PARENT is a tag representing the PARENT slot needed for
+`semantic-tag-protection'.
+TABLE is a list of tags (a subset of PARENT members) to scan. If TABLE is nil,
+the type members of PARENT are used.
+See `semantic-tag-protected-p' for details on which tags are returned."
+ (if (not (eq (semantic-tag-class parent) 'type))
+ (signal 'wrong-type-argument '(semantic-find-tags-by-scope-protection
+ parent
+ semantic-tag-class type))
+ (:override)))
+
+(defun semantic-find-tags-by-scope-protection-default
+ (scopeprotection parent &optional table)
+ "Find all tags accessable by SCOPEPROTECTION.
+SCOPEPROTECTION is a symbol which can be returned by the method
+`semantic-tag-protection'. A hard-coded order is used to determine a match.
+PARENT is a tag representing the PARENT slot needed for
+`semantic-tag-protection'.
+TABLE is a list of tags (a subset of PARENT members) to scan. If TABLE is nil,
+the type members of PARENT are used.
+See `semantic-tag-protected-p' for details on which tags are returned."
+ (if (not table) (setq table (semantic-tag-type-members parent)))
+ (if (null scopeprotection)
+ table
+ (require 'semantic/tag-ls)
+ (semantic--find-tags-by-macro
+ (not (semantic-tag-protected-p (car tags) scopeprotection parent))
+ table)))
+
+(defsubst semantic-find-tags-included (&optional table)
+ "Find all tags in TABLE that are of the 'include class.
+TABLE is a tag table. See `semantic-something-to-tag-table'."
+ (semantic-find-tags-by-class 'include table))
+
+;;; Deep Searches
+
+(defmacro semantic-deep-find-tags-by-name (name &optional table)
+ "Find all tags with NAME in TABLE.
+Search in top level tags, and their components, in TABLE.
+NAME is a string.
+TABLE is a tag table. See `semantic-flatten-tags-table'.
+See also `semantic-find-tags-by-name'."
+ `(semantic-find-tags-by-name
+ ,name (semantic-flatten-tags-table ,table)))
+
+(defmacro semantic-deep-find-tags-for-completion (prefix &optional table)
+ "Find all tags whos name begins with PREFIX in TABLE.
+Search in top level tags, and their components, in TABLE.
+TABLE is a tag table. See `semantic-flatten-tags-table'.
+See also `semantic-find-tags-for-completion'."
+ `(semantic-find-tags-for-completion
+ ,prefix (semantic-flatten-tags-table ,table)))
+
+(defmacro semantic-deep-find-tags-by-name-regexp (regexp &optional table)
+ "Find all tags with name matching REGEXP in TABLE.
+Search in top level tags, and their components, in TABLE.
+REGEXP is a string containing a regular expression,
+TABLE is a tag table. See `semantic-flatten-tags-table'.
+See also `semantic-find-tags-by-name-regexp'.
+Consider using `semantic-deep-find-tags-for-completion' if you are
+attempting to do completions."
+ `(semantic-find-tags-by-name-regexp
+ ,regexp (semantic-flatten-tags-table ,table)))
+
+;;; Specialty Searches
+
+(defun semantic-find-tags-external-children-of-type (type &optional table)
+ "Find all tags in whose parent is TYPE in TABLE.
+These tags are defined outside the scope of the original TYPE declaration.
+TABLE is a tag table. See `semantic-something-to-tag-table'."
+ (semantic--find-tags-by-macro
+ (equal (semantic-tag-external-member-parent (car tags))
+ type)
+ table))
+
+(defun semantic-find-tags-subclasses-of-type (type &optional table)
+ "Find all tags of class type in whose parent is TYPE in TABLE.
+These tags are defined outside the scope of the original TYPE declaration.
+TABLE is a tag table. See `semantic-something-to-tag-table'."
+ (semantic--find-tags-by-macro
+ (and (eq (semantic-tag-class (car tags)) 'type)
+ (or (member type (semantic-tag-type-superclasses (car tags)))
+ (member type (semantic-tag-type-interfaces (car tags)))))
+ table))
+
+;;
+;; ************************** Compatibility ***************************
+;;
+
+;;; Old Style Brute Force Search Routines
+;;
+;; These functions will search through tags lists explicity for
+;; desired information.
+
+;; The -by-name nonterminal search can use the built in fcn
+;; `assoc', which is faster than looping ourselves, so we will
+;; not use `semantic-brute-find-tag-by-function' to do this,
+;; instead erroring on the side of speed.
+
+(defun semantic-brute-find-first-tag-by-name
+ (name streamorbuffer &optional search-parts search-include)
+ "Find a tag NAME within STREAMORBUFFER. NAME is a string.
+If SEARCH-PARTS is non-nil, search children of tags.
+If SEARCH-INCLUDE was never implemented.
+
+Use `semantic-find-first-tag-by-name' instead."
+ (let* ((stream (semantic-something-to-tag-table streamorbuffer))
+ (assoc-fun (if semantic-case-fold
+ #'assoc-ignore-case
+ #'assoc))
+ (m (funcall assoc-fun name stream)))
+ (if m
+ m
+ (let ((toklst stream)
+ (children nil))
+ (while (and (not m) toklst)
+ (if search-parts
+ (progn
+ (setq children (semantic-tag-components-with-overlays
+ (car toklst)))
+ (if children
+ (setq m (semantic-brute-find-first-tag-by-name
+ name children search-parts search-include)))))
+ (setq toklst (cdr toklst)))
+ (if (not m)
+ ;; Go to dependencies, and search there.
+ nil)
+ m))))
+
+(defmacro semantic-brute-find-tag-by-class
+ (class streamorbuffer &optional search-parts search-includes)
+ "Find all tags with a class CLASS within STREAMORBUFFER.
+CLASS is a symbol representing the class of the tags to find.
+See `semantic-tag-class'.
+Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
+`semantic-brute-find-tag-by-function'.
+
+Use `semantic-find-tag-by-class' instead."
+ `(semantic-brute-find-tag-by-function
+ (lambda (tag) (eq ,class (semantic-tag-class tag)))
+ ,streamorbuffer ,search-parts ,search-includes))
+
+(defmacro semantic-brute-find-tag-standard
+ (streamorbuffer &optional search-parts search-includes)
+ "Find all tags in STREAMORBUFFER which define simple class types.
+See `semantic-tag-class'.
+Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
+`semantic-brute-find-tag-by-function'."
+ `(semantic-brute-find-tag-by-function
+ (lambda (tag) (member (semantic-tag-class tag)
+ '(function variable type)))
+ ,streamorbuffer ,search-parts ,search-includes))
+
+(defun semantic-brute-find-tag-by-type
+ (type streamorbuffer &optional search-parts search-includes)
+ "Find all tags with type TYPE within STREAMORBUFFER.
+TYPE is a string which is the name of the type of the tags returned.
+See `semantic-tag-type'.
+Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
+`semantic-brute-find-tag-by-function'."
+ (semantic-brute-find-tag-by-function
+ (lambda (tag)
+ (let ((ts (semantic-tag-type tag)))
+ (if (and (listp ts)
+ (or (= (length ts) 1)
+ (eq (semantic-tag-class ts) 'type)))
+ (setq ts (semantic-tag-name ts)))
+ (equal type ts)))
+ streamorbuffer search-parts search-includes))
+
+(defun semantic-brute-find-tag-by-type-regexp
+ (regexp streamorbuffer &optional search-parts search-includes)
+ "Find all tags with type matching REGEXP within STREAMORBUFFER.
+REGEXP is a regular expression which matches the name of the type of the
+tags returned. See `semantic-tag-type'.
+Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
+`semantic-brute-find-tag-by-function'."
+ (semantic-brute-find-tag-by-function
+ (lambda (tag)
+ (let ((ts (semantic-tag-type tag)))
+ (if (listp ts)
+ (setq ts
+ (if (eq (semantic-tag-class ts) 'type)
+ (semantic-tag-name ts)
+ (car ts))))
+ (and ts (string-match regexp ts))))
+ streamorbuffer search-parts search-includes))
+
+(defun semantic-brute-find-tag-by-name-regexp
+ (regex streamorbuffer &optional search-parts search-includes)
+ "Find all tags whose name match REGEX in STREAMORBUFFER.
+Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
+`semantic-brute-find-tag-by-function'."
+ (semantic-brute-find-tag-by-function
+ (lambda (tag) (string-match regex (semantic-tag-name tag)))
+ streamorbuffer search-parts search-includes)
+ )
+
+(defun semantic-brute-find-tag-by-property
+ (property value streamorbuffer &optional search-parts search-includes)
+ "Find all tags with PROPERTY equal to VALUE in STREAMORBUFFER.
+Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
+`semantic-brute-find-tag-by-function'."
+ (semantic-brute-find-tag-by-function
+ (lambda (tag) (equal (semantic--tag-get-property tag property) value))
+ streamorbuffer search-parts search-includes)
+ )
+
+(defun semantic-brute-find-tag-by-attribute
+ (attr streamorbuffer &optional search-parts search-includes)
+ "Find all tags with a given ATTR in STREAMORBUFFER.
+ATTR is a symbol key into the attributes list.
+Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
+`semantic-brute-find-tag-by-function'."
+ (semantic-brute-find-tag-by-function
+ (lambda (tag) (semantic-tag-get-attribute tag attr))
+ streamorbuffer search-parts search-includes)
+ )
+
+(defun semantic-brute-find-tag-by-attribute-value
+ (attr value streamorbuffer &optional search-parts search-includes)
+ "Find all tags with a given ATTR equal to VALUE in STREAMORBUFFER.
+ATTR is a symbol key into the attributes list.
+VALUE is the value that ATTR should match.
+Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
+`semantic-brute-find-tag-by-function'."
+ (semantic-brute-find-tag-by-function
+ (lambda (tag) (equal (semantic-tag-get-attribute tag attr) value))
+ streamorbuffer search-parts search-includes)
+ )
+
+(defun semantic-brute-find-tag-by-function
+ (function streamorbuffer &optional search-parts search-includes)
+ "Find all tags for which FUNCTION's value is non-nil within STREAMORBUFFER.
+FUNCTION must return non-nil if an element of STREAM will be included
+in the new list.
+
+If optional argument SEARCH-PARTS is non-nil, all sub-parts of tags
+are searched. The overloadable function `semantic-tag-componenets' is
+used for the searching child lists. If SEARCH-PARTS is the symbol
+'positiononly, then only children that have positional information are
+searched.
+
+If SEARCH-INCLUDES has not been implemented.
+This parameter hasn't be active for a while and is obsolete."
+ (let ((stream (semantic-something-to-tag-table streamorbuffer))
+ (sl nil) ;list of tag children
+ (nl nil) ;new list
+ (case-fold-search semantic-case-fold))
+ (dolist (tag stream)
+ (if (not (semantic-tag-p tag))
+ ;; `semantic-tag-components-with-overlays' can return invalid
+ ;; tags if search-parts is not equal to 'positiononly
+ nil ;; Ignore them!
+ (if (funcall function tag)
+ (setq nl (cons tag nl)))
+ (and search-parts
+ (setq sl (if (eq search-parts 'positiononly)
+ (semantic-tag-components-with-overlays tag)
+ (semantic-tag-components tag))
+ )
+ (setq nl (nconc nl
+ (semantic-brute-find-tag-by-function
+ function sl
+ search-parts))))))
+ (setq nl (nreverse nl))
+ nl))
+
+(defun semantic-brute-find-first-tag-by-function
+ (function streamorbuffer &optional search-parts search-includes)
+ "Find the first tag which FUNCTION match within STREAMORBUFFER.
+FUNCTION must return non-nil if an element of STREAM will be included
+in the new list.
+
+The following parameters were never implemented.
+
+If optional argument SEARCH-PARTS, all sub-parts of tags are searched.
+The overloadable function `semantic-tag-components' is used for
+searching.
+If SEARCH-INCLUDES is non-nil, then all include files are also
+searched for matches."
+ (let ((stream (semantic-something-to-tag-table streamorbuffer))
+ (found nil)
+ (case-fold-search semantic-case-fold))
+ (while (and (not found) stream)
+ (if (funcall function (car stream))
+ (setq found (car stream)))
+ (setq stream (cdr stream)))
+ found))
+
+
+;;; Old Positional Searches
+;;
+;; Are these useful anymore?
+;;
+(defun semantic-brute-find-tag-by-position (position streamorbuffer
+ &optional nomedian)
+ "Find a tag covering POSITION within STREAMORBUFFER.
+POSITION is a number, or marker. If NOMEDIAN is non-nil, don't do
+the median calculation, and return nil."
+ (save-excursion
+ (if (markerp position) (set-buffer (marker-buffer position)))
+ (let* ((stream (if (bufferp streamorbuffer)
+ (save-excursion
+ (set-buffer streamorbuffer)
+ (semantic-fetch-tags))
+ streamorbuffer))
+ (prev nil)
+ (found nil))
+ (while (and stream (not found))
+ ;; perfect fit
+ (if (and (>= position (semantic-tag-start (car stream)))
+ (<= position (semantic-tag-end (car stream))))
+ (setq found (car stream))
+ ;; Median between to objects.
+ (if (and prev (not nomedian)
+ (>= position (semantic-tag-end prev))
+ (<= position (semantic-tag-start (car stream))))
+ (let ((median (/ (+ (semantic-tag-end prev)
+ (semantic-tag-start (car stream)))
+ 2)))
+ (setq found
+ (if (> position median)
+ (car stream)
+ prev)))))
+ ;; Next!!!
+ (setq prev (car stream)
+ stream (cdr stream)))
+ found)))
+
+(defun semantic-brute-find-innermost-tag-by-position
+ (position streamorbuffer &optional nomedian)
+ "Find a list of tags covering POSITION within STREAMORBUFFER.
+POSITION is a number, or marker. If NOMEDIAN is non-nil, don't do
+the median calculation, and return nil.
+This function will find the topmost item, and recurse until no more
+details are available of findable."
+ (let* ((returnme nil)
+ (current (semantic-brute-find-tag-by-position
+ position streamorbuffer nomedian))
+ (nextstream (and current
+ (if (eq (semantic-tag-class current) 'type)
+ (semantic-tag-type-members current)
+ nil))))
+ (while nextstream
+ (setq returnme (cons current returnme))
+ (setq current (semantic-brute-find-tag-by-position
+ position nextstream nomedian))
+ (setq nextstream (and current
+ ;; NOTE TO SELF:
+ ;; Looking at this after several years away,
+ ;; what does this do???
+ (if (eq (semantic-tag-class current) 'token)
+ (semantic-tag-type-members current)
+ nil))))
+ (nreverse (cons current returnme))))
+
+(provide 'semantic/find)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/find"
+;; End:
+
+;;; semantic/find.el ends here
Index: cedet/semantic/format.el
===================================================================
RCS file: cedet/semantic/format.el
diff -N cedet/semantic/format.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/format.el 28 Sep 2009 15:15:08 -0000 1.2
@@ -0,0 +1,724 @@
+;;; semantic/format.el --- Routines for formatting tags
+
+;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
+;;; 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Once a language file has been parsed into a TAG, it is often useful
+;; then display that tag information in browsers, completion engines, or
+;; help routines. The functions and setup in this file provide ways
+;; to reformat a tag into different standard output types.
+;;
+;; In addition, macros for setting up customizable variables that let
+;; the user choose their default format type are also provided.
+;;
+
+;;; Code:
+(eval-when-compile (require 'font-lock))
+(require 'semantic)
+(require 'semantic/tag-ls)
+(require 'ezimage)
+
+(eval-when-compile (require 'semantic/find))
+
+;;; Tag to text overload functions
+;;
+;; abbreviations, prototypes, and coloring support.
+(defvar semantic-format-tag-functions
+ '(semantic-format-tag-name
+ semantic-format-tag-canonical-name
+ semantic-format-tag-abbreviate
+ semantic-format-tag-summarize
+ semantic-format-tag-summarize-with-file
+ semantic-format-tag-short-doc
+ semantic-format-tag-prototype
+ semantic-format-tag-concise-prototype
+ semantic-format-tag-uml-abbreviate
+ semantic-format-tag-uml-prototype
+ semantic-format-tag-uml-concise-prototype
+ semantic-format-tag-prin1
+ )
+ "List of functions which convert a tag to text.
+Each function must take the parameters TAG &optional PARENT COLOR.
+TAG is the tag to convert.
+PARENT is a parent tag or name which refers to the structure
+or class which contains TAG. PARENT is NOT a class which a TAG
+would claim as a parent.
+COLOR indicates that the generated text should be colored using
+`font-lock'.")
+
+(defvar semantic-format-tag-custom-list
+ (append '(radio)
+ (mapcar (lambda (f) (list 'const f))
+ semantic-format-tag-functions)
+ '(function))
+ "A List used by customizeable variables to choose a tag to text function.
+Use this variable in the :type field of a customizable variable.")
+
+(defcustom semantic-format-use-images-flag ezimage-use-images
+ "Non-nil means semantic format functions use images.
+Images can be used as icons instead of some types of text strings."
+ :group 'semantic
+ :type 'boolean)
+
+(defvar semantic-function-argument-separator ","
+ "Text used to separate arguments when creating text from tags.")
+(make-variable-buffer-local 'semantic-function-argument-separator)
+
+(defvar semantic-format-parent-separator "::"
+ "Text used to separate names when between namespaces/classes and functions.")
+(make-variable-buffer-local 'semantic-format-parent-separator)
+
+(defvar semantic-format-face-alist
+ `( (function . font-lock-function-name-face)
+ (variable . font-lock-variable-name-face)
+ (type . font-lock-type-face)
+ ;; These are different between Emacsen.
+ (include . ,(if (featurep 'xemacs)
+ 'font-lock-preprocessor-face
+ 'font-lock-constant-face))
+ (package . ,(if (featurep 'xemacs)
+ 'font-lock-preprocessor-face
+ 'font-lock-constant-face))
+ ;; Not a tag, but instead a feature of output
+ (label . font-lock-string-face)
+ (comment . font-lock-comment-face)
+ (keyword . font-lock-keyword-face)
+ (abstract . italic)
+ (static . underline)
+ (documentation . font-lock-doc-face)
+ )
+ "Face used to colorize tags of different types.
+Override the value locally if a language supports other tag types.
+When adding new elements, try to use symbols also returned by the parser.
+The form of an entry in this list is of the form:
+ ( SYMBOL . FACE )
+where SYMBOL is a tag type symbol used with semantic. FACE
+is a symbol representing a face.
+Faces used are generated in `font-lock' for consistency, and will not
+be used unless font lock is a feature.")
+
+
+;;; Coloring Functions
+;;
+(defun semantic--format-colorize-text (text face-class)
+ "Apply onto TEXT a color associated with FACE-CLASS.
+FACE-CLASS is a tag type found in `semantic-format-face-alist'.
+See that variable for details on adding new types."
+ (if (featurep 'font-lock)
+ (let ((face (cdr-safe (assoc face-class semantic-format-face-alist)))
+ (newtext (concat text)))
+ (put-text-property 0 (length text) 'face face newtext)
+ newtext)
+ text))
+
+(defun semantic--format-colorize-merge-text (precoloredtext face-class)
+ "Apply onto PRECOLOREDTEXT a color associated with FACE-CLASS.
+FACE-CLASS is a tag type found in `semantic-formatface-alist'.
+See that variable for details on adding new types."
+ (let ((face (cdr-safe (assoc face-class semantic-format-face-alist)))
+ (newtext (concat precoloredtext))
+ )
+ (if (featurep 'xemacs)
+ (add-text-properties 0 (length newtext) (list 'face face) newtext)
+ (alter-text-property 0 (length newtext) 'face
+ (lambda (current-face)
+ (let ((cf
+ (cond ((facep current-face)
+ (list current-face))
+ ((listp current-face)
+ current-face)
+ (t nil)))
+ (nf
+ (cond ((facep face)
+ (list face))
+ ((listp face)
+ face)
+ (t nil))))
+ (append cf nf)))
+ newtext))
+ newtext))
+
+;;; Function Arguments
+;;
+(defun semantic--format-tag-arguments (args formatter color)
+ "Format the argument list ARGS with FORMATTER.
+FORMATTER is a function used to format a tag.
+COLOR specifies if color should be used."
+ (let ((out nil))
+ (while args
+ (push (if (and formatter
+ (semantic-tag-p (car args))
+ (not (string= (semantic-tag-name (car args)) ""))
+ )
+ (funcall formatter (car args) nil color)
+ (semantic-format-tag-name-from-anything
+ (car args) nil color 'variable))
+ out)
+ (setq args (cdr args)))
+ (mapconcat 'identity (nreverse out) semantic-function-argument-separator)
+ ))
+
+;;; Data Type
+(define-overloadable-function semantic-format-tag-type (tag color)
+ "Convert the data type of TAG to a string usable in tag formatting.
+It is presumed that TYPE is a string or semantic tag.")
+
+(defun semantic-format-tag-type-default (tag color)
+ "Convert the data type of TAG to a string usable in tag formatting.
+Argument COLOR specifies to colorize the text."
+ (let* ((type (semantic-tag-type tag))
+ (out (cond ((semantic-tag-p type)
+ (let* ((typetype (semantic-tag-type type))
+ (name (semantic-tag-name type))
+ (str (if typetype
+ (concat typetype " " name)
+ name)))
+ (if color
+ (semantic--format-colorize-text
+ str
+ 'type)
+ str)))
+ ((and (listp type)
+ (stringp (car type)))
+ (car type))
+ ((stringp type)
+ type)
+ (t nil))))
+ (if (and color out)
+ (setq out (semantic--format-colorize-text out 'type))
+ out)
+ ))
+
+
+;;; Abstract formatting functions
+;;
+
+(defun semantic-format-tag-prin1 (tag &optional parent color)
+ "Convert TAG to a string that is the print name for TAG.
+PARENT and COLOR are ignored."
+ (format "%S" tag))
+
+(defun semantic-format-tag-name-from-anything (anything &optional
+ parent color
+ colorhint)
+ "Convert just about anything into a name like string.
+Argument ANYTHING is the thing to be converted.
+Optional argument PARENT is the parent type if TAG is a detail.
+Optional argument COLOR means highlight the prototype with font-lock colors.
+Optional COLORHINT is the type of color to use if ANYTHING is not a tag
+with a tag class. See `semantic--format-colorize-text' for a definition
+of FACE-CLASS for which this is used."
+ (cond ((stringp anything)
+ (semantic--format-colorize-text anything colorhint))
+ ((semantic-tag-p anything)
+ (let ((ans (semantic-format-tag-name anything parent color)))
+ ;; If ANS is empty string or nil, then the name wasn't
+ ;; supplied. The implication is as in C where there is a data
+ ;; type but no name for a prototype from an include file, or
+ ;; an argument just wasn't used in the body of the fcn.
+ (if (or (null ans) (string= ans ""))
+ (setq ans (semantic-format-tag-type anything color)))
+ ans))
+ ((and (listp anything)
+ (stringp (car anything)))
+ (semantic--format-colorize-text (car anything) colorhint))))
+
+;;;###autoload
+(define-overloadable-function semantic-format-tag-name (tag &optional parent
color)
+ "Return the name string describing TAG.
+The name is the shortest possible representation.
+Optional argument PARENT is the parent type if TAG is a detail.
+Optional argument COLOR means highlight the prototype with font-lock colors.")
+
+(defun semantic-format-tag-name-default (tag &optional parent color)
+ "Return an abbreviated string describing TAG.
+Optional argument PARENT is the parent type if TAG is a detail.
+Optional argument COLOR means highlight the prototype with font-lock colors."
+ (let ((name (semantic-tag-name tag))
+ (destructor
+ (if (eq (semantic-tag-class tag) 'function)
+ (semantic-tag-function-destructor-p tag))))
+ (when destructor
+ (setq name (concat "~" name)))
+ (if color
+ (setq name (semantic--format-colorize-text name (semantic-tag-class
tag))))
+ name))
+
+(declare-function semantic-go-to-tag "semantic/tag-file")
+
+(defun semantic--format-tag-parent-tree (tag parent)
+ "Under Consideration.
+
+Return a list of parents for TAG.
+PARENT is the first parent, or nil. If nil, then an attempt to
+determine PARENT is made.
+Once PARENT is identified, additional parents are looked for.
+The return list first element is the nearest parent, and the last
+item is the first parent which may be a string. The root parent may
+not be the actual first parent as there may just be a failure to find
+local definitions."
+ ;; First, validate the PARENT argument.
+ (unless parent
+ ;; All mechanisms here must be fast as often parent
+ ;; is nil because there isn't one.
+ (setq parent (or (semantic-tag-function-parent tag)
+ (save-excursion
+ (require 'semantic/tag-file)
+ (semantic-go-to-tag tag)
+ (semantic-current-tag-parent)))))
+ (when (stringp parent)
+ (setq parent (semantic-find-first-tag-by-name
+ parent (current-buffer))))
+ ;; Try and find a trail of parents from PARENT
+ (let ((rlist (list parent))
+ )
+ ;; IMPLELEMENT ME!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ (reverse rlist)))
+
+(define-overloadable-function semantic-format-tag-canonical-name (tag
&optional parent color)
+ "Return a canonical name for TAG.
+A canonical name includes the names of any parents or namespaces preceeding
+the tag.
+Optional argument PARENT is the parent type if TAG is a detail.
+Optional argument COLOR means highlight the prototype with font-lock colors.")
+
+(defun semantic-format-tag-canonical-name-default (tag &optional parent color)
+ "Return a canonical name for TAG.
+A canonical name includes the names of any parents or namespaces preceeding
+the tag with colons separating them.
+Optional argument PARENT is the parent type if TAG is a detail.
+Optional argument COLOR means highlight the prototype with font-lock colors."
+ (let ((parent-input-str
+ (if (and parent
+ (semantic-tag-p parent)
+ (semantic-tag-of-class-p parent 'type))
+ (concat
+ ;; Choose a class of 'type as the default parent for something.
+ ;; Just a guess though.
+ (semantic-format-tag-name-from-anything parent nil color 'type)
+ ;; Default separator between class/namespace and others.
+ semantic-format-parent-separator)
+ ""))
+ (tag-parent-str
+ (or (when (and (semantic-tag-of-class-p tag 'function)
+ (semantic-tag-function-parent tag))
+ (concat (semantic-tag-function-parent tag)
+ semantic-format-parent-separator))
+ ""))
+ )
+ (concat parent-input-str
+ tag-parent-str
+ (semantic-format-tag-name tag parent color))
+ ))
+
+(define-overloadable-function semantic-format-tag-abbreviate (tag &optional
parent color)
+ "Return an abbreviated string describing TAG.
+The abbreviation is to be short, with possible symbols indicating
+the type of tag, or other information.
+Optional argument PARENT is the parent type if TAG is a detail.
+Optional argument COLOR means highlight the prototype with font-lock colors.")
+
+(defun semantic-format-tag-abbreviate-default (tag &optional parent color)
+ "Return an abbreviated string describing TAG.
+Optional argument PARENT is a parent tag in the tag hierarchy.
+In this case PARENT refers to containment, not inheritance.
+Optional argument COLOR means highlight the prototype with font-lock colors.
+This is a simple C like default."
+ ;; Do lots of complex stuff here.
+ (let ((class (semantic-tag-class tag))
+ (name (semantic-format-tag-canonical-name tag parent color))
+ (suffix "")
+ (prefix "")
+ str)
+ (cond ((eq class 'function)
+ (setq suffix "()"))
+ ((eq class 'include)
+ (setq suffix "<>"))
+ ((eq class 'variable)
+ (setq suffix (if (semantic-tag-variable-default tag)
+ "=" "")))
+ ((eq class 'label)
+ (setq suffix ":"))
+ ((eq class 'code)
+ (setq prefix "{"
+ suffix "}"))
+ ((eq class 'type)
+ (setq suffix "{}"))
+ )
+ (setq str (concat prefix name suffix))
+ str))
+
+;;;###autoload
+(define-overloadable-function semantic-format-tag-summarize (tag &optional
parent color)
+ "Summarize TAG in a reasonable way.
+Optional argument PARENT is the parent type if TAG is a detail.
+Optional argument COLOR means highlight the prototype with font-lock colors.")
+
+(defun semantic-format-tag-summarize-default (tag &optional parent color)
+ "Summarize TAG in a reasonable way.
+Optional argument PARENT is the parent type if TAG is a detail.
+Optional argument COLOR means highlight the prototype with font-lock colors."
+ (let* ((proto (semantic-format-tag-prototype tag nil color))
+ (names (if parent
+ semantic-symbol->name-assoc-list-for-type-parts
+ semantic-symbol->name-assoc-list))
+ (tsymb (semantic-tag-class tag))
+ (label (capitalize (or (cdr-safe (assoc tsymb names))
+ (symbol-name tsymb)))))
+ (if color
+ (setq label (semantic--format-colorize-text label 'label)))
+ (concat label ": " proto)))
+
+(define-overloadable-function semantic-format-tag-summarize-with-file (tag
&optional parent color)
+ "Like `semantic-format-tag-summarize', but with the file name.
+Optional argument PARENT is the parent type if TAG is a detail.
+Optional argument COLOR means highlight the prototype with font-lock colors.")
+
+(defun semantic-format-tag-summarize-with-file-default (tag &optional parent
color)
+ "Summarize TAG in a reasonable way.
+Optional argument PARENT is the parent type if TAG is a detail.
+Optional argument COLOR means highlight the prototype with font-lock colors."
+ (let* ((proto (semantic-format-tag-prototype tag nil color))
+ (file (semantic-tag-file-name tag))
+ )
+ ;; Nothing for tag? Try parent.
+ (when (and (not file) (and parent))
+ (setq file (semantic-tag-file-name parent)))
+ ;; Don't include the file name if we can't find one, or it is the
+ ;; same as the current buffer.
+ (if (or (not file)
+ (string= file (buffer-file-name (current-buffer))))
+ proto
+ (setq file (file-name-nondirectory file))
+ (when color
+ (setq file (semantic--format-colorize-text file 'label)))
+ (concat file ": " proto))))
+
+(define-overloadable-function semantic-format-tag-short-doc (tag &optional
parent color)
+ "Display a short form of TAG's documentation. (Comments, or docstring.)
+Optional argument PARENT is the parent type if TAG is a detail.
+Optional argument COLOR means highlight the prototype with font-lock colors.")
+
+(declare-function semantic-documentation-for-tag "semantic/doc")
+
+(defun semantic-format-tag-short-doc-default (tag &optional parent color)
+ "Display a short form of TAG's documentation. (Comments, or docstring.)
+Optional argument PARENT is the parent type if TAG is a detail.
+Optional argument COLOR means highlight the prototype with font-lock colors."
+ (let* ((fname (or (semantic-tag-file-name tag)
+ (when parent (semantic-tag-file-name parent))))
+ (buf (or (semantic-tag-buffer tag)
+ (when parent (semantic-tag-buffer parent))))
+ (doc (semantic-tag-docstring tag buf)))
+ (when (and (not doc) (not buf) fname)
+ ;; If there is no doc, and no buffer, but we have a filename,
+ ;; lets try again.
+ (save-match-data
+ (setq buf (find-file-noselect fname)))
+ (setq doc (semantic-tag-docstring tag buf)))
+ (when (not doc)
+ (require 'semantic/doc)
+ (setq doc (semantic-documentation-for-tag tag))
+ )
+ (setq doc
+ (if (not doc)
+ ;; No doc, use summarize.
+ (semantic-format-tag-summarize tag parent color)
+ ;; We have doc. Can we devise a single line?
+ (if (string-match "$" doc)
+ (substring doc 0 (match-beginning 0))
+ doc)
+ ))
+ (when color
+ (setq doc (semantic--format-colorize-text doc 'documentation)))
+ doc
+ ))
+
+;;; Prototype generation
+;;
+;;;###autoload
+(define-overloadable-function semantic-format-tag-prototype (tag &optional
parent color)
+ "Return a prototype for TAG.
+This function should be overloaded, though it need not be used.
+This is because it can be used to create code by language independent
+tools.
+Optional argument PARENT is the parent type if TAG is a detail.
+Optional argument COLOR means highlight the prototype with font-lock colors.")
+
+(defun semantic-format-tag-prototype-default (tag &optional parent color)
+ "Default method for returning a prototype for TAG.
+This will work for C like languages.
+Optional argument PARENT is the parent type if TAG is a detail.
+Optional argument COLOR means highlight the prototype with font-lock colors."
+ (let* ((class (semantic-tag-class tag))
+ (name (semantic-format-tag-name tag parent color))
+ (type (if (member class '(function variable type))
+ (semantic-format-tag-type tag color)))
+ (args (if (member class '(function type))
+ (semantic--format-tag-arguments
+ (if (eq class 'function)
+ (semantic-tag-function-arguments tag)
+ (list "")
+ ;;(semantic-tag-type-members tag)
+ )
+ #'semantic-format-tag-prototype
+ color)))
+ (const (semantic-tag-get-attribute tag :constant-flag))
+ (tm (semantic-tag-get-attribute tag :typemodifiers))
+ (mods (append
+ (if const '("const") nil)
+ (cond ((stringp tm) (list tm))
+ ((consp tm) tm)
+ (t nil))
+ ))
+ (array (if (eq class 'variable)
+ (let ((deref
+ (semantic-tag-get-attribute
+ tag :dereference))
+ (r ""))
+ (while (and deref (/= deref 0))
+ (setq r (concat r "[]")
+ deref (1- deref)))
+ r)))
+ )
+ (if args
+ (setq args
+ (concat " "
+ (if (eq class 'type) "{" "(")
+ args
+ (if (eq class 'type) "}" ")"))))
+ (when mods
+ (setq mods (concat (mapconcat 'identity mods " ") " ")))
+ (concat (or mods "")
+ (if type (concat type " "))
+ name
+ (or args "")
+ (or array ""))))
+
+;;;###autoload
+(define-overloadable-function semantic-format-tag-concise-prototype (tag
&optional parent color)
+ "Return a concise prototype for TAG.
+Optional argument PARENT is the parent type if TAG is a detail.
+Optional argument COLOR means highlight the prototype with font-lock colors.")
+
+(defun semantic-format-tag-concise-prototype-default (tag &optional parent
color)
+ "Return a concise prototype for TAG.
+This default function will make a cheap concise prototype using C like syntax.
+Optional argument PARENT is the parent type if TAG is a detail.
+Optional argument COLOR means highlight the prototype with font-lock colors."
+ (let ((class (semantic-tag-class tag)))
+ (cond
+ ((eq class 'type)
+ (concat (semantic-format-tag-name tag parent color) "{}"))
+ ((eq class 'function)
+ (concat (semantic-format-tag-name tag parent color)
+ " ("
+ (semantic--format-tag-arguments
+ (semantic-tag-function-arguments tag)
+ 'semantic-format-tag-concise-prototype
+ color)
+ ")"))
+ ((eq class 'variable)
+ (let* ((deref (semantic-tag-get-attribute
+ tag :dereference))
+ (array "")
+ )
+ (while (and deref (/= deref 0))
+ (setq array (concat array "[]")
+ deref (1- deref)))
+ (concat (semantic-format-tag-name tag parent color)
+ array)))
+ (t
+ (semantic-format-tag-abbreviate tag parent color)))))
+
+;;; UML display styles
+;;
+(defcustom semantic-uml-colon-string " : "
+ "*String used as a color separator between parts of a UML string.
+In UML, a variable may appear as `varname : type'.
+Change this variable to change the output separator."
+ :group 'semantic
+ :type 'string)
+
+(defcustom semantic-uml-no-protection-string ""
+ "*String used to describe when no protection is specified.
+Used by `semantic-format-tag-uml-protection-to-string'."
+ :group 'semantic
+ :type 'string)
+
+(defun semantic--format-uml-post-colorize (text tag parent)
+ "Add color to TEXT created from TAG and PARENT.
+Adds augmentation for `abstract' and `static' entries."
+ (if (semantic-tag-abstract-p tag parent)
+ (setq text (semantic--format-colorize-merge-text text 'abstract)))
+ (if (semantic-tag-static-p tag parent)
+ (setq text (semantic--format-colorize-merge-text text 'static)))
+ text
+ )
+
+(defun semantic-uml-attribute-string (tag &optional parent)
+ "Return a string for TAG, a child of PARENT representing a UML attribute.
+UML attribute strings are things like {abstract} or {leaf}."
+ (cond ((semantic-tag-abstract-p tag parent)
+ "{abstract}")
+ ((semantic-tag-leaf-p tag parent)
+ "{leaf}")
+ ))
+
+(defvar semantic-format-tag-protection-image-alist
+ '(("+" . ezimage-unlock)
+ ("#" . ezimage-key)
+ ("-" . ezimage-lock)
+ )
+ "Association of protection strings, and images to use.")
+
+(defvar semantic-format-tag-protection-symbol-to-string-assoc-list
+ '((public . "+")
+ (protected . "#")
+ (private . "-")
+ )
+ "Association list of the form (SYMBOL . \"STRING\") for protection symbols.
+This associates a symbol, such as 'public with the st ring \"+\".")
+
+(define-overloadable-function semantic-format-tag-uml-protection-to-string
(protection-symbol color)
+ "Convert PROTECTION-SYMBOL to a string for UML.
+By default, uses `semantic-format-tag-protection-symbol-to-string-assoc-list'
+to convert.
+By defaul character returns are:
+ public -- +
+ private -- -
+ protected -- #.
+If PROTECTION-SYMBOL is unknown, then the return value is
+`semantic-uml-no-protection-string'.
+COLOR indicates if we should use an image on the text.")
+
+(defun semantic-format-tag-uml-protection-to-string-default (protection-symbol
color)
+ "Convert PROTECTION-SYMBOL to a string for UML.
+Uses `semantic-format-tag-protection-symbol-to-string-assoc-list' to convert.
+If PROTECTION-SYMBOL is unknown, then the return value is
+`semantic-uml-no-protection-string'.
+COLOR indicates if we should use an image on the text."
+ (let* ((ezimage-use-images (and semantic-format-use-images-flag color))
+ (key (assoc protection-symbol
+
semantic-format-tag-protection-symbol-to-string-assoc-list))
+ (str (or (cdr-safe key) semantic-uml-no-protection-string)))
+ (ezimage-image-over-string
+ (copy-sequence str) ; make a copy to keep the original pristine.
+ semantic-format-tag-protection-image-alist)))
+
+(defsubst semantic-format-tag-uml-protection (tag parent color)
+ "Retrieve the protection string for TAG with PARENT.
+Argument COLOR specifies that color should be added to the string as
+needed."
+ (semantic-format-tag-uml-protection-to-string
+ (semantic-tag-protection tag parent)
+ color))
+
+(defun semantic--format-tag-uml-type (tag color)
+ "Format the data type of TAG to a string usable for formatting.
+COLOR indicates if it should be colorized."
+ (let ((str (semantic-format-tag-type tag color)))
+ (if str
+ (concat semantic-uml-colon-string str))))
+
+(define-overloadable-function semantic-format-tag-uml-abbreviate (tag
&optional parent color)
+ "Return a UML style abbreviation for TAG.
+Optional argument PARENT is the parent type if TAG is a detail.
+Optional argument COLOR means highlight the prototype with font-lock colors.")
+
+(defun semantic-format-tag-uml-abbreviate-default (tag &optional parent color)
+ "Return a UML style abbreviation for TAG.
+Optional argument PARENT is the parent type if TAG is a detail.
+Optional argument COLOR means highlight the prototype with font-lock colors."
+ (let* ((name (semantic-format-tag-name tag parent color))
+ (type (semantic--format-tag-uml-type tag color))
+ (protstr (semantic-format-tag-uml-protection tag parent color))
+ (text nil))
+ (setq text
+ (concat
+ protstr
+ (if type (concat name type)
+ name)))
+ (if color
+ (setq text (semantic--format-uml-post-colorize text tag parent)))
+ text))
+
+(define-overloadable-function semantic-format-tag-uml-prototype (tag &optional
parent color)
+ "Return a UML style prototype for TAG.
+Optional argument PARENT is the parent type if TAG is a detail.
+Optional argument COLOR means highlight the prototype with font-lock colors.")
+
+(defun semantic-format-tag-uml-prototype-default (tag &optional parent color)
+ "Return a UML style prototype for TAG.
+Optional argument PARENT is the parent type if TAG is a detail.
+Optional argument COLOR means highlight the prototype with font-lock colors."
+ (let* ((class (semantic-tag-class tag))
+ (cp (semantic-format-tag-name tag parent color))
+ (type (semantic--format-tag-uml-type tag color))
+ (prot (semantic-format-tag-uml-protection tag parent color))
+ (argtext
+ (cond ((eq class 'function)
+ (concat
+ " ("
+ (semantic--format-tag-arguments
+ (semantic-tag-function-arguments tag)
+ #'semantic-format-tag-uml-prototype
+ color)
+ ")"))
+ ((eq class 'type)
+ "{}")))
+ (text nil))
+ (setq text (concat prot cp argtext type))
+ (if color
+ (setq text (semantic--format-uml-post-colorize text tag parent)))
+ text
+ ))
+
+(define-overloadable-function semantic-format-tag-uml-concise-prototype (tag
&optional parent color)
+ "Return a UML style concise prototype for TAG.
+Optional argument PARENT is the parent type if TAG is a detail.
+Optional argument COLOR means highlight the prototype with font-lock colors.")
+
+(defun semantic-format-tag-uml-concise-prototype-default (tag &optional parent
color)
+ "Return a UML style concise prototype for TAG.
+Optional argument PARENT is the parent type if TAG is a detail.
+Optional argument COLOR means highlight the prototype with font-lock colors."
+ (let* ((cp (semantic-format-tag-concise-prototype tag parent color))
+ (type (semantic--format-tag-uml-type tag color))
+ (prot (semantic-format-tag-uml-protection tag parent color))
+ (text nil)
+ )
+ (setq text (concat prot cp type))
+ (if color
+ (setq text (semantic--format-uml-post-colorize text tag parent)))
+ text))
+
+(provide 'semantic/format)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/format"
+;; End:
+
+;;; semantic/format.el ends here
Index: cedet/semantic/fw.el
===================================================================
RCS file: cedet/semantic/fw.el
diff -N cedet/semantic/fw.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/fw.el 28 Sep 2009 15:15:08 -0000 1.2
@@ -0,0 +1,387 @@
+;;; semantic/fw.el --- Framework for Semantic
+
+;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+;;; 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Semantic has several core features shared across it's lex/parse/util
+;; stages. This used to clutter semantic.el some. These routines are all
+;; simple things that are not parser specific, but aid in making
+;; semantic flexible and compatible amongst different Emacs platforms.
+
+;;; Code:
+;;
+(require 'mode-local)
+(require 'eieio)
+(require 'semantic/loaddefs)
+
+;;; Compatibility
+
+(defalias 'semantic-buffer-local-value 'buffer-local-value)
+(defalias 'semantic-overlay-live-p 'overlay-buffer)
+(defalias 'semantic-make-overlay 'make-overlay)
+(defalias 'semantic-overlay-put 'overlay-put)
+(defalias 'semantic-overlay-get 'overlay-get)
+(defalias 'semantic-overlay-properties 'overlay-properties)
+(defalias 'semantic-overlay-move 'move-overlay)
+(defalias 'semantic-overlay-delete 'delete-overlay)
+(defalias 'semantic-overlays-at 'overlays-at)
+(defalias 'semantic-overlays-in 'overlays-in)
+(defalias 'semantic-overlay-buffer 'overlay-buffer)
+(defalias 'semantic-overlay-start 'overlay-start)
+(defalias 'semantic-overlay-end 'overlay-end)
+(defalias 'semantic-overlay-size 'overlay-size)
+(defalias 'semantic-overlay-next-change 'next-overlay-change)
+(defalias 'semantic-overlay-previous-change 'previous-overlay-change)
+(defalias 'semantic-overlay-lists 'overlay-lists)
+(defalias 'semantic-overlay-p 'overlayp)
+(defalias 'semantic-read-event 'read-event)
+(defalias 'semantic-popup-menu 'popup-menu)
+(defalias 'semantic-make-local-hook 'identity)
+(defalias 'semantic-mode-line-update 'force-mode-line-update)
+(defalias 'semantic-run-mode-hooks 'run-mode-hooks)
+(defalias 'semantic-compile-warn 'byte-compile-warn)
+(defalias 'semantic-menu-item 'identity)
+
+(defun semantic-event-window (event)
+ "Extract the window from EVENT."
+ (car (car (cdr event))))
+
+(defun semantic-delete-overlay-maybe (overlay)
+ "Delete OVERLAY if it is a semantic token overlay."
+ (if (semantic-overlay-get overlay 'semantic)
+ (semantic-overlay-delete overlay)))
+
+;;; Positional Data Cache
+;;
+(defvar semantic-cache-data-overlays nil
+ "List of all overlays waiting to be flushed.")
+
+(defun semantic-cache-data-to-buffer (buffer start end value name &optional
lifespan)
+ "In BUFFER over the region START END, remember VALUE.
+NAME specifies a special name that can be searched for later to
+recover the cached data with `semantic-get-cache-data'.
+LIFESPAN indicates how long the data cache will be remembered.
+The default LIFESPAN is 'end-of-command.
+Possible Lifespans are:
+ 'end-of-command - Remove the cache at the end of the currently
+ executing command.
+ 'exit-cache-zone - Remove when point leaves the overlay at the
+ end of the currently executing command."
+ ;; Check if LIFESPAN is valid before to create any overlay
+ (or lifespan (setq lifespan 'end-of-command))
+ (or (memq lifespan '(end-of-command exit-cache-zone))
+ (error "semantic-cache-data-to-buffer: Unknown LIFESPAN: %s"
+ lifespan))
+ (let ((o (semantic-make-overlay start end buffer)))
+ (semantic-overlay-put o 'cache-name name)
+ (semantic-overlay-put o 'cached-value value)
+ (semantic-overlay-put o 'lifespan lifespan)
+ (setq semantic-cache-data-overlays
+ (cons o semantic-cache-data-overlays))
+ ;;(message "Adding to cache: %s" o)
+ (add-hook 'post-command-hook 'semantic-cache-data-post-command-hook)
+ ))
+
+(defun semantic-cache-data-post-command-hook ()
+ "Flush `semantic-cache-data-overlays' based 'lifespan property.
+Remove self from `post-command-hook' if it is empty."
+ (let ((newcache nil)
+ (oldcache semantic-cache-data-overlays))
+ (while oldcache
+ (let* ((o (car oldcache))
+ (life (semantic-overlay-get o 'lifespan))
+ )
+ (if (or (eq life 'end-of-command)
+ (and (eq life 'exit-cache-zone)
+ (not (member o (semantic-overlays-at (point))))))
+ (progn
+ ;;(message "Removing from cache: %s" o)
+ (semantic-overlay-delete o)
+ )
+ (setq newcache (cons o newcache))))
+ (setq oldcache (cdr oldcache)))
+ (setq semantic-cache-data-overlays (nreverse newcache)))
+
+ ;; Remove ourselves if we have removed all overlays.
+ (unless semantic-cache-data-overlays
+ (remove-hook 'post-command-hook
+ 'semantic-cache-data-post-command-hook)))
+
+(defun semantic-get-cache-data (name &optional point)
+ "Get cached data with NAME from optional POINT."
+ (save-excursion
+ (if point (goto-char point))
+ (let ((o (semantic-overlays-at (point)))
+ (ans nil))
+ (while (and (not ans) o)
+ (if (equal (semantic-overlay-get (car o) 'cache-name) name)
+ (setq ans (car o))
+ (setq o (cdr o))))
+ (when ans
+ (semantic-overlay-get ans 'cached-value)))))
+
+;;; Obsoleting various functions & variables
+;;
+(defun semantic-overload-symbol-from-function (name)
+ "Return the symbol for overload used by NAME, the defined symbol."
+ (let ((sym-name (symbol-name name)))
+ (if (string-match "^semantic-" sym-name)
+ (intern (substring sym-name (match-end 0)))
+ name)))
+
+(defun semantic-alias-obsolete (oldfnalias newfn)
+ "Make OLDFNALIAS an alias for NEWFN.
+Mark OLDFNALIAS as obsolete, such that the byte compiler
+will throw a warning when it encounters this symbol."
+ (defalias oldfnalias newfn)
+ (make-obsolete oldfnalias newfn)
+ (when (and (function-overload-p newfn)
+ (not (overload-obsoleted-by newfn))
+ ;; Only throw this warning when byte compiling things.
+ (boundp 'byte-compile-current-file)
+ byte-compile-current-file
+ (not (string-match "cedet" byte-compile-current-file))
+ )
+ (make-obsolete-overload oldfnalias newfn)
+ (semantic-compile-warn
+ "%s: `%s' obsoletes overload `%s'"
+ byte-compile-current-file
+ newfn
+ (semantic-overload-symbol-from-function oldfnalias))
+ ))
+
+(defun semantic-varalias-obsolete (oldvaralias newvar)
+ "Make OLDVARALIAS an alias for variable NEWVAR.
+Mark OLDVARALIAS as obsolete, such that the byte compiler
+will throw a warning when it encounters this symbol."
+ (make-obsolete-variable oldvaralias newvar)
+ (condition-case nil
+ (defvaralias oldvaralias newvar)
+ (error
+ ;; Only throw this warning when byte compiling things.
+ (when (and (boundp 'byte-compile-current-file)
+ byte-compile-current-file)
+ (semantic-compile-warn
+ "variable `%s' obsoletes, but isn't alias of `%s'"
+ newvar oldvaralias)
+ ))))
+
+;;; Help debugging
+;;
+(defmacro semantic-safe (format &rest body)
+ "Turn into a FORMAT message any error caught during eval of BODY.
+Return the value of last BODY form or nil if an error occurred.
+FORMAT can have a %s escape which will be replaced with the actual
+error message.
+If `debug-on-error' is set, errors are not caught, so that you can
+debug them.
+Avoid using a large BODY since it is duplicated."
+ ;;(declare (debug t) (indent 1))
+ `(if debug-on-error
+ ;;(let ((inhibit-quit nil)) ,@body)
+ ;; Note to self: Doing the above screws up the wisent parser.
+ (progn ,@body)
+ (condition-case err
+ (progn ,@body)
+ (error
+ (message ,format (format "%S - %s" (current-buffer)
+ (error-message-string err)))
+ nil))))
+(put 'semantic-safe 'lisp-indent-function 1)
+
+;;; Misc utilities
+;;
+(defsubst semantic-map-buffers (function)
+ "Run FUNCTION for each Semantic enabled buffer found.
+FUNCTION does not have arguments. When FUNCTION is entered
+`current-buffer' is a selected Semantic enabled buffer."
+ (mode-local-map-file-buffers function #'semantic-active-p))
+
+(defalias 'semantic-map-mode-buffers 'mode-local-map-mode-buffers)
+
+(semantic-alias-obsolete 'define-mode-overload-implementation
+ 'define-mode-local-override)
+
+(defun semantic-install-function-overrides (overrides &optional transient mode)
+ "Install the function OVERRIDES in the specified environment.
+OVERRIDES must be an alist ((OVERLOAD . FUNCTION) ...) where OVERLOAD
+is a symbol identifying an overloadable entry, and FUNCTION is the
+function to override it with.
+If optional argument TRANSIENT is non-nil, installed overrides can in
+turn be overridden by next installation.
+If optional argument MODE is non-nil, it must be a major mode symbol.
+OVERRIDES will be installed globally for this major mode. If MODE is
+nil, OVERRIDES will be installed locally in the current buffer. This
+later installation should be done in MODE hook."
+ (mode-local-bind
+ ;; Add the semantic- prefix to OVERLOAD short names.
+ (mapcar
+ #'(lambda (e)
+ (let ((name (symbol-name (car e))))
+ (if (string-match "^semantic-" name)
+ e
+ (cons (intern (format "semantic-%s" name)) (cdr e)))))
+ overrides)
+ (list 'constant-flag (not transient)
+ 'override-flag t)
+ mode))
+
+;;; User Interrupt handling
+;;
+(defvar semantic-current-input-throw-symbol nil
+ "The current throw symbol for `semantic-exit-on-input'.")
+
+(defmacro semantic-exit-on-input (symbol &rest forms)
+ "Using SYMBOL as an argument to `throw', execute FORMS.
+If FORMS includes a call to `semantic-thow-on-input', then
+if a user presses any key during execution, this form macro
+will exit with the value passed to `semantic-throw-on-input'.
+If FORMS completes, then the return value is the same as `progn'."
+ `(let ((semantic-current-input-throw-symbol ,symbol))
+ (catch ,symbol
+ ,@forms)))
+(put 'semantic-exit-on-input 'lisp-indent-function 1)
+
+(defmacro semantic-throw-on-input (from)
+ "Exit with `throw' when in `semantic-exit-on-input' on user input.
+FROM is an indication of where this function is called from as a value
+to pass to `throw'. It is recommended to use the name of the function
+calling this one."
+ `(when (and semantic-current-input-throw-symbol
+ (or (input-pending-p) (accept-process-output)))
+ (throw semantic-current-input-throw-symbol ,from)))
+
+
+;;; Special versions of Find File
+;;
+(defun semantic-find-file-noselect (file &optional nowarn rawfile wildcards)
+ "Call `find-file-noselect' with various features turned off.
+Use this when referencing a file that will be soon deleted.
+FILE, NOWARN, RAWFILE, and WILDCARDS are passed into `find-file-noselect'"
+ (let* ((recentf-exclude '( (lambda (f) t) ))
+ ;; This is a brave statement. Don't waste time loading in
+ ;; lots of modes. Especially decoration mode can waste a lot
+ ;; of time for a buffer we intend to kill.
+ (semantic-init-hook nil)
+ ;; This disables the part of EDE that asks questions
+ (ede-auto-add-method 'never)
+ ;; Ask font-lock to not colorize these buffers, nor to
+ ;; whine about it either.
+ (font-lock-maximum-size 0)
+ (font-lock-verbose nil)
+ ;; Disable revision control
+ (vc-handled-backends nil)
+ ;; Don't prompt to insert a template if we visit an empty file
+ (auto-insert nil)
+ ;; We don't want emacs to query about unsafe local variables
+ (enable-local-variables
+ (if (featurep 'xemacs)
+ ;; XEmacs only has nil as an option?
+ nil
+ ;; Emacs 23 has the spiffy :safe option, nil otherwise.
+ (if (>= emacs-major-version 22)
+ nil
+ :safe)))
+ ;; ... or eval variables
+ (enable-local-eval nil)
+ )
+ (save-match-data
+ (if (featurep 'xemacs)
+ (find-file-noselect file nowarn rawfile)
+ (find-file-noselect file nowarn rawfile wildcards)))
+ ))
+
+
+;; ;;; Editor goodies ;-)
+;; ;;
+;; (defconst semantic-fw-font-lock-keywords
+;; (eval-when-compile
+;; (let* (
+;; ;; Variable declarations
+;; (vl nil)
+;; (kv (if vl (regexp-opt vl t) ""))
+;; ;; Function declarations
+;; (vf '(
+;; "define-lex"
+;; "define-lex-analyzer"
+;; "define-lex-block-analyzer"
+;; "define-lex-regex-analyzer"
+;; "define-lex-spp-macro-declaration-analyzer"
+;; "define-lex-spp-macro-undeclaration-analyzer"
+;; "define-lex-spp-include-analyzer"
+;; "define-lex-simple-regex-analyzer"
+;; "define-lex-keyword-type-analyzer"
+;; "define-lex-sexp-type-analyzer"
+;; "define-lex-regex-type-analyzer"
+;; "define-lex-string-type-analyzer"
+;; "define-lex-block-type-analyzer"
+;; ;;"define-mode-overload-implementation"
+;; ;;"define-semantic-child-mode"
+;; "define-semantic-idle-service"
+;; "define-semantic-decoration-style"
+;; "define-wisent-lexer"
+;; "semantic-alias-obsolete"
+;; "semantic-varalias-obsolete"
+;; "semantic-make-obsolete-overload"
+;; "defcustom-mode-local-semantic-dependency-system-include-path"
+;; ))
+;; (kf (if vf (regexp-opt vf t) ""))
+;; ;; Regexp depths
+;; (kv-depth (if kv (regexp-opt-depth kv) nil))
+;; (kf-depth (if kf (regexp-opt-depth kf) nil))
+;; )
+;; `((,(concat
+;; ;; Declarative things
+;; "(\\(" kv "\\|" kf "\\)"
+;; ;; Whitespaces & names
+;; "\\>[ \t]*\\(\\sw+\\)?[ \t]*\\(\\sw+\\)?"
+;; )
+;; (1 font-lock-keyword-face)
+;; (,(+ 1 kv-depth kf-depth 1)
+;; (cond ((match-beginning 2)
+;; font-lock-type-face)
+;; ((match-beginning ,(+ 1 kv-depth 1))
+;; font-lock-function-name-face)
+;; )
+;; nil t)
+;; (,(+ 1 kv-depth kf-depth 1 1)
+;; (cond ((match-beginning 2)
+;; font-lock-variable-name-face)
+;; )
+;; nil t)))
+;; ))
+;; "Highlighted Semantic keywords.")
+
+;; (when (fboundp 'font-lock-add-keywords)
+;; (font-lock-add-keywords 'emacs-lisp-mode
+;; semantic-fw-font-lock-keywords))
+
+;;; Interfacing with edebug
+;;
+(defun semantic-fw-add-edebug-spec ()
+ (def-edebug-spec semantic-exit-on-input 'def-body))
+
+(add-hook 'edebug-setup-hook 'semantic-fw-add-edebug-spec)
+
+(provide 'semantic/fw)
+
+;;; semantic/fw.el ends here
Index: cedet/semantic/grammar-wy.el
===================================================================
RCS file: cedet/semantic/grammar-wy.el
diff -N cedet/semantic/grammar-wy.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/grammar-wy.el 28 Sep 2009 15:15:08 -0000 1.2
@@ -0,0 +1,478 @@
+;;; semantic/grammar-wy.el --- Generated parser support file
+
+;; Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
+
+;; Author: David Ponce <address@hidden>
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; This file is generated from the grammar file semantic-grammar.wy in
+;; the upstream CEDET repository.
+
+;;; Code:
+
+(require 'semantic/lex)
+(defvar semantic-grammar-lex-c-char-re)
+
+;; Current parsed nonterminal name.
+(defvar semantic-grammar-wy--nterm nil)
+;; Index of rule in a nonterminal clause.
+(defvar semantic-grammar-wy--rindx nil)
+
+;;; Declarations
+;;
+(defconst semantic-grammar-wy--keyword-table
+ (semantic-lex-make-keyword-table
+ '(("%default-prec" . DEFAULT-PREC)
+ ("%no-default-prec" . NO-DEFAULT-PREC)
+ ("%keyword" . KEYWORD)
+ ("%languagemode" . LANGUAGEMODE)
+ ("%left" . LEFT)
+ ("%nonassoc" . NONASSOC)
+ ("%package" . PACKAGE)
+ ("%prec" . PREC)
+ ("%put" . PUT)
+ ("%quotemode" . QUOTEMODE)
+ ("%right" . RIGHT)
+ ("%scopestart" . SCOPESTART)
+ ("%start" . START)
+ ("%token" . TOKEN)
+ ("%type" . TYPE)
+ ("%use-macros" . USE-MACROS))
+ 'nil)
+ "Table of language keywords.")
+
+(defconst semantic-grammar-wy--token-table
+ (semantic-lex-make-type-table
+ '(("punctuation"
+ (GT . ">")
+ (LT . "<")
+ (OR . "|")
+ (SEMI . ";")
+ (COLON . ":"))
+ ("close-paren"
+ (RBRACE . "}")
+ (RPAREN . ")"))
+ ("open-paren"
+ (LBRACE . "{")
+ (LPAREN . "("))
+ ("block"
+ (BRACE_BLOCK . "(LBRACE RBRACE)")
+ (PAREN_BLOCK . "(LPAREN RPAREN)"))
+ ("code"
+ (EPILOGUE . "%%...EOF")
+ (PROLOGUE . "%{...%}"))
+ ("sexp"
+ (SEXP))
+ ("qlist"
+ (PREFIXED_LIST))
+ ("char"
+ (CHARACTER))
+ ("symbol"
+ (PERCENT_PERCENT . "\\`%%\\'")
+ (SYMBOL))
+ ("string"
+ (STRING)))
+ '(("punctuation" :declared t)
+ ("block" :declared t)
+ ("sexp" matchdatatype sexp)
+ ("sexp" syntax "\\=")
+ ("sexp" :declared t)
+ ("qlist" matchdatatype sexp)
+ ("qlist" syntax "\\s'\\s-*(")
+ ("qlist" :declared t)
+ ("char" syntax semantic-grammar-lex-c-char-re)
+ ("char" :declared t)
+ ("symbol" syntax ":?\\(\\sw\\|\\s_\\)+")
+ ("symbol" :declared t)
+ ("string" :declared t)
+ ("keyword" :declared t)))
+ "Table of lexical tokens.")
+
+(defconst semantic-grammar-wy--parse-table
+ (progn
+ (eval-when-compile
+ (require 'semantic/wisent/comp))
+ (wisent-compile-grammar
+ '((DEFAULT-PREC NO-DEFAULT-PREC KEYWORD LANGUAGEMODE LEFT NONASSOC
PACKAGE PREC PUT QUOTEMODE RIGHT SCOPESTART START TOKEN TYPE USE-MACROS STRING
SYMBOL PERCENT_PERCENT CHARACTER PREFIXED_LIST SEXP PROLOGUE EPILOGUE
PAREN_BLOCK BRACE_BLOCK LPAREN RPAREN LBRACE RBRACE COLON SEMI OR LT GT)
+ nil
+ (grammar
+ ((prologue))
+ ((epilogue))
+ ((declaration))
+ ((nonterminal))
+ ((PERCENT_PERCENT)))
+ (prologue
+ ((PROLOGUE)
+ (wisent-raw-tag
+ (semantic-tag-new-code "prologue" nil))))
+ (epilogue
+ ((EPILOGUE)
+ (wisent-raw-tag
+ (semantic-tag-new-code "epilogue" nil))))
+ (declaration
+ ((decl)
+ (eval $1)))
+ (decl
+ ((default_prec_decl))
+ ((no_default_prec_decl))
+ ((languagemode_decl))
+ ((package_decl))
+ ((precedence_decl))
+ ((put_decl))
+ ((quotemode_decl))
+ ((scopestart_decl))
+ ((start_decl))
+ ((keyword_decl))
+ ((token_decl))
+ ((type_decl))
+ ((use_macros_decl)))
+ (default_prec_decl
+ ((DEFAULT-PREC)
+ `(wisent-raw-tag
+ (semantic-tag "default-prec" 'assoc :value
+ '("t")))))
+ (no_default_prec_decl
+ ((NO-DEFAULT-PREC)
+ `(wisent-raw-tag
+ (semantic-tag "default-prec" 'assoc :value
+ '("nil")))))
+ (languagemode_decl
+ ((LANGUAGEMODE symbols)
+ `(wisent-raw-tag
+ (semantic-tag ',(car $2)
+ 'languagemode :rest ',(cdr $2)))))
+ (package_decl
+ ((PACKAGE SYMBOL)
+ `(wisent-raw-tag
+ (semantic-tag-new-package ',$2 nil))))
+ (precedence_decl
+ ((associativity token_type_opt items)
+ `(wisent-raw-tag
+ (semantic-tag ',$1 'assoc :type ',$2 :value ',$3))))
+ (associativity
+ ((LEFT)
+ (progn "left"))
+ ((RIGHT)
+ (progn "right"))
+ ((NONASSOC)
+ (progn "nonassoc")))
+ (put_decl
+ ((PUT put_name put_value)
+ `(wisent-raw-tag
+ (semantic-tag ',$2 'put :value ',(list $3))))
+ ((PUT put_name put_value_list)
+ `(wisent-raw-tag
+ (semantic-tag ',$2 'put :value ',$3)))
+ ((PUT put_name_list put_value)
+ `(wisent-raw-tag
+ (semantic-tag ',(car $2)
+ 'put :rest ',(cdr $2)
+ :value ',(list $3))))
+ ((PUT put_name_list put_value_list)
+ `(wisent-raw-tag
+ (semantic-tag ',(car $2)
+ 'put :rest ',(cdr $2)
+ :value ',$3))))
+ (put_name_list
+ ((BRACE_BLOCK)
+ (mapcar 'semantic-tag-name
+ (semantic-parse-region
+ (car $region1)
+ (cdr $region1)
+ 'put_names 1))))
+ (put_names
+ ((LBRACE)
+ nil)
+ ((RBRACE)
+ nil)
+ ((put_name)
+ (wisent-raw-tag
+ (semantic-tag $1 'put-name))))
+ (put_name
+ ((SYMBOL))
+ ((token_type)))
+ (put_value_list
+ ((BRACE_BLOCK)
+ (mapcar 'semantic-tag-code-detail
+ (semantic-parse-region
+ (car $region1)
+ (cdr $region1)
+ 'put_values 1))))
+ (put_values
+ ((LBRACE)
+ nil)
+ ((RBRACE)
+ nil)
+ ((put_value)
+ (wisent-raw-tag
+ (semantic-tag-new-code "put-value" $1))))
+ (put_value
+ ((SYMBOL any_value)
+ (cons $1 $2)))
+ (scopestart_decl
+ ((SCOPESTART SYMBOL)
+ `(wisent-raw-tag
+ (semantic-tag ',$2 'scopestart))))
+ (quotemode_decl
+ ((QUOTEMODE SYMBOL)
+ `(wisent-raw-tag
+ (semantic-tag ',$2 'quotemode))))
+ (start_decl
+ ((START symbols)
+ `(wisent-raw-tag
+ (semantic-tag ',(car $2)
+ 'start :rest ',(cdr $2)))))
+ (keyword_decl
+ ((KEYWORD SYMBOL string_value)
+ `(wisent-raw-tag
+ (semantic-tag ',$2 'keyword :value ',$3))))
+ (token_decl
+ ((TOKEN token_type_opt SYMBOL string_value)
+ `(wisent-raw-tag
+ (semantic-tag ',$3 ',(if $2 'token 'keyword)
+ :type ',$2 :value ',$4)))
+ ((TOKEN token_type_opt symbols)
+ `(wisent-raw-tag
+ (semantic-tag ',(car $3)
+ 'token :type ',$2 :rest ',(cdr $3)))))
+ (token_type_opt
+ (nil)
+ ((token_type)))
+ (token_type
+ ((LT SYMBOL GT)
+ (progn $2)))
+ (type_decl
+ ((TYPE token_type plist_opt)
+ `(wisent-raw-tag
+ (semantic-tag ',$2 'type :value ',$3))))
+ (plist_opt
+ (nil)
+ ((plist)))
+ (plist
+ ((plist put_value)
+ (append
+ (list $2)
+ $1))
+ ((put_value)
+ (list $1)))
+ (use_name_list
+ ((BRACE_BLOCK)
+ (mapcar 'semantic-tag-name
+ (semantic-parse-region
+ (car $region1)
+ (cdr $region1)
+ 'use_names 1))))
+ (use_names
+ ((LBRACE)
+ nil)
+ ((RBRACE)
+ nil)
+ ((SYMBOL)
+ (wisent-raw-tag
+ (semantic-tag $1 'use-name))))
+ (use_macros_decl
+ ((USE-MACROS SYMBOL use_name_list)
+ `(wisent-raw-tag
+ (semantic-tag "macro" 'macro :type ',$2 :value ',$3))))
+ (string_value
+ ((STRING)
+ (read $1)))
+ (any_value
+ ((SYMBOL))
+ ((STRING))
+ ((PAREN_BLOCK))
+ ((PREFIXED_LIST))
+ ((SEXP)))
+ (symbols
+ ((lifo_symbols)
+ (nreverse $1)))
+ (lifo_symbols
+ ((lifo_symbols SYMBOL)
+ (cons $2 $1))
+ ((SYMBOL)
+ (list $1)))
+ (nonterminal
+ ((SYMBOL
+ (setq semantic-grammar-wy--nterm $1 semantic-grammar-wy--rindx 0)
+ COLON rules SEMI)
+ (wisent-raw-tag
+ (semantic-tag $1 'nonterminal :children $4))))
+ (rules
+ ((lifo_rules)
+ (apply 'nconc
+ (nreverse $1))))
+ (lifo_rules
+ ((lifo_rules OR rule)
+ (cons $3 $1))
+ ((rule)
+ (list $1)))
+ (rule
+ ((rhs)
+ (let*
+ ((nterm semantic-grammar-wy--nterm)
+ (rindx semantic-grammar-wy--rindx)
+ (rhs $1)
+ comps prec action elt)
+ (setq semantic-grammar-wy--rindx
+ (1+ semantic-grammar-wy--rindx))
+ (while rhs
+ (setq elt
+ (car rhs)
+ rhs
+ (cdr rhs))
+ (cond
+ ((vectorp elt)
+ (if prec
+ (error "duplicate %%prec in `%s:%d' rule" nterm rindx))
+ (setq prec
+ (aref elt 0)))
+ ((consp elt)
+ (if
+ (or action comps)
+ (setq comps
+ (cons elt comps)
+ semantic-grammar-wy--rindx
+ (1+ semantic-grammar-wy--rindx))
+ (setq action
+ (car elt))))
+ (t
+ (setq comps
+ (cons elt comps)))))
+ (wisent-cook-tag
+ (wisent-raw-tag
+ (semantic-tag
+ (format "%s:%d" nterm rindx)
+ 'rule :type
+ (if comps "group" "empty")
+ :value comps :prec prec :expr action))))))
+ (rhs
+ (nil)
+ ((rhs item)
+ (cons $2 $1))
+ ((rhs action)
+ (cons
+ (list $2)
+ $1))
+ ((rhs PREC item)
+ (cons
+ (vector $3)
+ $1)))
+ (action
+ ((PAREN_BLOCK))
+ ((PREFIXED_LIST))
+ ((BRACE_BLOCK)
+ (format "(progn\n%s)"
+ (let
+ ((s $1))
+ (if
+ (string-match "^{[
\n ]*" s)
+ (setq s
+ (substring s
+ (match-end 0))))
+ (if
+ (string-match "[
\n ]*}$" s)
+ (setq s
+ (substring s 0
+ (match-beginning 0))))
+ s))))
+ (items
+ ((lifo_items)
+ (nreverse $1)))
+ (lifo_items
+ ((lifo_items item)
+ (cons $2 $1))
+ ((item)
+ (list $1)))
+ (item
+ ((SYMBOL))
+ ((CHARACTER))))
+ '(grammar prologue epilogue declaration nonterminal rule put_names
put_values use_names)))
+ "Parser table.")
+
+(defun semantic-grammar-wy--install-parser ()
+ "Setup the Semantic Parser."
+ (semantic-install-function-overrides
+ '((parse-stream . wisent-parse-stream)))
+ (setq semantic-parser-name "LALR"
+ semantic--parse-table semantic-grammar-wy--parse-table
+ semantic-debug-parser-source "semantic-grammar.wy"
+ semantic-flex-keywords-obarray semantic-grammar-wy--keyword-table
+ semantic-lex-types-obarray semantic-grammar-wy--token-table)
+ ;; Collect unmatched syntax lexical tokens
+ (semantic-make-local-hook 'wisent-discarding-token-functions)
+ (add-hook 'wisent-discarding-token-functions
+ 'wisent-collect-unmatched-syntax nil t))
+
+
+;;; Analyzers
+
+(define-lex-sexp-type-analyzer semantic-grammar-wy--<sexp>-sexp-analyzer
+ "sexp analyzer for <sexp> tokens."
+ "\\="
+ 'SEXP)
+
+(define-lex-sexp-type-analyzer semantic-grammar-wy--<qlist>-sexp-analyzer
+ "sexp analyzer for <qlist> tokens."
+ "\\s'\\s-*("
+ 'PREFIXED_LIST)
+
+(define-lex-keyword-type-analyzer
semantic-grammar-wy--<keyword>-keyword-analyzer
+ "keyword analyzer for <keyword> tokens."
+ "\\(\\sw\\|\\s_\\)+")
+
+(define-lex-block-type-analyzer semantic-grammar-wy--<block>-block-analyzer
+ "block analyzer for <block> tokens."
+ "\\s(\\|\\s)"
+ '((("(" LPAREN PAREN_BLOCK)
+ ("{" LBRACE BRACE_BLOCK))
+ (")" RPAREN)
+ ("}" RBRACE))
+ )
+
+(define-lex-regex-type-analyzer semantic-grammar-wy--<char>-regexp-analyzer
+ "regexp analyzer for <char> tokens."
+ semantic-grammar-lex-c-char-re
+ nil
+ 'CHARACTER)
+
+(define-lex-sexp-type-analyzer semantic-grammar-wy--<string>-sexp-analyzer
+ "sexp analyzer for <string> tokens."
+ "\\s\""
+ 'STRING)
+
+(define-lex-regex-type-analyzer semantic-grammar-wy--<symbol>-regexp-analyzer
+ "regexp analyzer for <symbol> tokens."
+ ":?\\(\\sw\\|\\s_\\)+"
+ '((PERCENT_PERCENT . "\\`%%\\'"))
+ 'SYMBOL)
+
+(define-lex-string-type-analyzer
semantic-grammar-wy--<punctuation>-string-analyzer
+ "string analyzer for <punctuation> tokens."
+ "\\(\\s.\\|\\s$\\|\\s'\\)+"
+ '((GT . ">")
+ (LT . "<")
+ (OR . "|")
+ (SEMI . ";")
+ (COLON . ":"))
+ 'punctuation)
+
+(provide 'semantic/grammar-wy)
+
+;;; semantic/grammar-wy.el ends here
Index: cedet/semantic/grammar.el
===================================================================
RCS file: cedet/semantic/grammar.el
diff -N cedet/semantic/grammar.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/grammar.el 28 Sep 2009 15:15:08 -0000 1.2
@@ -0,0 +1,1897 @@
+;;; semantic/grammar.el --- Major mode framework for Semantic grammars
+
+;;; Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: David Ponce <address@hidden>
+;; Maintainer: David Ponce <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Major mode framework for editing Semantic's input grammar files.
+
+;;; History:
+;;
+
+;;; Code:
+
+(require 'semantic)
+(require 'semantic/ctxt)
+(require 'semantic/format)
+(require 'semantic/grammar-wy)
+(require 'semantic/idle)
+(declare-function semantic-momentary-highlight-tag "semantic/decorate")
+(declare-function semantic-analyze-context "semantic/analyze")
+(declare-function semantic-analyze-tags-of-class-list
+ "semantic/analyze/complete")
+
+(eval-when-compile
+ (require 'eldoc)
+ (require 'semantic/edit)
+ (require 'semantic/find))
+
+
+;;;;
+;;;; Set up lexer
+;;;;
+
+(defconst semantic-grammar-lex-c-char-re "'\\s\\?.'"
+ "Regexp matching C-like character literals.")
+
+;; Most of the analyzers are auto-generated from the grammar, but the
+;; following which need special handling code.
+;;
+(define-lex-regex-analyzer semantic-grammar-lex-prologue
+ "Detect and create a prologue token."
+ "\\<%{"
+ ;; Zing to the end of this brace block.
+ (semantic-lex-push-token
+ (semantic-lex-token
+ 'PROLOGUE (point)
+ (save-excursion
+ (semantic-lex-unterminated-syntax-protection 'PROLOGUE
+ (forward-char)
+ (forward-sexp 1)
+ (point))))))
+
+(defsubst semantic-grammar-epilogue-start ()
+ "Return the start position of the grammar epilogue."
+ (save-excursion
+ (goto-char (point-min))
+ (if (re-search-forward "^\\s-*\\<%%\\>\\s-*$" nil t 2)
+ (match-beginning 0)
+ (1+ (point-max)))))
+
+(define-lex-regex-analyzer semantic-grammar-lex-epilogue
+ "Detect and create an epilogue or percent-percent token."
+ "\\<%%\\>"
+ (let ((start (match-beginning 0))
+ (end (match-end 0))
+ (class 'PERCENT_PERCENT))
+ (when (>= start (semantic-grammar-epilogue-start))
+ (setq class 'EPILOGUE
+ end (point-max)))
+ (semantic-lex-push-token
+ (semantic-lex-token class start end))))
+
+(define-lex semantic-grammar-lexer
+ "Lexical analyzer that handles Semantic grammar buffers.
+It ignores whitespaces, newlines and comments."
+ semantic-lex-ignore-newline
+ semantic-lex-ignore-whitespace
+ ;; Must detect prologue/epilogue before other symbols/keywords!
+ semantic-grammar-lex-prologue
+ semantic-grammar-lex-epilogue
+ semantic-grammar-wy--<keyword>-keyword-analyzer
+ semantic-grammar-wy--<symbol>-regexp-analyzer
+ semantic-grammar-wy--<char>-regexp-analyzer
+ semantic-grammar-wy--<string>-sexp-analyzer
+ ;; Must detect comments after strings because `comment-start-skip'
+ ;; regexp match semicolons inside strings!
+ semantic-lex-ignore-comments
+ ;; Must detect prefixed list before punctuation because prefix chars
+ ;; are also punctuations!
+ semantic-grammar-wy--<qlist>-sexp-analyzer
+ ;; Must detect punctuations after comments because the semicolon can
+ ;; be a punctuation or a comment start!
+ semantic-grammar-wy--<punctuation>-string-analyzer
+ semantic-grammar-wy--<block>-block-analyzer
+ semantic-grammar-wy--<sexp>-sexp-analyzer)
+
+;;; Test the lexer
+;;
+(defun semantic-grammar-lex-buffer ()
+ "Run `semantic-grammar-lex' on current buffer."
+ (interactive)
+ (semantic-lex-init)
+ (setq semantic-lex-analyzer 'semantic-grammar-lexer)
+ (let ((token-stream
+ (semantic-lex (point-min) (point-max))))
+ (with-current-buffer (get-buffer-create "*semantic-grammar-lex*")
+ (erase-buffer)
+ (pp token-stream (current-buffer))
+ (goto-char (point-min))
+ (pop-to-buffer (current-buffer)))))
+
+;;;;
+;;;; Semantic action expansion
+;;;;
+
+(defun semantic-grammar-ASSOC (&rest args)
+ "Return expansion of built-in ASSOC expression.
+ARGS are ASSOC's key value list."
+ (let ((key t))
+ `(semantic-tag-make-assoc-list
+ ,@(mapcar #'(lambda (i)
+ (prog1
+ (if key
+ (list 'quote i)
+ i)
+ (setq key (not key))))
+ args))))
+
+(defsubst semantic-grammar-quote-p (sym)
+ "Return non-nil if SYM is bound to the `quote' function."
+ (condition-case nil
+ (eq (indirect-function sym)
+ (indirect-function 'quote))
+ (error nil)))
+
+(defsubst semantic-grammar-backquote-p (sym)
+ "Return non-nil if SYM is bound to the `backquote' function."
+ (condition-case nil
+ (eq (indirect-function sym)
+ (indirect-function 'backquote))
+ (error nil)))
+
+;;;;
+;;;; API to access grammar tags
+;;;;
+
+(define-mode-local-override semantic-tag-components
+ semantic-grammar-mode (tag)
+ "Return the children of tag TAG."
+ (semantic-tag-get-attribute tag :children))
+
+(defun semantic-grammar-first-tag-name (class)
+ "Return the name of the first tag of class CLASS found.
+Warn if other tags of class CLASS exist."
+ (let* ((tags (semantic-find-tags-by-class
+ class (current-buffer))))
+ (if tags
+ (prog1
+ (semantic-tag-name (car tags))
+ (if (cdr tags)
+ (message "*** Ignore all but first declared %s"
+ class))))))
+
+(defun semantic-grammar-tag-symbols (class)
+ "Return the list of symbols defined in tags of class CLASS.
+That is tag names plus names defined in tag attribute `:rest'."
+ (let* ((tags (semantic-find-tags-by-class
+ class (current-buffer))))
+ (apply 'append
+ (mapcar
+ #'(lambda (tag)
+ (mapcar
+ 'intern
+ (cons (semantic-tag-name tag)
+ (semantic-tag-get-attribute tag :rest))))
+ tags))))
+
+(defsubst semantic-grammar-item-text (item)
+ "Return the readable string form of ITEM."
+ (if (string-match semantic-grammar-lex-c-char-re item)
+ (concat "?" (substring item 1 -1))
+ item))
+
+(defsubst semantic-grammar-item-value (item)
+ "Return symbol or character value of ITEM string."
+ (if (string-match semantic-grammar-lex-c-char-re item)
+ (let ((c (read (concat "?" (substring item 1 -1)))))
+ (if (featurep 'xemacs)
+ ;; Handle characters as integers in XEmacs like in GNU Emacs.
+ (char-int c)
+ c))
+ (intern item)))
+
+(defun semantic-grammar-prologue ()
+ "Return grammar prologue code as a string value."
+ (let ((tag (semantic-find-first-tag-by-name
+ "prologue"
+ (semantic-find-tags-by-class 'code (current-buffer)))))
+ (if tag
+ (save-excursion
+ (concat
+ (buffer-substring
+ (progn
+ (goto-char (semantic-tag-start tag))
+ (skip-chars-forward "%{\r\n\t ")
+ (point))
+ (progn
+ (goto-char (semantic-tag-end tag))
+ (skip-chars-backward "\r\n\t %}")
+ (point)))
+ "\n"))
+ "")))
+
+(defun semantic-grammar-epilogue ()
+ "Return grammar epilogue code as a string value."
+ (let ((tag (semantic-find-first-tag-by-name
+ "epilogue"
+ (semantic-find-tags-by-class 'code (current-buffer)))))
+ (if tag
+ (save-excursion
+ (concat
+ (buffer-substring
+ (progn
+ (goto-char (semantic-tag-start tag))
+ (skip-chars-forward "%\r\n\t ")
+ (point))
+ (progn
+ (goto-char (semantic-tag-end tag))
+ (skip-chars-backward "\r\n\t")
+ ;; If a grammar footer is found, skip it.
+ (re-search-backward "^;;;\\s-+\\S-+\\s-+ends here"
+ (save-excursion
+ (beginning-of-line)
+ (point))
+ t)
+ (skip-chars-backward "\r\n\t")
+ (point)))
+ "\n"))
+ "")))
+
+(defsubst semantic-grammar-buffer-file (&optional buffer)
+ "Return name of file sans directory BUFFER is visiting.
+No argument or nil as argument means use the current buffer."
+ (file-name-nondirectory (buffer-file-name buffer)))
+
+(defun semantic-grammar-package ()
+ "Return the %package value as a string.
+If there is no %package statement in the grammar, return a default
+package name derived from the grammar file name. For example, the
+default package name for the grammar file foo.wy is foo-wy, and for
+foo.by it is foo-by."
+ (or (semantic-grammar-first-tag-name 'package)
+ (let* ((file (semantic-grammar-buffer-file))
+ (ext (file-name-extension file))
+ (i (string-match (format "\\([.]\\)%s\\'" ext) file)))
+ (concat (substring file 0 i) "-" ext))))
+
+(defsubst semantic-grammar-languagemode ()
+ "Return the %languagemode value as a list of symbols or nil."
+ (semantic-grammar-tag-symbols 'languagemode))
+
+(defsubst semantic-grammar-start ()
+ "Return the %start value as a list of symbols or nil."
+ (semantic-grammar-tag-symbols 'start))
+
+(defsubst semantic-grammar-scopestart ()
+ "Return the %scopestart value as a symbol or nil."
+ (intern (or (semantic-grammar-first-tag-name 'scopestart) "nil")))
+
+(defsubst semantic-grammar-quotemode ()
+ "Return the %quotemode value as a symbol or nil."
+ (intern (or (semantic-grammar-first-tag-name 'quotemode) "nil")))
+
+(defsubst semantic-grammar-keywords ()
+ "Return the language keywords.
+That is an alist of (VALUE . TOKEN) where VALUE is the string value of
+the keyword and TOKEN is the terminal symbol identifying the keyword."
+ (mapcar
+ #'(lambda (key)
+ (cons (semantic-tag-get-attribute key :value)
+ (intern (semantic-tag-name key))))
+ (semantic-find-tags-by-class 'keyword (current-buffer))))
+
+(defun semantic-grammar-keyword-properties (keywords)
+ "Return the list of KEYWORDS properties."
+ (let ((puts (semantic-find-tags-by-class
+ 'put (current-buffer)))
+ put keys key plist assoc pkey pval props)
+ (while puts
+ (setq put (car puts)
+ puts (cdr puts)
+ keys (mapcar
+ 'intern
+ (cons (semantic-tag-name put)
+ (semantic-tag-get-attribute put :rest))))
+ (while keys
+ (setq key (car keys)
+ keys (cdr keys)
+ assoc (rassq key keywords))
+ (if (null assoc)
+ nil ;;(message "*** %%put to undefined keyword %s ignored" key)
+ (setq key (car assoc)
+ plist (semantic-tag-get-attribute put :value))
+ (while plist
+ (setq pkey (intern (caar plist))
+ pval (read (cdar plist))
+ props (cons (list key pkey pval) props)
+ plist (cdr plist))))))
+ props))
+
+(defun semantic-grammar-tokens ()
+ "Return defined lexical tokens.
+That is an alist (TYPE . DEFS) where type is a %token <type> symbol
+and DEFS is an alist of (TOKEN . VALUE). TOKEN is the terminal symbol
+identifying the token and VALUE is the string value of the token or
+nil."
+ (let (tags alist assoc tag type term names value)
+
+ ;; Check for <type> in %left, %right & %nonassoc declarations
+ (setq tags (semantic-find-tags-by-class
+ 'assoc (current-buffer)))
+ (while tags
+ (setq tag (car tags)
+ tags (cdr tags))
+ (when (setq type (semantic-tag-type tag))
+ (setq names (semantic-tag-get-attribute tag :value)
+ assoc (assoc type alist))
+ (or assoc (setq assoc (list type)
+ alist (cons assoc alist)))
+ (while names
+ (setq term (car names)
+ names (cdr names))
+ (or (string-match semantic-grammar-lex-c-char-re term)
+ (setcdr assoc (cons (list (intern term))
+ (cdr assoc)))))))
+
+ ;; Then process %token declarations so they can override any
+ ;; previous specifications
+ (setq tags (semantic-find-tags-by-class
+ 'token (current-buffer)))
+ (while tags
+ (setq tag (car tags)
+ tags (cdr tags))
+ (setq names (cons (semantic-tag-name tag)
+ (semantic-tag-get-attribute tag :rest))
+ type (or (semantic-tag-type tag) "<no-type>")
+ value (semantic-tag-get-attribute tag :value)
+ assoc (assoc type alist))
+ (or assoc (setq assoc (list type)
+ alist (cons assoc alist)))
+ (while names
+ (setq term (intern (car names))
+ names (cdr names))
+ (setcdr assoc (cons (cons term value) (cdr assoc)))))
+ alist))
+
+(defun semantic-grammar-token-%type-properties (&optional props)
+ "Return properties set by %type statements.
+This declare a new type if necessary.
+If optional argument PROPS is non-nil, it is an existing list of
+properties where to add new properties."
+ (let (type)
+ (dolist (tag (semantic-find-tags-by-class 'type (current-buffer)))
+ (setq type (semantic-tag-name tag))
+ ;; Indicate to auto-generate the analyzer for this type
+ (push (list type :declared t) props)
+ (dolist (e (semantic-tag-get-attribute tag :value))
+ (push (list type (intern (car e)) (read (or (cdr e) "nil")))
+ props)))
+ props))
+
+(defun semantic-grammar-token-%put-properties (tokens)
+ "For types found in TOKENS, return properties set by %put statements."
+ (let (found props)
+ (dolist (put (semantic-find-tags-by-class 'put (current-buffer)))
+ (dolist (type (cons (semantic-tag-name put)
+ (semantic-tag-get-attribute put :rest)))
+ (setq found (assoc type tokens))
+ (if (null found)
+ nil ;; %put <type> ignored, no token defined
+ (setq type (car found))
+ (dolist (e (semantic-tag-get-attribute put :value))
+ (push (list type (intern (car e)) (read (or (cdr e) "nil")))
+ props)))))
+ props))
+
+(defsubst semantic-grammar-token-properties (tokens)
+ "Return properties of declared types.
+Types are explicitly declared by %type statements. Types found in
+TOKENS are those declared implicitly by %token statements.
+Properties can be set by %put and %type statements.
+Properties set by %type statements take precedence over those set by
+%put statements."
+ (let ((props (semantic-grammar-token-%put-properties tokens)))
+ (semantic-grammar-token-%type-properties props)))
+
+(defun semantic-grammar-use-macros ()
+ "Return macro definitions from %use-macros statements.
+Also load the specified macro libraries."
+ (let (lib defs)
+ (dolist (tag (semantic-find-tags-by-class 'macro (current-buffer)))
+ (setq lib (intern (semantic-tag-type tag)))
+ (condition-case nil
+ ;;(load lib) ;; Be sure to use the latest macro library.
+ (require lib)
+ (error nil))
+ (dolist (mac (semantic-tag-get-attribute tag :value))
+ (push (cons (intern mac)
+ (intern (format "%s-%s" lib mac)))
+ defs)))
+ (nreverse defs)))
+
+(defvar semantic-grammar-macros nil
+ "List of associations (MACRO-NAME . EXPANDER).")
+(make-variable-buffer-local 'semantic-grammar-macros)
+
+(defun semantic-grammar-macros ()
+ "Build and return the alist of defined macros."
+ (append
+ ;; Definitions found in tags.
+ (semantic-grammar-use-macros)
+ ;; Other pre-installed definitions.
+ semantic-grammar-macros))
+
+;;;;
+;;;; Overloaded functions that build parser data.
+;;;;
+
+;;; Keyword table builder
+;;
+(defun semantic-grammar-keywordtable-builder-default ()
+ "Return the default value of the keyword table."
+ (let ((keywords (semantic-grammar-keywords)))
+ `(semantic-lex-make-keyword-table
+ ',keywords
+ ',(semantic-grammar-keyword-properties keywords))))
+
+(define-overloadable-function semantic-grammar-keywordtable-builder ()
+ "Return the keyword table table value.")
+
+;;; Token table builder
+;;
+(defun semantic-grammar-tokentable-builder-default ()
+ "Return the default value of the table of lexical tokens."
+ (let ((tokens (semantic-grammar-tokens)))
+ `(semantic-lex-make-type-table
+ ',tokens
+ ',(semantic-grammar-token-properties tokens))))
+
+(define-overloadable-function semantic-grammar-tokentable-builder ()
+ "Return the value of the table of lexical tokens.")
+
+;;; Parser table builder
+;;
+(defun semantic-grammar-parsetable-builder-default ()
+ "Return the default value of the parse table."
+ (error "`semantic-grammar-parsetable-builder' not defined"))
+
+(define-overloadable-function semantic-grammar-parsetable-builder ()
+ "Return the parser table value.")
+
+;;; Parser setup code builder
+;;
+(defun semantic-grammar-setupcode-builder-default ()
+ "Return the default value of the setup code form."
+ (error "`semantic-grammar-setupcode-builder' not defined"))
+
+(define-overloadable-function semantic-grammar-setupcode-builder ()
+ "Return the parser setup code form.")
+
+;;;;
+;;;; Lisp code generation
+;;;;
+(defvar semantic--grammar-input-buffer nil)
+(defvar semantic--grammar-output-buffer nil)
+
+(defsubst semantic-grammar-keywordtable ()
+ "Return the variable name of the keyword table."
+ (concat (file-name-sans-extension
+ (semantic-grammar-buffer-file
+ semantic--grammar-output-buffer))
+ "--keyword-table"))
+
+(defsubst semantic-grammar-tokentable ()
+ "Return the variable name of the token table."
+ (concat (file-name-sans-extension
+ (semantic-grammar-buffer-file
+ semantic--grammar-output-buffer))
+ "--token-table"))
+
+(defsubst semantic-grammar-parsetable ()
+ "Return the variable name of the parse table."
+ (concat (file-name-sans-extension
+ (semantic-grammar-buffer-file
+ semantic--grammar-output-buffer))
+ "--parse-table"))
+
+(defsubst semantic-grammar-setupfunction ()
+ "Return the name of the parser setup function."
+ (concat (file-name-sans-extension
+ (semantic-grammar-buffer-file
+ semantic--grammar-output-buffer))
+ "--install-parser"))
+
+(defmacro semantic-grammar-as-string (object)
+ "Return OBJECT as a string value."
+ `(if (stringp ,object)
+ ,object
+ ;;(require 'pp)
+ (pp-to-string ,object)))
+
+(defun semantic-grammar-insert-defconst (name value docstring)
+ "Insert declaration of constant NAME with VALUE and DOCSTRING."
+ (let ((start (point)))
+ (insert (format "(defconst %s\n%s%S)\n\n" name value docstring))
+ (save-excursion
+ (goto-char start)
+ (indent-sexp))))
+
+(defun semantic-grammar-insert-defun (name body docstring)
+ "Insert declaration of function NAME with BODY and DOCSTRING."
+ (let ((start (point)))
+ (insert (format "(defun %s ()\n%S\n%s)\n\n" name docstring body))
+ (save-excursion
+ (goto-char start)
+ (indent-sexp))))
+
+(defun semantic-grammar-insert-define (define)
+ "Insert the declaration specified by DEFINE expression.
+Typically a DEFINE expression should look like this:
+
+\(define-thing name docstring expression1 ...)"
+ ;;(require 'pp)
+ (let ((start (point)))
+ (insert (format "(%S %S" (car define) (nth 1 define)))
+ (dolist (item (nthcdr 2 define))
+ (insert "\n")
+ (delete-blank-lines)
+ (pp item (current-buffer)))
+ (insert ")\n\n")
+ (save-excursion
+ (goto-char start)
+ (indent-sexp))))
+
+(defconst semantic-grammar-header-template
+ '("\
+;;; " file " --- Generated parser support file
+
+" copy "
+
+;; Author: " user-full-name " <" user-mail-address ">
+;; Created: " date "
+;; Keywords: syntax
+;; X-RCS: " vcid "
+
+;; This file is not part of GNU Emacs.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or (at
+;; your option) any later version.
+;;
+;; This software is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+;;
+;; PLEASE DO NOT MANUALLY EDIT THIS FILE! It is automatically
+;; generated from the grammar file " gram ".
+
+;;; History:
+;;
+
+;;; Code:
+")
+ "Generated header template.
+The symbols in the template are local variables in
+`semantic-grammar-header'")
+
+(defconst semantic-grammar-footer-template
+ '("\
+
+\(provide '" libr ")
+
+;;; " file " ends here
+")
+ "Generated footer template.
+The symbols in the list are local variables in
+`semantic-grammar-footer'.")
+
+(defun semantic-grammar-copyright-line ()
+ "Return the grammar copyright line, or nil if not found."
+ (save-excursion
+ (goto-char (point-min))
+ (when (re-search-forward "^;;+[ \t]+Copyright (C) .*$"
+ ;; Search only in the four top lines
+ (save-excursion (forward-line 4) (point))
+ t)
+ (match-string 0))))
+
+(defun semantic-grammar-header ()
+ "Return text of a generated standard header."
+ (let ((file (semantic-grammar-buffer-file
+ semantic--grammar-output-buffer))
+ (gram (semantic-grammar-buffer-file))
+ (date (format-time-string "%Y-%m-%d %T%z"))
+ (vcid (concat "$" "Id" "$")) ;; Avoid expansion
+ ;; Try to get the copyright from the input grammar, or
+ ;; generate a new one if not found.
+ (copy (or (semantic-grammar-copyright-line)
+ (concat (format-time-string ";; Copyright (C) %Y ")
+ user-full-name)))
+ (out ""))
+ (dolist (S semantic-grammar-header-template)
+ (cond ((stringp S)
+ (setq out (concat out S)))
+ ((symbolp S)
+ (setq out (concat out (symbol-value S))))))
+ out))
+
+(defun semantic-grammar-footer ()
+ "Return text of a generated standard footer."
+ (let* ((file (semantic-grammar-buffer-file
+ semantic--grammar-output-buffer))
+ (libr (file-name-sans-extension file))
+ (out ""))
+ (dolist (S semantic-grammar-footer-template)
+ (cond ((stringp S)
+ (setq out (concat out S)))
+ ((symbolp S)
+ (setq out (concat out (symbol-value S))))))
+ out))
+
+(defun semantic-grammar-token-data ()
+ "Return the string value of the table of lexical tokens."
+ (semantic-grammar-as-string
+ (semantic-grammar-tokentable-builder)))
+
+(defun semantic-grammar-keyword-data ()
+ "Return the string value of the table of keywords."
+ (semantic-grammar-as-string
+ (semantic-grammar-keywordtable-builder)))
+
+(defun semantic-grammar-parser-data ()
+ "Return the parser table as a string value."
+ (semantic-grammar-as-string
+ (semantic-grammar-parsetable-builder)))
+
+(defun semantic-grammar-setup-data ()
+ "Return the parser setup code form as a string value."
+ (semantic-grammar-as-string
+ (semantic-grammar-setupcode-builder)))
+
+;;; Generation of lexical analyzers.
+;;
+(defvar semantic-grammar--lex-block-specs)
+
+(defsubst semantic-grammar--lex-delim-spec (block-spec)
+ "Return delimiters specification from BLOCK-SPEC."
+ (condition-case nil
+ (let* ((standard-input (cdr block-spec))
+ (delim-spec (read)))
+ (if (and (consp delim-spec)
+ (car delim-spec) (symbolp (car delim-spec))
+ (cadr delim-spec) (symbolp (cadr delim-spec)))
+ delim-spec
+ (error)))
+ (error
+ (error "Invalid delimiters specification %s in block token %s"
+ (cdr block-spec) (car block-spec)))))
+
+(defun semantic-grammar--lex-block-specs ()
+ "Compute lexical block specifications for the current buffer.
+Block definitions are read from the current table of lexical types."
+ (cond
+ ;; Block specifications have been parsed and are invalid.
+ ((eq semantic-grammar--lex-block-specs 'error)
+ nil
+ )
+ ;; Parse block specifications.
+ ((null semantic-grammar--lex-block-specs)
+ (condition-case err
+ (let* ((blocks (cdr (semantic-lex-type-value "block" t)))
+ (open-delims (cdr (semantic-lex-type-value "open-paren" t)))
+ (close-delims (cdr (semantic-lex-type-value "close-paren" t)))
+ olist clist block-spec delim-spec open-spec close-spec)
+ (dolist (block-spec blocks)
+ (setq delim-spec (semantic-grammar--lex-delim-spec block-spec)
+ open-spec (assq (car delim-spec) open-delims)
+ close-spec (assq (cadr delim-spec) close-delims))
+ (or open-spec
+ (error "Missing open-paren token %s required by block %s"
+ (car delim-spec) (car block-spec)))
+ (or close-spec
+ (error "Missing close-paren token %s required by block %s"
+ (cdr delim-spec) (car block-spec)))
+ ;; build alist ((OPEN-DELIM OPEN-SYM BLOCK-SYM) ...)
+ (push (list (cdr open-spec) (car open-spec) (car block-spec))
+ olist)
+ ;; build alist ((CLOSE-DELIM CLOSE-SYM) ...)
+ (push (list (cdr close-spec) (car close-spec))
+ clist))
+ (setq semantic-grammar--lex-block-specs (cons olist clist)))
+ (error
+ (setq semantic-grammar--lex-block-specs 'error)
+ (message "%s" (error-message-string err))
+ nil))
+ )
+ ;; Block specifications already parsed.
+ (t
+ semantic-grammar--lex-block-specs)))
+
+(defsubst semantic-grammar-quoted-form (exp)
+ "Return a quoted form of EXP if it isn't a self evaluating form."
+ (if (and (not (null exp))
+ (or (listp exp) (symbolp exp)))
+ (list 'quote exp)
+ exp))
+
+(defun semantic-grammar-insert-defanalyzer (type)
+ "Insert declaration of the lexical analyzer defined with TYPE."
+ (let* ((type-name (symbol-name type))
+ (type-value (symbol-value type))
+ (syntax (get type 'syntax))
+ (declared (get type :declared))
+ spec mtype prefix name doc)
+ ;; Generate an analyzer if the corresponding type has been
+ ;; explicitly declared in a %type statement, and if at least the
+ ;; syntax property has been provided.
+ (when (and declared syntax)
+ (setq prefix (file-name-sans-extension
+ (semantic-grammar-buffer-file
+ semantic--grammar-output-buffer))
+ mtype (or (get type 'matchdatatype) 'regexp)
+ name (intern (format "%s--<%s>-%s-analyzer" prefix type mtype))
+ doc (format "%s analyzer for <%s> tokens." mtype type))
+ (cond
+ ;; Regexp match analyzer
+ ((eq mtype 'regexp)
+ (semantic-grammar-insert-define
+ `(define-lex-regex-type-analyzer ,name
+ ,doc ,syntax
+ ,(semantic-grammar-quoted-form (cdr type-value))
+ ',(or (car type-value) (intern type-name))))
+ )
+ ;; String compare analyzer
+ ((eq mtype 'string)
+ (semantic-grammar-insert-define
+ `(define-lex-string-type-analyzer ,name
+ ,doc ,syntax
+ ,(semantic-grammar-quoted-form (cdr type-value))
+ ',(or (car type-value) (intern type-name))))
+ )
+ ;; Block analyzer
+ ((and (eq mtype 'block)
+ (setq spec (semantic-grammar--lex-block-specs)))
+ (semantic-grammar-insert-define
+ `(define-lex-block-type-analyzer ,name
+ ,doc ,syntax
+ ,(semantic-grammar-quoted-form spec)))
+ )
+ ;; Sexp analyzer
+ ((eq mtype 'sexp)
+ (semantic-grammar-insert-define
+ `(define-lex-sexp-type-analyzer ,name
+ ,doc ,syntax
+ ',(or (car type-value) (intern type-name))))
+ )
+ ;; keyword analyzer
+ ((eq mtype 'keyword)
+ (semantic-grammar-insert-define
+ `(define-lex-keyword-type-analyzer ,name
+ ,doc ,syntax))
+ )
+ ))
+ ))
+
+(defun semantic-grammar-insert-defanalyzers ()
+ "Insert declarations of lexical analyzers."
+ (let (tokens props)
+ (with-current-buffer semantic--grammar-input-buffer
+ (setq tokens (semantic-grammar-tokens)
+ props (semantic-grammar-token-properties tokens)))
+ (insert "(require 'semantic-lex)\n\n")
+ (let ((semantic-lex-types-obarray
+ (semantic-lex-make-type-table tokens props))
+ semantic-grammar--lex-block-specs)
+ (mapatoms 'semantic-grammar-insert-defanalyzer
+ semantic-lex-types-obarray))))
+
+;;; Generation of the grammar support file.
+;;
+(defcustom semantic-grammar-file-regexp "\\.[wb]y$"
+ "Regexp which matches grammar source files."
+ :group 'semantic
+ :type 'regexp)
+
+(defsubst semantic-grammar-noninteractive ()
+ "Return non-nil if running without interactive terminal."
+ (if (featurep 'xemacs)
+ (noninteractive)
+ noninteractive))
+
+(defun semantic-grammar-create-package (&optional force)
+ "Create package Lisp code from grammar in current buffer.
+Does nothing if the Lisp code seems up to date.
+If optional argument FORCE is non-nil, unconditionally re-generate the
+Lisp code."
+ (interactive "P")
+ (setq force (or force current-prefix-arg))
+ (semantic-fetch-tags)
+ (let* (
+ ;; Values of the following local variables are obtained from
+ ;; the grammar parsed tree in current buffer, that is before
+ ;; switching to the output file.
+ (package (semantic-grammar-package))
+ (output (concat package ".el"))
+ (semantic--grammar-input-buffer (current-buffer))
+ (semantic--grammar-output-buffer (find-file-noselect output))
+ (header (semantic-grammar-header))
+ (prologue (semantic-grammar-prologue))
+ (epilogue (semantic-grammar-epilogue))
+ (footer (semantic-grammar-footer))
+ )
+ (if (and (not force)
+ (not (buffer-modified-p))
+ (file-newer-than-file-p
+ (buffer-file-name semantic--grammar-output-buffer)
+ (buffer-file-name semantic--grammar-input-buffer)))
+ (message "Package `%s' is up to date." package)
+ ;; Create the package
+ (set-buffer semantic--grammar-output-buffer)
+ ;; Use Unix EOLs, so that the file is portable to all platforms.
+ (setq buffer-file-coding-system 'raw-text-unix)
+ (erase-buffer)
+ (unless (eq major-mode 'emacs-lisp-mode)
+ (emacs-lisp-mode))
+
+;;;; Header + Prologue
+
+ (insert header
+ " \n;;; Prologue\n;;\n"
+ prologue
+ )
+ ;; Evaluate the prologue now, because it might provide definition
+ ;; of grammar macro expanders.
+ (eval-region (point-min) (point))
+
+ (save-excursion
+
+;;;; Declarations
+
+ (insert " \n;;; Declarations\n;;\n")
+
+ ;; `eval-defun' is not necessary to reset `defconst' values.
+ (semantic-grammar-insert-defconst
+ (semantic-grammar-keywordtable)
+ (with-current-buffer semantic--grammar-input-buffer
+ (semantic-grammar-keyword-data))
+ "Table of language keywords.")
+
+ (semantic-grammar-insert-defconst
+ (semantic-grammar-tokentable)
+ (with-current-buffer semantic--grammar-input-buffer
+ (semantic-grammar-token-data))
+ "Table of lexical tokens.")
+
+ (semantic-grammar-insert-defconst
+ (semantic-grammar-parsetable)
+ (with-current-buffer semantic--grammar-input-buffer
+ (semantic-grammar-parser-data))
+ "Parser table.")
+
+ (semantic-grammar-insert-defun
+ (semantic-grammar-setupfunction)
+ (with-current-buffer semantic--grammar-input-buffer
+ (semantic-grammar-setup-data))
+ "Setup the Semantic Parser.")
+
+;;;; Analyzers
+ (insert " \n;;; Analyzers\n;;\n")
+
+ (semantic-grammar-insert-defanalyzers)
+
+;;;; Epilogue & Footer
+
+ (insert " \n;;; Epilogue\n;;\n"
+ epilogue
+ footer
+ )
+
+ )
+
+ (save-buffer 16)
+
+ ;; If running in batch mode, there is nothing more to do.
+ ;; Save the generated file and quit.
+ (if (semantic-grammar-noninteractive)
+ (let ((version-control t)
+ (delete-old-versions t)
+ (make-backup-files t)
+ (vc-make-backup-files t))
+ (kill-buffer (current-buffer)))
+ ;; If running interactively, eval declarations and epilogue
+ ;; code, then pop to the buffer visiting the generated file.
+ (eval-region (point) (point-max))
+ (goto-char (point-min))
+ (pop-to-buffer (current-buffer))
+ ;; The generated code has been evaluated and updated into
+ ;; memory. Now find all buffers that match the major modes we
+ ;; have created this language for, and force them to call our
+ ;; setup function again, refreshing all semantic data, and
+ ;; enabling them to work with the new code just created.
+;;;; FIXME?
+ ;; At this point, I don't know any user's defined setup code :-(
+ ;; At least, what I can do for now, is to run the generated
+ ;; parser-install function.
+ (semantic-map-mode-buffers
+ (semantic-grammar-setupfunction)
+ (semantic-grammar-languagemode)))
+ )
+ ;; Return the name of the generated package file.
+ output))
+
+(defun semantic-grammar-recreate-package ()
+ "Unconditionnaly create Lisp code from grammar in current buffer.
+Like \\[universal-argument] \\[semantic-grammar-create-package]."
+ (interactive)
+ (semantic-grammar-create-package t))
+
+(defun semantic-grammar-batch-build-one-package (file)
+ "Build a Lisp package from the grammar in FILE.
+That is, generate Lisp code from FILE, and `byte-compile' it.
+Return non-nil if there were no errors, nil if errors."
+ ;; We need this require so that we can find `byte-compile-dest-file'.
+ (require 'bytecomp)
+ (unless (auto-save-file-name-p file)
+ ;; Create the package
+ (let ((packagename
+ (condition-case err
+ (with-current-buffer (find-file-noselect file)
+ (semantic-grammar-create-package))
+ (error
+ (message "%s" (error-message-string err))
+ nil))))
+ (when packagename
+ ;; Only byte compile if out of date
+ (if (file-newer-than-file-p
+ packagename (byte-compile-dest-file packagename))
+ (let (;; Some complex grammar table expressions need a few
+ ;; more resources than the default.
+ (max-specpdl-size (max 3000 max-specpdl-size))
+ (max-lisp-eval-depth (max 1000 max-lisp-eval-depth))
+ )
+ ;; byte compile the resultant file
+ (byte-compile-file packagename))
+ t)))))
+
+(defun semantic-grammar-batch-build-packages ()
+ "Build Lisp packages from grammar files on the command line.
+That is, run `semantic-grammar-batch-build-one-package' for each file.
+Each file is processed even if an error occurred previously.
+Must be used from the command line, with `-batch'.
+For example, to process grammar files in current directory, invoke:
+
+ \"emacs -batch -f semantic-grammar-batch-build-packages .\".
+
+See also the variable `semantic-grammar-file-regexp'."
+ (or (semantic-grammar-noninteractive)
+ (error "\
+`semantic-grammar-batch-build-packages' must be used with -batch"
+ ))
+ (let ((status 0)
+ ;; Remove vc from find-file-hook. It causes bad stuff to
+ ;; happen in Emacs 20.
+ (find-file-hook (delete 'vc-find-file-hook find-file-hook)))
+ (message "Compiling Grammars from: %s" (locate-library "semantic-grammar"))
+ (dolist (arg command-line-args-left)
+ (unless (and arg (file-exists-p arg))
+ (error "Argument %s is not a valid file name" arg))
+ (setq arg (expand-file-name arg))
+ (if (file-directory-p arg)
+ ;; Directory as argument
+ (dolist (src (condition-case nil
+ (directory-files
+ arg nil semantic-grammar-file-regexp)
+ (error
+ (error "Unable to read directory files"))))
+ (or (semantic-grammar-batch-build-one-package
+ (expand-file-name src arg))
+ (setq status 1)))
+ ;; Specific file argument
+ (or (semantic-grammar-batch-build-one-package arg)
+ (setq status 1))))
+ (kill-emacs status)
+ ))
+
+;;;;
+;;;; Macros highlighting
+;;;;
+
+(defvar semantic--grammar-macros-regexp-1 nil)
+(make-variable-buffer-local 'semantic--grammar-macros-regexp-1)
+
+(defun semantic--grammar-macros-regexp-1 ()
+ "Return font-lock keyword regexp for pre-installed macro names."
+ (and semantic-grammar-macros
+ (not semantic--grammar-macros-regexp-1)
+ (condition-case nil
+ (setq semantic--grammar-macros-regexp-1
+ (concat "(\\s-*"
+ (regexp-opt
+ (mapcar #'(lambda (e) (symbol-name (car e)))
+ semantic-grammar-macros)
+ t)
+ "\\>"))
+ (error nil)))
+ semantic--grammar-macros-regexp-1)
+
+(defconst semantic--grammar-macdecl-re
+ "\\<%use-macros\\>[ \t\r\n]+\\(\\sw\\|\\s_\\)+[ \t\r\n]+{"
+ "Regexp that matches a macro declaration statement.")
+
+(defvar semantic--grammar-macros-regexp-2 nil)
+(make-variable-buffer-local 'semantic--grammar-macros-regexp-2)
+
+(defun semantic--grammar-clear-macros-regexp-2 (&rest ignore)
+ "Clear the cached regexp that match macros local in this grammar.
+IGNORE arguments.
+Added to `before-change-functions' hooks to be run before each text
+change."
+ (setq semantic--grammar-macros-regexp-2 nil))
+
+(defun semantic--grammar-macros-regexp-2 ()
+ "Return the regexp that match macros local in this grammar."
+ (unless semantic--grammar-macros-regexp-2
+ (let (macs)
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward semantic--grammar-macdecl-re nil t)
+ (condition-case nil
+ (setq macs (nconc macs
+ (split-string
+ (buffer-substring-no-properties
+ (point)
+ (progn
+ (backward-char)
+ (forward-list 1)
+ (down-list -1)
+ (point))))))
+ (error nil)))
+ (when macs
+ (setq semantic--grammar-macros-regexp-2
+ (concat "(\\s-*" (regexp-opt macs t) "\\>"))))))
+ semantic--grammar-macros-regexp-2)
+
+(defun semantic--grammar-macros-matcher (end)
+ "Search for a grammar macro name to highlight.
+END is the limit of the search."
+ (let ((regexp (semantic--grammar-macros-regexp-1)))
+ (or (and regexp (re-search-forward regexp end t))
+ (and (setq regexp (semantic--grammar-macros-regexp-2))
+ (re-search-forward regexp end t)))))
+
+;;;;
+;;;; Define major mode
+;;;;
+
+(defvar semantic-grammar-syntax-table
+ (let ((table (make-syntax-table (standard-syntax-table))))
+ (modify-syntax-entry ?\: "." table) ;; COLON
+ (modify-syntax-entry ?\> "." table) ;; GT
+ (modify-syntax-entry ?\< "." table) ;; LT
+ (modify-syntax-entry ?\| "." table) ;; OR
+ (modify-syntax-entry ?\; ". 12" table) ;; SEMI, Comment start ;;
+ (modify-syntax-entry ?\n ">" table) ;; Comment end
+ (modify-syntax-entry ?\" "\"" table) ;; String
+ (modify-syntax-entry ?\% "w" table) ;; Word
+ (modify-syntax-entry ?\- "_" table) ;; Symbol
+ (modify-syntax-entry ?\. "_" table) ;; Symbol
+ (modify-syntax-entry ?\\ "\\" table) ;; Quote
+ (modify-syntax-entry ?\` "'" table) ;; Prefix ` (backquote)
+ (modify-syntax-entry ?\' "'" table) ;; Prefix ' (quote)
+ (modify-syntax-entry ?\, "'" table) ;; Prefix , (comma)
+ (modify-syntax-entry ?\# "'" table) ;; Prefix # (sharp)
+ table)
+ "Syntax table used in a Semantic grammar buffers.")
+
+(defvar semantic-grammar-mode-hook nil
+ "Hook run when starting Semantic grammar mode.")
+
+(defvar semantic-grammar-mode-keywords-1
+ `(("\\(\\<%%\\>\\|\\<%[{}]\\)"
+ 0 font-lock-reference-face)
+ ("\\(%\\)\\(\\(\\sw\\|\\s_\\)+\\)"
+ (1 font-lock-reference-face)
+ (2 font-lock-keyword-face))
+ ("\\<error\\>"
+ 0 (unless (semantic-grammar-in-lisp-p) 'bold))
+ ("^\\(\\(\\sw\\|\\s_\\)+\\)[ \n\r\t]*:"
+ 1 font-lock-function-name-face)
+ (semantic--grammar-macros-matcher
+ 1 ,(if (boundp 'font-lock-builtin-face)
+ 'font-lock-builtin-face
+ 'font-lock-preprocessor-face))
+ ("\\$\\(\\sw\\|\\s_\\)*"
+ 0 font-lock-variable-name-face)
+ ("<\\(\\(\\sw\\|\\s_\\)+\\)>"
+ 1 font-lock-type-face)
+ (,semantic-grammar-lex-c-char-re
+ 0 ,(if (boundp 'font-lock-constant-face)
+ 'font-lock-constant-face
+ 'font-lock-string-face) t)
+ ;; Must highlight :keyword here, because ':' is a punctuation in
+ ;; grammar mode!
+ ("[\r\n\t ]+:\\sw+\\>"
+ 0 font-lock-builtin-face)
+ ;; ;; Append the Semantic keywords
+ ;; ,@semantic-fw-font-lock-keywords
+ )
+ "Font Lock keywords used to highlight Semantic grammar buffers.")
+
+(defvar semantic-grammar-mode-keywords-2
+ (append semantic-grammar-mode-keywords-1
+ lisp-font-lock-keywords-1)
+ "Font Lock keywords used to highlight Semantic grammar buffers.")
+
+(defvar semantic-grammar-mode-keywords-3
+ (append semantic-grammar-mode-keywords-1
+ lisp-font-lock-keywords-2)
+ "Font Lock keywords used to highlight Semantic grammar buffers.")
+
+(defvar semantic-grammar-mode-keywords
+ semantic-grammar-mode-keywords-1
+ "Font Lock keywords used to highlight Semantic grammar buffers.")
+
+(defvar semantic-grammar-map
+ (let ((km (make-sparse-keymap)))
+
+ (define-key km "|" 'semantic-grammar-electric-punctuation)
+ (define-key km ";" 'semantic-grammar-electric-punctuation)
+ (define-key km "%" 'semantic-grammar-electric-punctuation)
+ (define-key km "(" 'semantic-grammar-electric-punctuation)
+ (define-key km ")" 'semantic-grammar-electric-punctuation)
+ (define-key km ":" 'semantic-grammar-electric-punctuation)
+
+ (define-key km "\t" 'semantic-grammar-indent)
+ (define-key km "\M-\t" 'semantic-grammar-complete)
+ (define-key km "\C-c\C-c" 'semantic-grammar-create-package)
+ (define-key km "\C-cm" 'semantic-grammar-find-macro-expander)
+ (define-key km "\C-cik" 'semantic-grammar-insert-keyword)
+;; (define-key km "\C-cc" 'semantic-grammar-generate-and-load)
+;; (define-key km "\C-cr" 'semantic-grammar-generate-one-rule)
+
+ km)
+ "Keymap used in `semantic-grammar-mode'.")
+
+(defvar semantic-grammar-menu
+ '("Grammar"
+ ["Indent Line" semantic-grammar-indent]
+ ["Complete Symbol" semantic-grammar-complete]
+ ["Find Macro" semantic-grammar-find-macro-expander]
+ "--"
+ ["Insert %keyword" semantic-grammar-insert-keyword]
+ "--"
+ ["Update Lisp Package" semantic-grammar-create-package]
+ ["Recreate Lisp Package" semantic-grammar-recreate-package]
+ )
+ "Common semantic grammar menu.")
+
+(defun semantic-grammar-setup-menu-emacs (symbol mode-menu)
+ "Setup a GNU Emacs grammar menu in variable SYMBOL.
+MODE-MENU is an optional specific menu whose items are appended to the
+common grammar menu."
+ (let ((items (make-symbol "items")))
+ `(unless (boundp ',symbol)
+ (easy-menu-define ,symbol (current-local-map)
+ "Grammar Menu" semantic-grammar-menu)
+ (let ((,items (cdr ,mode-menu)))
+ (when ,items
+ (easy-menu-add-item ,symbol nil "--")
+ (while ,items
+ (easy-menu-add-item ,symbol nil (car ,items))
+ (setq ,items (cdr ,items))))))
+ ))
+
+(defun semantic-grammar-setup-menu-xemacs (symbol mode-menu)
+ "Setup an XEmacs grammar menu in variable SYMBOL.
+MODE-MENU is an optional specific menu whose items are appended to the
+common grammar menu."
+ (let ((items (make-symbol "items"))
+ (path (make-symbol "path")))
+ `(progn
+ (unless (boundp ',symbol)
+ (easy-menu-define ,symbol nil
+ "Grammar Menu" (copy-sequence semantic-grammar-menu)))
+ (easy-menu-add ,symbol)
+ (let ((,items (cdr ,mode-menu))
+ (,path (list (car ,symbol))))
+ (when ,items
+ (easy-menu-add-item nil ,path "--")
+ (while ,items
+ (easy-menu-add-item nil ,path (car ,items))
+ (setq ,items (cdr ,items))))))
+ ))
+
+(defmacro semantic-grammar-setup-menu (&optional mode-menu)
+ "Setup a mode local grammar menu.
+MODE-MENU is an optional specific menu whose items are appended to the
+common grammar menu."
+ (let ((menu (intern (format "%s-menu" major-mode))))
+ (if (featurep 'xemacs)
+ (semantic-grammar-setup-menu-xemacs menu mode-menu)
+ (semantic-grammar-setup-menu-emacs menu mode-menu))))
+
+(defsubst semantic-grammar-in-lisp-p ()
+ "Return non-nil if point is in Lisp code."
+ (or (>= (point) (semantic-grammar-epilogue-start))
+ (condition-case nil
+ (save-excursion
+ (up-list -1)
+ t)
+ (error nil))))
+
+(defun semantic-grammar-edits-new-change-hook-fcn (overlay)
+ "Function set into `semantic-edits-new-change-hook'.
+Argument OVERLAY is the overlay created to mark the change.
+When OVERLAY marks a change in the scope of a nonterminal tag extend
+the change bounds to encompass the whole nonterminal tag."
+ (let ((outer (car (semantic-find-tag-by-overlay-in-region
+ (semantic-edits-os overlay)
+ (semantic-edits-oe overlay)))))
+ (if (semantic-tag-of-class-p outer 'nonterminal)
+ (semantic-overlay-move overlay
+ (semantic-tag-start outer)
+ (semantic-tag-end outer)))))
+
+(defun semantic-grammar-mode ()
+ "Initialize a buffer for editing Semantic grammars.
+
+\\{semantic-grammar-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (setq major-mode 'semantic-grammar-mode
+ mode-name "Semantic Grammar Framework")
+ (set (make-local-variable 'parse-sexp-ignore-comments) t)
+ (set (make-local-variable 'comment-start) ";;")
+ ;; Look within the line for a ; following an even number of backslashes
+ ;; after either a non-backslash or the line beginning.
+ (set (make-local-variable 'comment-start-skip)
+ "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *")
+ (set-syntax-table semantic-grammar-syntax-table)
+ (use-local-map semantic-grammar-map)
+ (set (make-local-variable 'indent-line-function)
+ 'semantic-grammar-indent)
+ (set (make-local-variable 'fill-paragraph-function)
+ 'lisp-fill-paragraph)
+ (set (make-local-variable 'font-lock-multiline)
+ 'undecided)
+ (set (make-local-variable 'font-lock-defaults)
+ '((semantic-grammar-mode-keywords
+ semantic-grammar-mode-keywords-1
+ semantic-grammar-mode-keywords-2
+ semantic-grammar-mode-keywords-3)
+ nil ;; perform string/comment fontification
+ nil ;; keywords are case sensitive.
+ ;; This puts _ & - as a word constituant,
+ ;; simplifying our keywords significantly
+ ((?_ . "w") (?- . "w"))))
+ ;; Setup Semantic to parse grammar
+ (semantic-grammar-wy--install-parser)
+ (setq semantic-lex-comment-regex ";;"
+ semantic-lex-analyzer 'semantic-grammar-lexer
+ semantic-type-relation-separator-character '(":")
+ semantic-symbol->name-assoc-list
+ '(
+ (code . "Setup Code")
+ (keyword . "Keyword")
+ (token . "Token")
+ (nonterminal . "Nonterminal")
+ (rule . "Rule")
+ ))
+ (set (make-local-variable 'semantic-format-face-alist)
+ '(
+ (code . default)
+ (keyword . font-lock-keyword-face)
+ (token . font-lock-type-face)
+ (nonterminal . font-lock-function-name-face)
+ (rule . default)
+ ))
+ (set (make-local-variable 'semantic-stickyfunc-sticky-classes)
+ '(nonterminal))
+ ;; Before each change, clear the cached regexp used to highlight
+ ;; macros local in this grammar.
+ (semantic-make-local-hook 'before-change-functions)
+ (add-hook 'before-change-functions
+ 'semantic--grammar-clear-macros-regexp-2 nil t)
+ ;; Handle safe re-parse of grammar rules.
+ (semantic-make-local-hook 'semantic-edits-new-change-hooks)
+ (add-hook 'semantic-edits-new-change-hooks
+ 'semantic-grammar-edits-new-change-hook-fcn
+ nil t)
+ (semantic-run-mode-hooks 'semantic-grammar-mode-hook))
+
+;;;;
+;;;; Useful commands
+;;;;
+
+(defvar semantic-grammar-skip-quoted-syntax-table
+ (let ((st (copy-syntax-table semantic-grammar-syntax-table)))
+ (modify-syntax-entry ?\' "$" st)
+ st)
+ "Syntax table to skip a whole quoted expression in grammar code.
+Consider quote as a \"paired delimiter\", so `forward-sexp' will skip
+whole quoted expression.")
+
+(defsubst semantic-grammar-backward-item ()
+ "Move point to beginning of the previous grammar item."
+ (forward-comment (- (point-max)))
+ (if (zerop (skip-syntax-backward "."))
+ (if (eq (char-before) ?\')
+ (with-syntax-table
+ ;; Can't be Lisp code here! Temporarily consider quote
+ ;; as a "paired delimiter", so `forward-sexp' can skip
+ ;; the whole quoted expression.
+ semantic-grammar-skip-quoted-syntax-table
+ (forward-sexp -1))
+ (forward-sexp -1))))
+
+(defun semantic-grammar-anchored-indentation ()
+ "Return indentation based on previous anchor character found."
+ (let (indent)
+ (save-excursion
+ (while (not indent)
+ (semantic-grammar-backward-item)
+ (cond
+ ((bobp)
+ (setq indent 0))
+ ((looking-at ":\\(\\s-\\|$\\)")
+ (setq indent (current-column))
+ (forward-char)
+ (skip-syntax-forward "-")
+ (if (eolp) (setq indent 2))
+ )
+ ((and (looking-at "[;%]")
+ (not (looking-at "\\<%prec\\>")))
+ (setq indent 0)
+ ))))
+ indent))
+
+(defun semantic-grammar-do-grammar-indent ()
+ "Indent a line of grammar.
+When called the point is not in Lisp code."
+ (let (indent n)
+ (save-excursion
+ (beginning-of-line)
+ (skip-syntax-forward "-")
+ (setq indent (current-column))
+ (cond
+ ((or (bobp)
+ (looking-at "\\(\\w\\|\\s_\\)+\\s-*:")
+ (and (looking-at "%")
+ (not (looking-at "%prec\\>"))))
+ (setq n 0))
+ ((looking-at ":")
+ (setq n 2))
+ ((and (looking-at ";;")
+ (save-excursion (forward-comment (point-max))
+ (looking-at ":")))
+ (setq n 1))
+ (t
+ (setq n (semantic-grammar-anchored-indentation))
+ (unless (zerop n)
+ (cond
+ ((looking-at ";;")
+ (setq n (1- n)))
+ ((looking-at "[|;]")
+ )
+ (t
+ (setq n (+ n 2)))))))
+ (when (/= n indent)
+ (beginning-of-line)
+ (delete-horizontal-space)
+ (indent-to n)))))
+
+(defvar semantic-grammar-brackets-as-parens-syntax-table
+ (let ((st (copy-syntax-table emacs-lisp-mode-syntax-table)))
+ (modify-syntax-entry ?\{ "(} " st)
+ (modify-syntax-entry ?\} "){ " st)
+ st)
+ "Syntax table that consider brackets as parenthesis.
+So `lisp-indent-line' will work inside bracket blocks.")
+
+(defun semantic-grammar-do-lisp-indent ()
+ "Maybe run the Emacs Lisp indenter on a line of code.
+Return nil if not in a Lisp expression."
+ (condition-case nil
+ (save-excursion
+ (beginning-of-line)
+ (skip-chars-forward "\t ")
+ (let ((first (point)))
+ (or (>= first (semantic-grammar-epilogue-start))
+ (up-list -1))
+ (condition-case nil
+ (while t
+ (up-list -1))
+ (error nil))
+ (beginning-of-line)
+ (save-restriction
+ (narrow-to-region (point) first)
+ (goto-char (point-max))
+ (with-syntax-table
+ ;; Temporarily consider brackets as parenthesis so
+ ;; `lisp-indent-line' can indent Lisp code inside
+ ;; brackets.
+ semantic-grammar-brackets-as-parens-syntax-table
+ (lisp-indent-line))))
+ t)
+ (error nil)))
+
+(defun semantic-grammar-indent ()
+ "Indent the current line.
+Use the Lisp or grammar indenter depending on point location."
+ (interactive)
+ (let ((orig (point))
+ first)
+ (or (semantic-grammar-do-lisp-indent)
+ (semantic-grammar-do-grammar-indent))
+ (setq first (save-excursion
+ (beginning-of-line)
+ (skip-chars-forward "\t ")
+ (point)))
+ (if (or (< orig first) (/= orig (point)))
+ (goto-char first))))
+
+(defun semantic-grammar-electric-punctuation ()
+ "Insert and reindent for the symbol just typed in."
+ (interactive)
+ (self-insert-command 1)
+ (save-excursion
+ (semantic-grammar-indent)))
+
+(defun semantic-grammar-complete ()
+ "Attempt to complete the symbol under point.
+Completion is position sensitive. If the cursor is in a match section of
+a rule, then nonterminals symbols are scanned. If the cursor is in a Lisp
+expression then Lisp symbols are completed."
+ (interactive)
+ (if (semantic-grammar-in-lisp-p)
+ ;; We are in lisp code. Do lisp completion.
+ (lisp-complete-symbol)
+ ;; We are not in lisp code. Do rule completion.
+ (let* ((nonterms (semantic-find-tags-by-class 'nonterminal
(current-buffer)))
+ (sym (car (semantic-ctxt-current-symbol)))
+ (ans (try-completion sym nonterms)))
+ (cond ((eq ans t)
+ ;; All done
+ (message "Symbols is already complete"))
+ ((and (stringp ans) (string= ans sym))
+ ;; Max matchable. Show completions.
+ (with-output-to-temp-buffer "*Completions*"
+ (display-completion-list (all-completions sym nonterms)))
+ )
+ ((stringp ans)
+ ;; Expand the completions
+ (forward-sexp -1)
+ (delete-region (point) (progn (forward-sexp 1) (point)))
+ (insert ans))
+ (t (message "No Completions."))
+ ))
+ ))
+
+(defun semantic-grammar-insert-keyword (name)
+ "Insert a new %keyword declaration with NAME.
+Assumes it is typed in with the correct casing."
+ (interactive "sKeyword: ")
+ (if (not (bolp)) (insert "\n"))
+ (insert "%keyword " (upcase name) " \"" name "\"
+%put " (upcase name) " summary
+\"\"\n")
+ (forward-char -2))
+
+;;; Macro facilities
+;;
+
+(defsubst semantic--grammar-macro-function-tag (name)
+ "Search for a function tag for the grammar macro with name NAME.
+Return the tag found or nil if not found."
+ (car (semantic-find-tags-by-class
+ 'function
+ (or (semantic-find-tags-by-name name (current-buffer))
+ (and (featurep 'semanticdb)
+ semanticdb-current-database
+ (cdar (semanticdb-find-tags-by-name name nil t)))))))
+
+(defsubst semantic--grammar-macro-lib-part (def)
+ "Return the library part of the grammar macro defined by DEF."
+ (let ((suf (format "-%s\\'" (regexp-quote (symbol-name (car def)))))
+ (fun (symbol-name (cdr def))))
+ (substring fun 0 (string-match suf fun))))
+
+(defun semantic--grammar-macro-compl-elt (def &optional full)
+ "Return a completion entry for the grammar macro defined by DEF.
+If optional argument FULL is non-nil qualify the macro name with the
+library found in DEF."
+ (let ((mac (car def))
+ (lib (semantic--grammar-macro-lib-part def)))
+ (cons (if full
+ (format "%s/%s" mac lib)
+ (symbol-name mac))
+ (list mac lib))))
+
+(defun semantic--grammar-macro-compl-dict ()
+ "Return a completion dictionnary of macro definitions."
+ (let ((defs (semantic-grammar-macros))
+ def dups dict)
+ (while defs
+ (setq def (car defs)
+ defs (cdr defs))
+ (if (or (assoc (car def) defs) (assoc (car def) dups))
+ (push def dups)
+ (push (semantic--grammar-macro-compl-elt def) dict)))
+ (while dups
+ (setq def (car dups)
+ dups (cdr dups))
+ (push (semantic--grammar-macro-compl-elt def t) dict))
+ dict))
+
+(defun semantic-grammar-find-macro-expander (macro-name library)
+ "Visit the Emacs Lisp library where a grammar macro is implemented.
+MACRO-NAME is a symbol that identifies a grammar macro.
+LIBRARY is the name (sans extension) of the Emacs Lisp library where
+to start searching the macro implementation. Lookup in included
+libraries, if necessary.
+Find a function tag (in current tags table) whose name contains MACRO-NAME.
+Select the buffer containing the tag's definition, and move point there."
+ (interactive
+ (let* ((dic (semantic--grammar-macro-compl-dict))
+ (def (assoc (completing-read "Macro: " dic nil 1) dic)))
+ (or (cdr def) '(nil nil))))
+ (when (and macro-name library)
+ (let* ((lib (format "%s.el" library))
+ (buf (find-file-noselect (or (locate-library lib t) lib)))
+ (tag (with-current-buffer buf
+ (semantic--grammar-macro-function-tag
+ (format "%s-%s" library macro-name)))))
+ (if tag
+ (progn
+ (require 'semantic/decorate)
+ (pop-to-buffer (semantic-tag-buffer tag))
+ (goto-char (semantic-tag-start tag))
+ (semantic-momentary-highlight-tag tag))
+ (pop-to-buffer buf)
+ (message "No expander found in library %s for macro %s"
+ library macro-name)))))
+
+;;; Additional help
+;;
+
+(defvar semantic-grammar-syntax-help
+ `(
+ ;; Lexical Symbols
+ ("symbol" . "Syntax: A symbol of alpha numeric and symbol characters")
+ ("number" . "Syntax: Numeric characters.")
+ ("punctuation" . "Syntax: Punctuation character.")
+ ("semantic-list" . "Syntax: A list delimited by any valid list characters")
+ ("open-paren" . "Syntax: Open Parenthesis character")
+ ("close-paren" . "Syntax: Close Parenthesis character")
+ ("string" . "Syntax: String character delimited text")
+ ("comment" . "Syntax: Comment character delimited text")
+ ;; Special Macros
+ ("EMPTY" . "Syntax: Match empty text")
+ ("ASSOC" . "Lambda Key: (ASSOC key1 value1 key2 value2 ...)")
+ ("EXPAND" . "Lambda Key: (EXPAND <list id> <rule>)")
+ ("EXPANDFULL" . "Lambda Key: (EXPANDFULL <list id> <rule>)")
+ ;; Tag Generator Macros
+ ("TAG" . "Generic Tag Generation: (TAG <name> <tag-class> [ :key value
]*)")
+ ("VARIABLE-TAG" . "(VARIABLE-TAG <name> <lang-type> <default-value> [ :key
value ]*)")
+ ("FUNCTION-TAG" . "(FUNCTION-TAG <name> <lang-type> <arg-list> [ :key
value ]*)")
+ ("TYPE-TAG" . "(TYPE-TAG <name> <lang-type> <part-list> <parents> [ :key
value ]*)")
+ ("INCLUDE-TAG" . "(INCLUDE-TAG <name> <system-flag> [ :key value ]*)")
+ ("PACKAGE-TAG" . "(PACKAGE-TAG <name> <detail> [ :key value ]*)")
+ ("CODE-TAG" . "(CODE-TAG <name> <detail> [ :key value ]*)")
+ ("ALIAS-TAG" . "(ALIAS-TAG <name> <aliasclass> <definition> [:key
value]*)")
+ ;; Special value macros
+ ("$1" . "Match Value: Value from match list in slot 1")
+ ("$2" . "Match Value: Value from match list in slot 2")
+ ("$3" . "Match Value: Value from match list in slot 3")
+ ("$4" . "Match Value: Value from match list in slot 4")
+ ("$5" . "Match Value: Value from match list in slot 5")
+ ("$6" . "Match Value: Value from match list in slot 6")
+ ("$7" . "Match Value: Value from match list in slot 7")
+ ("$8" . "Match Value: Value from match list in slot 8")
+ ("$9" . "Match Value: Value from match list in slot 9")
+ ;; Same, but with annoying , in front.
+ (",$1" . "Match Value: Value from match list in slot 1")
+ (",$2" . "Match Value: Value from match list in slot 2")
+ (",$3" . "Match Value: Value from match list in slot 3")
+ (",$4" . "Match Value: Value from match list in slot 4")
+ (",$5" . "Match Value: Value from match list in slot 5")
+ (",$6" . "Match Value: Value from match list in slot 6")
+ (",$7" . "Match Value: Value from match list in slot 7")
+ (",$8" . "Match Value: Value from match list in slot 8")
+ (",$9" . "Match Value: Value from match list in slot 9")
+ )
+ "Association of syntax elements, and the corresponding help.")
+
+(defun semantic-grammar-eldoc-get-macro-docstring (macro expander)
+ "Return a one-line docstring for the given grammar MACRO.
+EXPANDER is the name of the function that expands MACRO."
+ (require 'eldoc)
+ (if (and (eq expander (aref eldoc-last-data 0))
+ (eq 'function (aref eldoc-last-data 2)))
+ (aref eldoc-last-data 1)
+ (let ((doc (help-split-fundoc (documentation expander t) expander)))
+ (cond
+ (doc
+ (setq doc (car doc))
+ (string-match "\\`[^ )]* ?" doc)
+ (setq doc (concat "(" (substring doc (match-end 0)))))
+ (t
+ (setq doc (eldoc-function-argstring expander))))
+ (when doc
+ (setq doc
+ (eldoc-docstring-format-sym-doc
+ macro (format "==> %s %s" expander doc) 'default))
+ (eldoc-last-data-store expander doc 'function))
+ doc)))
+
+(define-mode-local-override semantic-idle-summary-current-symbol-info
+ semantic-grammar-mode ()
+ "Display additional eldoc information about grammar syntax elements.
+Syntax element is the current symbol at point.
+If it is associated a help string in `semantic-grammar-syntax-help',
+return that string.
+If it is a macro name, return a description of the associated expander
+function parameter list.
+If it is a function name, return a description of this function
+parameter list.
+It it is a variable name, return a brief (one-line) documentation
+string for the variable.
+If a default description of the current context can be obtained,
+return it.
+Otherwise return nil."
+ (require 'eldoc)
+ (let* ((elt (car (semantic-ctxt-current-symbol)))
+ (val (and elt (cdr (assoc elt semantic-grammar-syntax-help)))))
+ (when (and (not val) elt (semantic-grammar-in-lisp-p))
+ ;; Ensure to load macro definitions before doing `intern-soft'.
+ (setq val (semantic-grammar-macros)
+ elt (intern-soft elt)
+ val (and elt (cdr (assq elt val))))
+ (cond
+ ;; Grammar macro
+ ((and val (fboundp val))
+ (setq val (semantic-grammar-eldoc-get-macro-docstring elt val)))
+ ;; Function
+ ((and elt (fboundp elt))
+ (setq val (eldoc-get-fnsym-args-string elt)))
+ ;; Variable
+ ((and elt (boundp elt))
+ (setq val (eldoc-get-var-docstring elt)))
+ (t nil)))
+ (or val (semantic-idle-summary-current-symbol-info-default))))
+
+(define-mode-local-override semantic-tag-boundary-p
+ semantic-grammar-mode (tag)
+ "Return non-nil for tags that should have a boundary drawn.
+Only tags of type 'nonterminal will be so marked."
+ (let ((c (semantic-tag-class tag)))
+ (eq c 'nonterminal)))
+
+(define-mode-local-override semantic-ctxt-current-function
+ semantic-grammar-mode (&optional point)
+ "Determine the name of the current function at POINT."
+ (save-excursion
+ (and point (goto-char point))
+ (when (semantic-grammar-in-lisp-p)
+ (with-mode-local emacs-lisp-mode
+ (semantic-ctxt-current-function)))))
+
+(define-mode-local-override semantic-ctxt-current-argument
+ semantic-grammar-mode (&optional point)
+ "Determine the argument index of the called function at POINT."
+ (save-excursion
+ (and point (goto-char point))
+ (when (semantic-grammar-in-lisp-p)
+ (with-mode-local emacs-lisp-mode
+ (semantic-ctxt-current-argument)))))
+
+(define-mode-local-override semantic-ctxt-current-assignment
+ semantic-grammar-mode (&optional point)
+ "Determine the tag being assigned into at POINT."
+ (save-excursion
+ (and point (goto-char point))
+ (when (semantic-grammar-in-lisp-p)
+ (with-mode-local emacs-lisp-mode
+ (semantic-ctxt-current-assignment)))))
+
+(define-mode-local-override semantic-ctxt-current-class-list
+ semantic-grammar-mode (&optional point)
+ "Determine the class of tags that can be used at POINT."
+ (save-excursion
+ (and point (goto-char point))
+ (if (semantic-grammar-in-lisp-p)
+ (with-mode-local emacs-lisp-mode
+ (semantic-ctxt-current-class-list))
+ '(nonterminal keyword))))
+
+(define-mode-local-override semantic-ctxt-current-mode
+ semantic-grammar-mode (&optional point)
+ "Return the major mode active at POINT.
+POINT defaults to the value of point in current buffer.
+Return `emacs-lisp-mode' is POINT is within Lisp code, otherwise
+return the current major mode."
+ (save-excursion
+ (and point (goto-char point))
+ (if (semantic-grammar-in-lisp-p)
+ 'emacs-lisp-mode
+ (semantic-ctxt-current-mode-default))))
+
+(define-mode-local-override semantic-format-tag-abbreviate
+ semantic-grammar-mode (tag &optional parent color)
+ "Return a string abbreviation of TAG.
+Optional PARENT is not used.
+Optional COLOR is used to flag if color is added to the text."
+ (let ((class (semantic-tag-class tag))
+ (name (semantic-format-tag-name tag parent color)))
+ (cond
+ ((eq class 'nonterminal)
+ (concat name ":"))
+ ((eq class 'setting)
+ "%settings%")
+ ((memq class '(rule keyword))
+ name)
+ (t
+ (concat "%" (symbol-name class) " " name)))))
+
+(define-mode-local-override semantic-format-tag-summarize
+ semantic-grammar-mode (tag &optional parent color)
+ "Return a string summarizing TAG.
+Optional PARENT is not used.
+Optional argument COLOR determines if color is added to the text."
+ (let ((class (semantic-tag-class tag))
+ (name (semantic-format-tag-name tag parent color))
+ (label nil)
+ (desc nil))
+ (cond
+ ((eq class 'nonterminal)
+ (setq label "Nonterminal: "
+ desc (format
+ " with %d match lists."
+ (length (semantic-tag-components tag)))))
+ ((eq class 'keyword)
+ (setq label "Keyword: ")
+ (let (summary)
+ (semantic--find-tags-by-function
+ #'(lambda (put)
+ (unless summary
+ (setq summary (cdr (assoc "summary"
+ (semantic-tag-get-attribute
+ put :value))))))
+ ;; Get `put' tag with TAG name.
+ (semantic-find-tags-by-name-regexp
+ (regexp-quote (semantic-tag-name tag))
+ (semantic-find-tags-by-class 'put (current-buffer))))
+ (setq desc (concat " = "
+ (semantic-tag-get-attribute tag :value)
+ (if summary
+ (concat " - " (read summary))
+ "")))))
+ ((eq class 'token)
+ (setq label "Token: ")
+ (let ((val (semantic-tag-get-attribute tag :value))
+ (names (semantic-tag-get-attribute tag :rest))
+ (type (semantic-tag-type tag)))
+ (if names
+ (setq name (mapconcat 'identity (cons name names) " ")))
+ (setq desc (concat
+ (if type
+ (format " <%s>" type)
+ "")
+ (if val
+ (format "%s%S" val (if type " " ""))
+ "")))))
+ ((eq class 'assoc)
+ (setq label "Assoc: ")
+ (let ((val (semantic-tag-get-attribute tag :value))
+ (type (semantic-tag-type tag)))
+ (setq desc (concat
+ (if type
+ (format " <%s>" type)
+ "")
+ (if val
+ (concat " " (mapconcat 'identity val " "))
+ "")))))
+ (t
+ (setq desc (semantic-format-tag-abbreviate tag parent color))))
+ (if (and color label)
+ (setq label (semantic--format-colorize-text label 'label)))
+ (if (and color label desc)
+ (setq desc (semantic--format-colorize-text desc 'comment)))
+ (if label
+ (concat label name desc)
+ ;; Just a description is the abbreviated version
+ desc)))
+
+;;; Semantic Analysis
+
+(define-mode-local-override semantic-analyze-current-context
+ semantic-grammar-mode (point)
+ "Provide a semantic analysis object describing a context in a grammar."
+ (require 'semantic/analyze)
+ (if (semantic-grammar-in-lisp-p)
+ (with-mode-local emacs-lisp-mode
+ (semantic-analyze-current-context point))
+
+ (let* ((context-return nil)
+ (prefixandbounds (semantic-ctxt-current-symbol-and-bounds))
+ (prefix (car prefixandbounds))
+ (bounds (nth 2 prefixandbounds))
+ (prefixsym nil)
+ (prefixclass (semantic-ctxt-current-class-list))
+ )
+
+ ;; Do context for rules when in a match list.
+ (setq prefixsym
+ (semantic-find-first-tag-by-name
+ (car prefix)
+ (current-buffer)))
+
+ (setq context-return
+ (semantic-analyze-context
+ "context-for-semantic-grammar"
+ :buffer (current-buffer)
+ :scope nil
+ :bounds bounds
+ :prefix (if prefixsym
+ (list prefixsym)
+ prefix)
+ :prefixtypes nil
+ :prefixclass prefixclass
+ ))
+
+ context-return)))
+
+(define-mode-local-override semantic-analyze-possible-completions
+ semantic-grammar-mode (context)
+ "Return a list of possible completions based on CONTEXT."
+ (require 'semantic/analyze/complete)
+ (if (semantic-grammar-in-lisp-p)
+ (with-mode-local emacs-lisp-mode
+ (semantic-analyze-possible-completions context))
+ (save-excursion
+ (set-buffer (oref context buffer))
+ (let* ((prefix (car (oref context :prefix)))
+ (completetext (cond ((semantic-tag-p prefix)
+ (semantic-tag-name prefix))
+ ((stringp prefix)
+ prefix)
+ ((stringp (car prefix))
+ (car prefix))))
+ (tags (semantic-find-tags-for-completion completetext
+ (current-buffer))))
+ (semantic-analyze-tags-of-class-list
+ tags (oref context prefixclass)))
+ )))
+
+(provide 'semantic/grammar)
+
+;;; semantic/grammar.el ends here
Index: cedet/semantic/html.el
===================================================================
RCS file: cedet/semantic/html.el
diff -N cedet/semantic/html.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/html.el 28 Sep 2009 15:15:08 -0000 1.2
@@ -0,0 +1,260 @@
+;;; semantic/html.el --- Semantic details for html files
+
+;;; Copyright (C) 2004, 2005, 2007, 2008 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Parse HTML files and organize them in a nice way.
+;; Pay attention to anchors, including them in the tag list.
+;;
+;; Copied from the original semantic-texi.el.
+;;
+;; ToDo: Find <script> tags, and parse the contents in other
+;; parsers, such as javascript, php, shtml, or others.
+
+;;; Code:
+
+(require 'semantic)
+(require 'semantic/format)
+(require 'sgml-mode)
+
+(defvar semantic-command-separation-character)
+
+(defvar semantic-html-super-regex
+ "<\\(h[1-9]\\|title\\|script\\|body\\|a +href\\)\\>"
+ "Regular expression used to find special sections in an HTML file.")
+
+(defvar semantic-html-section-list
+ '(("title" 1)
+ ("script" 1)
+ ("body" 1)
+ ("a" 11)
+ ("h1" 2)
+ ("h2" 3)
+ ("h3" 4)
+ ("h4" 5)
+ ("h5" 6)
+ ("h6" 7)
+ ("h7" 8)
+ ("h8" 9)
+ ("h9" 10)
+ )
+ "Alist of sectioning commands and their relative level.")
+
+(define-mode-local-override semantic-parse-region
+ html-mode (&rest ignore)
+ "Parse the current html buffer for semantic tags.
+INGNORE any arguments. Always parse the whole buffer.
+Each tag returned is of the form:
+ (\"NAME\" section (:members CHILDREN))
+or
+ (\"NAME\" anchor)"
+ (mapcar 'semantic-html-expand-tag
+ (semantic-html-parse-headings)))
+
+(define-mode-local-override semantic-parse-changes
+ html-mode ()
+ "We can't parse changes for HTML mode right now."
+ (semantic-parse-tree-set-needs-rebuild))
+
+(defun semantic-html-expand-tag (tag)
+ "Expand the HTML tag TAG."
+ (let ((chil (semantic-html-components tag)))
+ (if chil
+ (semantic-tag-put-attribute
+ tag :members (mapcar 'semantic-html-expand-tag chil)))
+ (car (semantic--tag-expand tag))))
+
+(defun semantic-html-components (tag)
+ "Return components belonging to TAG."
+ (semantic-tag-get-attribute tag :members))
+
+(defun semantic-html-parse-headings ()
+ "Parse the current html buffer for all semantic tags."
+ (let ((pass1 nil))
+ ;; First search and snarf.
+ (save-excursion
+ (goto-char (point-min))
+
+ (let ((semantic--progress-reporter
+ (make-progress-reporter
+ (format "Parsing %s..."
+ (file-name-nondirectory buffer-file-name))
+ (point-min) (point-max))))
+ (while (re-search-forward semantic-html-super-regex nil t)
+ (setq pass1 (cons (match-beginning 0) pass1))
+ (progress-reporter-update semantic--progress-reporter (point)))
+ (progress-reporter-done semantic--progress-reporter)))
+
+ (setq pass1 (nreverse pass1))
+ ;; Now, make some tags while creating a set of children.
+ (car (semantic-html-recursive-combobulate-list pass1 0))
+ ))
+
+(defun semantic-html-set-endpoint (metataglist pnt)
+ "Set the end point of the first section tag in METATAGLIST to PNT.
+METATAGLIST is a list of tags in the intermediate tag format used by the
+html parser. PNT is the new point to set."
+ (let ((metatag nil))
+ (while (and metataglist
+ (not (eq (semantic-tag-class (car metataglist)) 'section)))
+ (setq metataglist (cdr metataglist)))
+ (setq metatag (car metataglist))
+ (when metatag
+ (setcar (nthcdr (1- (length metatag)) metatag) pnt)
+ metatag)))
+
+(defsubst semantic-html-new-section-tag (name members level start end)
+ "Create a semantic tag of class section.
+NAME is the name of this section.
+MEMBERS is a list of semantic tags representing the elements that make
+up this section.
+LEVEL is the levelling level.
+START and END define the location of data described by the tag."
+ (let ((anchorp (eq level 11)))
+ (append (semantic-tag name
+ (cond (anchorp 'anchor)
+ (t 'section))
+ :members members)
+ (list start (if anchorp (point) end)) )))
+
+(defun semantic-html-extract-section-name ()
+ "Extract a section name from the current buffer and point.
+Assume the cursor is in the tag representing the section we
+need the name from."
+ (save-excursion
+ ; Skip over the HTML tag.
+ (forward-sexp -1)
+ (forward-char -1)
+ (forward-sexp 1)
+ (skip-chars-forward "\n\t ")
+ (while (looking-at "<")
+ (forward-sexp 1)
+ (skip-chars-forward "\n\t ")
+ )
+ (let ((start (point))
+ (end nil))
+ (if (re-search-forward "</" nil t)
+ (progn
+ (goto-char (match-beginning 0))
+ (skip-chars-backward " \n\t")
+ (setq end (point))
+ (buffer-substring-no-properties start end))
+ ""))
+ ))
+
+(defun semantic-html-recursive-combobulate-list (sectionlist level)
+ "Rearrange SECTIONLIST to be a hierarchical tag list starting at LEVEL.
+Return the rearranged new list, with all remaining tags from
+SECTIONLIST starting at ELT 2. Sections not are not dealt with as soon as a
+tag with greater section value than LEVEL is found."
+ (let ((newl nil)
+ (oldl sectionlist)
+ (case-fold-search t)
+ tag
+ )
+ (save-excursion
+ (catch 'level-jump
+ (while oldl
+ (goto-char (car oldl))
+ (if (looking-at "<\\(\\w+\\)")
+ (let* ((word (match-string 1))
+ (levelmatch (assoc-string
+ word semantic-html-section-list t))
+ text begin tmp
+ )
+ (when (not levelmatch)
+ (error "Tag %s matched in regexp but is not in list"
+ word))
+ ;; Set begin to the right location
+ (setq begin (point))
+ ;; Get out of here if there if we made it that far.
+ (if (and levelmatch (<= (car (cdr levelmatch)) level))
+ (progn
+ (when newl
+ (semantic-html-set-endpoint newl begin))
+ (throw 'level-jump t)))
+ ;; When there is a match, the descriptive text
+ ;; consists of the rest of the line.
+ (goto-char (match-end 1))
+ (skip-chars-forward " \t")
+ (setq text (semantic-html-extract-section-name))
+ ;; Next, recurse into the body to find the end.
+ (setq tmp (semantic-html-recursive-combobulate-list
+ (cdr oldl) (car (cdr levelmatch))))
+ ;; Build a tag
+ (setq tag (semantic-html-new-section-tag
+ text (car tmp) (car (cdr levelmatch)) begin
(point-max)))
+ ;; Before appending the newtag, update the previous tag
+ ;; if it is a section tag.
+ (when newl
+ (semantic-html-set-endpoint newl begin))
+ ;; Append new tag to our master list.
+ (setq newl (cons tag newl))
+ ;; continue
+ (setq oldl (cdr tmp))
+ )
+ (error "Problem finding section in semantic/html parser"))
+ ;; (setq oldl (cdr oldl))
+ )))
+ ;; Return the list
+ (cons (nreverse newl) oldl)))
+
+(define-mode-local-override semantic-sb-tag-children-to-expand
+ html-mode (tag)
+ "The children TAG expands to."
+ (semantic-html-components tag))
+
+;;;###autoload
+(defun semantic-default-html-setup ()
+ "Set up a buffer for parsing of HTML files."
+ ;; This will use our parser.
+ (setq semantic-parser-name "HTML"
+ semantic--parse-table t
+ imenu-create-index-function 'semantic-create-imenu-index
+ semantic-command-separation-character ">"
+ semantic-type-relation-separator-character '(":")
+ semantic-symbol->name-assoc-list '((section . "Section")
+
+ )
+ semantic-imenu-expandable-tag-classes '(section)
+ semantic-imenu-bucketize-file nil
+ semantic-imenu-bucketize-type-members nil
+ senator-step-at-start-end-tag-classes '(section)
+ semantic-stickyfunc-sticky-classes '(section)
+ )
+ (semantic-install-function-overrides
+ '((tag-components . semantic-html-components)
+ )
+ t)
+ )
+
+(define-child-mode html-helper-mode html-mode
+ "`html-helper-mode' needs the same semantic support as `html-mode'.")
+
+(provide 'semantic/html)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/html"
+;; End:
+
+;;; semantic/html.el ends here
Index: cedet/semantic/ia-sb.el
===================================================================
RCS file: cedet/semantic/ia-sb.el
diff -N cedet/semantic/ia-sb.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/ia-sb.el 28 Sep 2009 15:15:08 -0000 1.2
@@ -0,0 +1,374 @@
+;;; semantic/ia-sb.el --- Speedbar analysis display interactor
+
+;;; Copyright (C) 2002, 2003, 2004, 2006, 2008, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Speedbar node for displaying derived context information.
+;;
+
+(require 'semantic/analyze)
+(require 'speedbar)
+
+;;; Code:
+(defvar semantic-ia-sb-key-map nil
+ "Keymap used when in semantic analysis display mode.")
+
+(if semantic-ia-sb-key-map
+ nil
+ (setq semantic-ia-sb-key-map (speedbar-make-specialized-keymap))
+
+ ;; Basic featuers.
+ (define-key semantic-ia-sb-key-map "\C-m" 'speedbar-edit-line)
+ (define-key semantic-ia-sb-key-map "I" 'semantic-ia-sb-show-tag-info)
+ )
+
+(defvar semantic-ia-sb-easymenu-definition
+ '( "---"
+; [ "Expand" speedbar-expand-line nil ]
+; [ "Contract" speedbar-contract-line nil ]
+ [ "Tag Information" semantic-ia-sb-show-tag-info t ]
+ [ "Jump to Tag" speedbar-edit-line t ]
+ [ "Complete" speedbar-edit-line t ]
+ )
+ "Extra menu items Analysis mode.")
+
+;; Make sure our special speedbar major mode is loaded
+(speedbar-add-expansion-list '("Analyze"
+ semantic-ia-sb-easymenu-definition
+ semantic-ia-sb-key-map
+ semantic-ia-speedbar))
+
+(speedbar-add-mode-functions-list
+ (list "Analyze"
+ ;;'(speedbar-item-info . eieio-speedbar-item-info)
+ '(speedbar-line-directory . semantic-ia-sb-line-path)))
+
+;;;###autoload
+(defun semantic-speedbar-analysis ()
+ "Start Speedbar in semantic analysis mode.
+The analyzer displays information about the current context, plus a smart
+list of possible completions."
+ (interactive)
+ ;; Make sure that speedbar is active
+ (speedbar-frame-mode 1)
+ ;; Now, throw us into Analyze mode on speedbar.
+ (speedbar-change-initial-expansion-list "Analyze")
+ )
+
+(defun semantic-ia-speedbar (directory zero)
+ "Create buttons in speedbar which define the current analysis at POINT.
+DIRECTORY is the current directory, which is ignored, and ZERO is 0."
+ (let ((analysis nil)
+ (scope nil)
+ (buffer nil)
+ (completions nil)
+ (cf (selected-frame))
+ (cnt nil)
+ (mode-local-active-mode nil)
+ )
+ ;; Try and get some sort of analysis
+ (condition-case nil
+ (progn
+ (speedbar-select-attached-frame)
+ (setq buffer (current-buffer))
+ (setq mode-local-active-mode major-mode)
+ (save-excursion
+ ;; Get the current scope
+ (setq scope (semantic-calculate-scope (point)))
+ ;; Get the analysis
+ (setq analysis (semantic-analyze-current-context (point)))
+ (setq cnt (semantic-find-tag-by-overlay))
+ (when analysis
+ (setq completions (semantic-analyze-possible-completions
analysis))
+ )
+ ))
+ (error nil))
+ (select-frame cf)
+ (save-excursion
+ (set-buffer speedbar-buffer)
+ ;; If we have something, do something spiff with it.
+ (erase-buffer)
+ (speedbar-insert-separator "Buffer/Function")
+ ;; Note to self: Turn this into an expandable file name.
+ (speedbar-make-tag-line 'bracket ? nil nil
+ (buffer-name buffer)
+ nil nil 'speedbar-file-face 0)
+
+ (when cnt
+ (semantic-ia-sb-string-list cnt
+ 'speedbar-tag-face
+ 'semantic-sb-token-jump))
+ (when analysis
+ ;; If this analyzer happens to point at a complete symbol, then
+ ;; see if we can dig up some documentation for it.
+ (semantic-ia-sb-show-doc analysis))
+
+ (when analysis
+ ;; Let different classes draw more buttons.
+ (semantic-ia-sb-more-buttons analysis)
+ (when completions
+ (speedbar-insert-separator "Completions")
+ (semantic-ia-sb-completion-list completions
+ 'speedbar-tag-face
+ 'semantic-ia-sb-complete))
+ )
+
+ ;; Show local variables
+ (when scope
+ (semantic-ia-sb-show-scope scope))
+
+ )))
+
+(defmethod semantic-ia-sb-show-doc ((context semantic-analyze-context))
+ "Show documentation about CONTEXT iff CONTEXT points at a complete symbol."
+ (let ((sym (car (reverse (oref context prefix))))
+ (doc nil))
+ (when (semantic-tag-p sym)
+ (setq doc (semantic-documentation-for-tag sym))
+ (when doc
+ (speedbar-insert-separator "Documentation")
+ (insert doc)
+ (insert "\n")
+ ))
+ ))
+
+(defun semantic-ia-sb-show-scope (scope)
+ "Show SCOPE information."
+ (let ((localvars (when scope
+ (oref scope localvar)))
+ )
+ (when localvars
+ (speedbar-insert-separator "Local Variables")
+ (semantic-ia-sb-string-list localvars
+ 'speedbar-tag-face
+ ;; This is from semantic-sb
+ 'semantic-sb-token-jump))))
+
+(defmethod semantic-ia-sb-more-buttons ((context semantic-analyze-context))
+ "Show a set of speedbar buttons specific to CONTEXT."
+ (let ((prefix (oref context prefix)))
+ (when prefix
+ (speedbar-insert-separator "Prefix")
+ (semantic-ia-sb-string-list prefix
+ 'speedbar-tag-face
+ 'semantic-sb-token-jump))
+ ))
+
+(defmethod semantic-ia-sb-more-buttons ((context
semantic-analyze-context-assignment))
+ "Show a set of speedbar buttons specific to CONTEXT."
+ (call-next-method)
+ (let ((assignee (oref context assignee)))
+ (when assignee
+ (speedbar-insert-separator "Assignee")
+ (semantic-ia-sb-string-list assignee
+ 'speedbar-tag-face
+ 'semantic-sb-token-jump))))
+
+(defmethod semantic-ia-sb-more-buttons ((context
semantic-analyze-context-functionarg))
+ "Show a set of speedbar buttons specific to CONTEXT."
+ (call-next-method)
+ (let ((func (oref context function)))
+ (when func
+ (speedbar-insert-separator "Function")
+ (semantic-ia-sb-string-list func
+ 'speedbar-tag-face
+ 'semantic-sb-token-jump)
+ ;; An index for the argument the prefix is in:
+ (let ((arg (oref context argument))
+ (args (semantic-tag-function-arguments (car func)))
+ (idx 0)
+ )
+ (speedbar-insert-separator
+ (format "Argument #%d" (oref context index)))
+ (if args
+ (semantic-ia-sb-string-list args
+ 'speedbar-tag-face
+ 'semantic-sb-token-jump
+ (oref context index)
+ 'speedbar-selected-face)
+ ;; Else, no args list, so use what the context had.
+ (semantic-ia-sb-string-list arg
+ 'speedbar-tag-face
+ 'semantic-sb-token-jump))
+ ))))
+
+(defun semantic-ia-sb-string-list (list face function &optional idx idxface)
+ "Create some speedbar buttons from LIST.
+Each button will use FACE, and be activated with FUNCTION.
+Optional IDX is an index into LIST to apply IDXFACE instead."
+ (let ((count 1))
+ (while list
+ (let* ((usefn nil)
+ (string (cond ((stringp (car list))
+ (car list))
+ ((semantic-tag-p (car list))
+ (setq usefn (semantic-tag-with-position-p (car
list)))
+ (semantic-format-tag-uml-concise-prototype (car
list)))
+ (t "<No Tag>")))
+ (localface (if (or (not idx) (/= idx count))
+ face
+ idxface))
+ )
+ (if (semantic-tag-p (car list))
+ (speedbar-make-tag-line 'angle ?i
+ 'semantic-ia-sb-tag-info (car list)
+ string (if usefn function) (car list)
localface
+ 0)
+ (speedbar-make-tag-line 'statictag ??
+ nil nil
+ string (if usefn function) (car list)
localface
+ 0))
+ (setq list (cdr list)
+ count (1+ count)))
+ )))
+
+(defun semantic-ia-sb-completion-list (list face function)
+ "Create some speedbar buttons from LIST.
+Each button will use FACE, and be activated with FUNCTION."
+ (while list
+ (let* ((documentable nil)
+ (string (cond ((stringp (car list))
+ (car list))
+ ((semantic-tag-p (car list))
+ (setq documentable t)
+ (semantic-format-tag-uml-concise-prototype (car
list)))
+ (t "foo"))))
+ (if documentable
+ (speedbar-make-tag-line 'angle ?i
+ 'semantic-ia-sb-tag-info
+ (car list)
+ string function (car list) face
+ 0)
+ (speedbar-make-tag-line 'statictag ? nil nil
+ string function (car list) face
+ 0))
+ (setq list (cdr list)))))
+
+(defun semantic-ia-sb-show-tag-info ()
+ "Display information about the tag on the current line.
+Same as clicking on the <i> button.
+See `semantic-ia-sb-tag-info' for more."
+ (interactive)
+ (let ((tok nil))
+ (save-excursion
+ (end-of-line)
+ (forward-char -1)
+ (setq tok (get-text-property (point) 'speedbar-token)))
+ (semantic-ia-sb-tag-info nil tok 0)))
+
+(defun semantic-ia-sb-tag-info (text tag indent)
+ "Display as much information as we can about tag.
+Show the information in a shrunk split-buffer and expand
+out as many details as possible.
+TEXT, TAG, and INDENT are speedbar function arguments."
+ (when (semantic-tag-p tag)
+ (unwind-protect
+ (let ((ob nil))
+ (speedbar-select-attached-frame)
+ (setq ob (current-buffer))
+ (with-output-to-temp-buffer "*Tag Information*"
+ ;; Output something about this tag:
+ (save-excursion
+ (set-buffer "*Tag Information*")
+ (goto-char (point-max))
+ (insert
+ (semantic-format-tag-prototype tag nil t)
+ "\n")
+ (let ((typetok
+ (condition-case nil
+ (save-excursion
+ (set-buffer ob)
+ ;; @todo - We need a context to derive a scope from.
+ (semantic-analyze-tag-type tag nil))
+ (error nil))))
+ (if typetok
+ (insert (semantic-format-tag-prototype
+ typetok nil t))
+ ;; No type found by the analyzer
+ ;; The below used to try and select the buffer from the last
+ ;; analysis, but since we are already in the correct buffer, I
+ ;; don't think that is needed.
+ (let ((type (semantic-tag-type tag)))
+ (cond ((semantic-tag-p type)
+ (setq type (semantic-tag-name type)))
+ ((listp type)
+ (setq type (car type))))
+ (if (semantic-lex-keyword-p type)
+ (setq typetok
+ (semantic-lex-keyword-get type 'summary))))
+ (if typetok
+ (insert typetok))
+ ))
+ ))
+ ;; Make it small
+ (shrink-window-if-larger-than-buffer
+ (get-buffer-window "*Tag Information*")))
+ (select-frame speedbar-frame))))
+
+(defun semantic-ia-sb-line-path (&optional depth)
+ "Return the file name associated with DEPTH."
+ (save-match-data
+ (let* ((tok (speedbar-line-token))
+ (buff (if (semantic-tag-buffer tok)
+ (semantic-tag-buffer tok)
+ (current-buffer))))
+ (buffer-file-name buff))))
+
+(defun semantic-ia-sb-complete (text tag indent)
+ "At point in the attached buffer, complete the symbol clicked on.
+TEXT TAG and INDENT are the details."
+ ;; Find the specified bounds from the current analysis.
+ (speedbar-select-attached-frame)
+ (unwind-protect
+ (let* ((a (semantic-analyze-current-context (point)))
+ (bounds (oref a bounds))
+ (movepoint nil)
+ )
+ (save-excursion
+ (if (and (<= (point) (cdr bounds)) (>= (point) (car bounds)))
+ (setq movepoint t))
+ (goto-char (car bounds))
+ (delete-region (car bounds) (cdr bounds))
+ (insert (semantic-tag-name tag))
+ (if movepoint (setq movepoint (point)))
+ ;; I'd like to use this to add fancy () or what not at the end
+ ;; but we need the parent file whih requires an upgrade to the
+ ;; analysis tool.
+ ;;(semantic-insert-foreign-tag tag ??))
+ )
+ (if movepoint
+ (let ((cf (selected-frame)))
+ (speedbar-select-attached-frame)
+ (goto-char movepoint)
+ (select-frame cf))))
+ (select-frame speedbar-frame)))
+
+(provide 'semantic/ia-sb)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/ia-sb"
+;; End:
+
+;;; semantic/ia-sb.el ends here
Index: cedet/semantic/ia.el
===================================================================
RCS file: cedet/semantic/ia.el
diff -N cedet/semantic/ia.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/ia.el 28 Sep 2009 15:15:08 -0000 1.2
@@ -0,0 +1,422 @@
+;;; semantic/ia.el --- Interactive Analysis functions
+
+;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;;; 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Interactive access to `semantic-analyze'.
+;;
+;; These routines are fairly simple, and show how to use the Semantic
+;; analyzer to provide things such as completion lists, summaries,
+;; locations, or documentation.
+;;
+
+;;; TODO
+;;
+;; fast-jump. For a virtual method, offer some of the possible
+;; implementations in various sub-classes.
+
+(require 'semantic/analyze)
+(require 'semantic/format)
+(require 'pulse)
+(eval-when-compile
+ (require 'semantic/analyze)
+ (require 'semantic/analyze/refs))
+
+(declare-function imenu--mouse-menu "imenu")
+
+;;; Code:
+
+;;; COMPLETION
+;;
+;; This set of routines provides some simplisting completion
+;; functions.
+
+(defcustom semantic-ia-completion-format-tag-function
+ 'semantic-prototype-nonterminal
+ "*Function used to convert a tag to a string during completion."
+ :group 'semantic
+ :type semantic-format-tag-custom-list)
+
+(defvar semantic-ia-cache nil
+ "Cache of the last completion request.
+Of the form ( POINT . COMPLETIONS ) where POINT is a location in the
+buffer where the completion was requested. COMPLETONS is the list
+of semantic tag names that provide logical completions from that
+location.")
+(make-variable-buffer-local 'semantic-ia-cache)
+
+;;; COMPLETION HELPER
+;;
+;; This overload function handles inserting a tag
+;; into a buffer for these local completion routines.
+;;
+;; By creating the functions as overloadable, it can be
+;; customized. For example, the default will put a paren "("
+;; character after function names. For Lisp, it might check
+;; to put a "(" in front of a function name.
+
+(define-overloadable-function semantic-ia-insert-tag (tag)
+ "Insert TAG into the current buffer based on completion.")
+
+(defun semantic-ia-insert-tag-default (tag)
+ "Insert TAG into the current buffer based on completion."
+ (insert (semantic-tag-name tag))
+ (let ((tt (semantic-tag-class tag)))
+ (cond ((eq tt 'function)
+ (insert "("))
+ (t nil))))
+
+(declare-function semantic-analyze-possible-completions
+ "semantic/analyze/complete")
+
+(defun semantic-ia-get-completions (context point)
+ "Fetch the completion of CONTEXT at POINT.
+Supports caching."
+ ;; Cache the current set of symbols so that we can get at
+ ;; them quickly the second time someone presses the
+ ;; complete button.
+ (let ((symbols
+ (if (and semantic-ia-cache
+ (= point (car semantic-ia-cache)))
+ (cdr semantic-ia-cache)
+ (semantic-analyze-possible-completions context))))
+ ;; Set the cache
+ (setq semantic-ia-cache (cons point symbols))
+ symbols))
+
+;;;###autoload
+(defun semantic-ia-complete-symbol (point)
+ "Complete the current symbol at POINT.
+Completion options are calculated with
`semantic-analyze-possible-completions'."
+ (interactive "d")
+ ;; Calculating completions is a two step process.
+ ;;
+ ;; The first analyzer the current context, which finds tags
+ ;; for all the stuff that may be references by the code around
+ ;; POINT.
+ ;;
+ ;; The second step derives completions from that context.
+ (let* ((a (semantic-analyze-current-context point))
+ (syms (semantic-ia-get-completions a point))
+ (pre (car (reverse (oref a prefix))))
+ )
+ ;; If PRE was actually an already completed symbol, it doesn't
+ ;; come in as a string, but as a tag instead.
+ (if (semantic-tag-p pre)
+ ;; We will try completions on it anyway.
+ (setq pre (semantic-tag-name pre)))
+ ;; Complete this symbol.
+ (if (null syms)
+ (progn
+ ;(message "No smart completions found. Trying
senator-complete-symbol.")
+ (if (semantic-analyze-context-p a)
+ ;; This is a clever hack. If we were unable to find any
+ ;; smart completions, lets divert to how senator derives
+ ;; completions.
+ ;;
+ ;; This is a way of making this fcn more useful since the
+ ;; smart completion engine sometimes failes.
+ (semantic-complete-symbol)))
+ ;; Use try completion to seek a common substring.
+ (let ((tc (try-completion (or pre "") syms)))
+ (if (and (stringp tc) (not (string= tc (or pre ""))))
+ (let ((tok (semantic-find-first-tag-by-name
+ tc syms)))
+ ;; Delete what came before...
+ (when (and (car (oref a bounds)) (cdr (oref a bounds)))
+ (delete-region (car (oref a bounds))
+ (cdr (oref a bounds)))
+ (goto-char (car (oref a bounds))))
+ ;; We have some new text. Stick it in.
+ (if tok
+ (semantic-ia-insert-tag tok)
+ (insert tc)))
+ ;; We don't have new text. Show all completions.
+ (when (cdr (oref a bounds))
+ (goto-char (cdr (oref a bounds))))
+ (with-output-to-temp-buffer "*Completions*"
+ (display-completion-list
+ (mapcar semantic-ia-completion-format-tag-function syms))
+ ))))))
+
+(defcustom semantic-ia-completion-menu-format-tag-function
+ 'semantic-uml-concise-prototype-nonterminal
+ "*Function used to convert a tag to a string during completion."
+ :group 'semantic
+ :type semantic-format-tag-custom-list)
+
+;;; Completions Tip
+;;
+;; This functions shows how to get the list of completions,
+;; to place in a tooltip. It doesn't actually do any completion.
+
+;;;###autoload
+(defun semantic-ia-complete-tip (point)
+ "Pop up a tooltip for completion at POINT."
+ (interactive "d")
+ (let* ((a (semantic-analyze-current-context point))
+ (syms (semantic-ia-get-completions a point))
+ (x (mod (- (current-column) (window-hscroll))
+ (window-width)))
+ (y (save-excursion
+ (save-restriction
+ (widen)
+ (narrow-to-region (window-start) (point))
+ (goto-char (point-min))
+ (1+ (vertical-motion (buffer-size))))))
+ (str (mapconcat #'semantic-tag-name
+ syms
+ "\n"))
+ )
+ (cond ((fboundp 'x-show-tip)
+ (x-show-tip str
+ (selected-frame)
+ nil
+ nil
+ x y)
+ )
+ (t (message str))
+ )))
+
+;;; Summary
+;;
+;; Like idle-summary-mode, this shows how to get something to
+;; show a summary on.
+
+;;;###autoload
+(defun semantic-ia-show-summary (point)
+ "Display a summary for the symbol under POINT."
+ (interactive "P")
+ (let* ((ctxt (semantic-analyze-current-context point))
+ (pf (when ctxt
+ ;; The CTXT is an EIEIO object. The below
+ ;; method will attempt to pick the most interesting
+ ;; tag associated with the current context.
+ (semantic-analyze-interesting-tag ctxt)))
+ )
+ (when pf
+ (message "%s" (semantic-format-tag-summarize pf nil t)))))
+
+;;; FAST Jump
+;;
+;; Jump to a destination based on the local context.
+;;
+;; This shows how to use the analyzer context, and the
+;; analyer references objects to choose a good destination.
+
+(defun semantic-ia--fast-jump-helper (dest)
+ "Jump to DEST, a Semantic tag.
+This helper manages the mark, buffer switching, and pulsing."
+ ;; We have a tag, but in C++, we usually get a prototype instead
+ ;; because of header files. Lets try to find the actual
+ ;; implementaion instead.
+ (when (semantic-tag-prototype-p dest)
+ (let* ((refs (semantic-analyze-tag-references dest))
+ (impl (semantic-analyze-refs-impl refs t))
+ )
+ (when impl (setq dest (car impl)))))
+
+ ;; Make sure we have a place to go...
+ (if (not (and (or (semantic-tag-with-position-p dest)
+ (semantic-tag-get-attribute dest :line))
+ (semantic-tag-file-name dest)))
+ (error "Tag %s has no buffer information"
+ (semantic-format-tag-name dest)))
+
+ ;; Once we have the tag, we can jump to it. Here
+ ;; are the key bits to the jump:
+
+ ;; 1) Push the mark, so you can pop global mark back, or
+ ;; use semantic-mru-bookmark mode to do so.
+ (push-mark)
+ (when (fboundp 'push-tag-mark)
+ (push-tag-mark))
+ ;; 2) Visits the tag.
+ (semantic-go-to-tag dest)
+ ;; 3) go-to-tag doesn't switch the buffer in the current window,
+ ;; so it is like find-file-noselect. Bring it forward.
+ (switch-to-buffer (current-buffer))
+ ;; 4) Fancy pulsing.
+ (pulse-momentary-highlight-one-line (point))
+ )
+
+(declare-function semantic-decoration-include-visit
"semantic/decorate/include")
+
+;;;###autoload
+(defun semantic-ia-fast-jump (point)
+ "Jump to the tag referred to by the code at POINT.
+Uses `semantic-analyze-current-context' output to identify an accurate
+origin of the code at point."
+ (interactive "d")
+ (let* ((ctxt (semantic-analyze-current-context point))
+ (pf (and ctxt (reverse (oref ctxt prefix))))
+ ;; In the analyzer context, the PREFIX is the list of items
+ ;; that makes up the code context at point. Thus the c++ code
+ ;; this.that().theothe
+ ;; would make a list:
+ ;; ( ("this" variable ..) ("that" function ...) "theothe")
+ ;; Where the first two elements are the semantic tags of the prefix.
+ ;;
+ ;; PF is the reverse of this list. If the first item is a string,
+ ;; then it is an incomplete symbol, thus we pick the second.
+ ;; The second cannot be a string, as that would have been an error.
+ (first (car pf))
+ (second (nth 1 pf))
+ )
+ (cond
+ ((semantic-tag-p first)
+ ;; We have a match. Just go there.
+ (semantic-ia--fast-jump-helper first))
+
+ ((semantic-tag-p second)
+ ;; Because FIRST failed, we should visit our second tag.
+ ;; HOWEVER, the tag we actually want that was only an unfound
+ ;; string may be related to some take in the datatype that belongs
+ ;; to SECOND. Thus, instead of visiting second directly, we
+ ;; can offer to find the type of SECOND, and go there.
+ (let ((secondclass (car (reverse (oref ctxt prefixtypes)))))
+ (cond
+ ((and (semantic-tag-with-position-p secondclass)
+ (y-or-n-p (format "Could not find `%s'. Jump to %s? "
+ first (semantic-tag-name secondclass))))
+ (semantic-ia--fast-jump-helper secondclass)
+ )
+ ;; If we missed out on the class of the second item, then
+ ;; just visit SECOND.
+ ((and (semantic-tag-p second)
+ (y-or-n-p (format "Could not find `%s'. Jump to %s? "
+ first (semantic-tag-name second))))
+ (semantic-ia--fast-jump-helper second)
+ ))))
+
+ ((semantic-tag-of-class-p (semantic-current-tag) 'include)
+ ;; Just borrow this cool fcn.
+ (require 'semantic/decorate/include)
+ (semantic-decoration-include-visit)
+ )
+
+ (t
+ (error "Could not find suitable jump point for %s"
+ first))
+ )))
+
+;;;###autoload
+(defun semantic-ia-fast-mouse-jump (evt)
+ "Jump to the tag referred to by the point clicked on.
+See `semantic-ia-fast-jump' for details on how it works.
+ This command is meant to be bound to a mouse event."
+ (interactive "e")
+ (semantic-ia-fast-jump
+ (save-excursion
+ (posn-set-point (event-end evt))
+ (point))))
+
+;;; DOC/DESCRIBE
+;;
+;; These routines show how to get additional information about a tag
+;; for purposes of describing or showing documentation about them.
+;;;###autoload
+(defun semantic-ia-show-doc (point)
+ "Display the code-level documentation for the symbol at POINT."
+ (interactive "d")
+ (let* ((ctxt (semantic-analyze-current-context point))
+ (pf (reverse (oref ctxt prefix)))
+ )
+ ;; If PF, the prefix is non-nil, then the last element is either
+ ;; a string (incomplete type), or a semantic TAG. If it is a TAG
+ ;; then we should be able to find DOC for it.
+ (cond
+ ((stringp (car pf))
+ (message "Incomplete symbol name."))
+ ((semantic-tag-p (car pf))
+ ;; The `semantic-documentation-for-tag' fcn is language
+ ;; specific. If it doesn't return what you expect, you may
+ ;; need to implement something for your language.
+ ;;
+ ;; The default tries to find a comment in front of the tag
+ ;; and then strings off comment prefixes.
+ (let ((doc (semantic-documentation-for-tag (car pf))))
+ (with-output-to-temp-buffer "*TAG DOCUMENTATION*"
+ (princ "Tag: ")
+ (princ (semantic-format-tag-prototype (car pf)))
+ (princ "\n")
+ (princ "\n")
+ (princ "Snarfed Documentation: ")
+ (princ "\n")
+ (princ "\n")
+ (if doc
+ (princ doc)
+ (princ " Documentation unavailable."))
+ )))
+ (t
+ (message "Unknown tag.")))
+ ))
+
+;;;###autoload
+(defun semantic-ia-describe-class (typename)
+ "Display all known parts for the datatype TYPENAME.
+If the type in question is a class, all methods and other accessible
+parts of the parent classes are displayed."
+ ;; @todo - use a fancy completing reader.
+ (interactive "sType Name: ")
+
+ ;; When looking for a tag of any name there are a couple ways to do
+ ;; it. The simple `semanticdb-find-tag-by-...' are simple, and
+ ;; you need to pass it the exact name you want.
+ ;;
+ ;; The analyzer function `semantic-analyze-tag-name' will take
+ ;; more complex names, such as the cpp symbol foo::bar::baz,
+ ;; and break it up, and dive through the namespaces.
+ (let ((class (semantic-analyze-find-tag typename)))
+
+ (when (not (semantic-tag-p class))
+ (error "Cannot find class %s" class))
+ (with-output-to-temp-buffer "*TAG DOCUMENTATION*"
+ ;; There are many semantic-format-tag-* fcns.
+ ;; The summarize routine is a fairly generic one.
+ (princ (semantic-format-tag-summarize class))
+ (princ "\n")
+ (princ " Type Members:\n")
+ ;; The type tag contains all the parts of the type.
+ ;; In complex languages with inheritance, not all the
+ ;; parts are in the tag. This analyzer fcn will traverse
+ ;; the inheritance tree, and find all the pieces that
+ ;; are inherited.
+ (let ((parts (semantic-analyze-scoped-type-parts class)))
+ (while parts
+ (princ " ")
+ (princ (semantic-format-tag-summarize (car parts)))
+ (princ "\n")
+ (setq parts (cdr parts)))
+ )
+ )))
+
+(provide 'semantic/ia)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/ia"
+;; End:
+
+;;; semantic/ia.el ends here
Index: cedet/semantic/idle.el
===================================================================
RCS file: cedet/semantic/idle.el
diff -N cedet/semantic/idle.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/idle.el 28 Sep 2009 15:15:08 -0000 1.2
@@ -0,0 +1,957 @@
+;;; idle.el --- Schedule parsing tasks in idle time
+
+;;; Copyright (C) 2003, 2004, 2005, 2006, 2008, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Originally, `semantic-auto-parse-mode' handled refreshing the
+;; tags in a buffer in idle time. Other activities can be scheduled
+;; in idle time, all of which require up-to-date tag tables.
+;; Having a specialized idle time scheduler that first refreshes
+;; the tags buffer, and then enables other idle time tasks reduces
+;; the amount of work needed. Any specialized idle tasks need not
+;; ask for a fresh tags list.
+;;
+;; NOTE ON SEMANTIC_ANALYZE
+;;
+;; Some of the idle modes use the semantic analyzer. The analyzer
+;; automatically caches the created context, so it is shared amongst
+;; all idle modes that will need it.
+
+(require 'semantic)
+(require 'semantic/ctxt)
+(require 'semantic/format)
+(require 'semantic/tag)
+(require 'timer)
+
+;; For the semantic-find-tags-by-name macro.
+(eval-when-compile (require 'semantic/find))
+
+(declare-function eldoc-message "eldoc")
+(declare-function semantic-analyze-interesting-tag "semantic/analyze")
+(declare-function semantic-complete-analyze-inline-idle "semantic/complete")
+(declare-function semanticdb-deep-find-tags-by-name "semantic/db-find")
+(declare-function semanticdb-save-all-db-idle "semantic/db")
+(declare-function semanticdb-typecache-refresh-for-buffer
"semantic/db-typecache")
+(declare-function semantic-decorate-flush-pending-decorations
+ "semantic/decorate/mode")
+(declare-function pulse-momentary-highlight-region "pulse")
+(declare-function pulse-momentary-highlight-overlay "pulse")
+(declare-function semantic-symref-hits-in-region "semantic/symref/filter")
+
+;;; Code:
+
+;;; TIMER RELATED FUNCTIONS
+;;
+(defvar semantic-idle-scheduler-timer nil
+ "Timer used to schedule tasks in idle time.")
+
+(defvar semantic-idle-scheduler-work-timer nil
+ "Timer used to schedule tasks in idle time that may take a while.")
+
+(defcustom semantic-idle-scheduler-verbose-flag nil
+ "Non-nil means that the idle scheduler should provide debug messages.
+Use this setting to debug idle activities."
+ :group 'semantic
+ :type 'boolean)
+
+(defcustom semantic-idle-scheduler-idle-time 1
+ "Time in seconds of idle before scheduling events.
+This time should be short enough to ensure that idle-scheduler will be
+run as soon as Emacs is idle."
+ :group 'semantic
+ :type 'number
+ :set (lambda (sym val)
+ (set-default sym val)
+ (when (timerp semantic-idle-scheduler-timer)
+ (cancel-timer semantic-idle-scheduler-timer)
+ (setq semantic-idle-scheduler-timer nil)
+ (semantic-idle-scheduler-setup-timers))))
+
+(defcustom semantic-idle-scheduler-work-idle-time 60
+ "Time in seconds of idle before scheduling big work.
+This time should be long enough that once any big work is started, it is
+unlikely the user would be ready to type again right away."
+ :group 'semantic
+ :type 'number
+ :set (lambda (sym val)
+ (set-default sym val)
+ (when (timerp semantic-idle-scheduler-timer)
+ (cancel-timer semantic-idle-scheduler-timer)
+ (setq semantic-idle-scheduler-timer nil)
+ (semantic-idle-scheduler-setup-timers))))
+
+(defun semantic-idle-scheduler-setup-timers ()
+ "Lazy initialization of the auto parse idle timer."
+ ;; REFRESH THIS FUNCTION for XEMACS FOIBLES
+ (or (timerp semantic-idle-scheduler-timer)
+ (setq semantic-idle-scheduler-timer
+ (run-with-idle-timer
+ semantic-idle-scheduler-idle-time t
+ #'semantic-idle-scheduler-function)))
+ (or (timerp semantic-idle-scheduler-work-timer)
+ (setq semantic-idle-scheduler-work-timer
+ (run-with-idle-timer
+ semantic-idle-scheduler-work-idle-time t
+ #'semantic-idle-scheduler-work-function)))
+ )
+
+(defun semantic-idle-scheduler-kill-timer ()
+ "Kill the auto parse idle timer."
+ (if (timerp semantic-idle-scheduler-timer)
+ (cancel-timer semantic-idle-scheduler-timer))
+ (setq semantic-idle-scheduler-timer nil))
+
+
+;;; MINOR MODE
+;;
+;; The minor mode portion of this code just sets up the minor mode
+;; which does the initial scheduling of the idle timers.
+;;
+;;;###autoload
+(defcustom global-semantic-idle-scheduler-mode nil
+ "*If non-nil, enable global use of idle-scheduler mode."
+ :group 'semantic
+ :group 'semantic-modes
+ :type 'boolean
+ :require 'semantic/idle
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (global-semantic-idle-scheduler-mode (if val 1 -1))))
+
+;;;###autoload
+(defun global-semantic-idle-scheduler-mode (&optional arg)
+ "Toggle global use of option `semantic-idle-scheduler-mode'.
+The idle scheduler with automatically reparse buffers in idle time,
+and then schedule other jobs setup with `semantic-idle-scheduler-add'.
+If ARG is positive, enable, if it is negative, disable.
+If ARG is nil, then toggle."
+ (interactive "P")
+ (setq global-semantic-idle-scheduler-mode
+ (semantic-toggle-minor-mode-globally
+ 'semantic-idle-scheduler-mode arg)))
+
+(defcustom semantic-idle-scheduler-mode-hook nil
+ "*Hook run at the end of function `semantic-idle-scheduler-mode'."
+ :group 'semantic
+ :type 'hook)
+
+(defvar semantic-idle-scheduler-mode nil
+ "Non-nil if idle-scheduler minor mode is enabled.
+Use the command `semantic-idle-scheduler-mode' to change this variable.")
+(make-variable-buffer-local 'semantic-idle-scheduler-mode)
+
+(defcustom semantic-idle-scheduler-max-buffer-size 0
+ "*Maximum size in bytes of buffers where idle-scheduler is enabled.
+If this value is less than or equal to 0, idle-scheduler is enabled in
+all buffers regardless of their size."
+ :group 'semantic
+ :type 'number)
+
+(defsubst semantic-idle-scheduler-enabled-p ()
+ "Return non-nil if idle-scheduler is enabled for this buffer.
+idle-scheduler is disabled when debugging or if the buffer size
+exceeds the `semantic-idle-scheduler-max-buffer-size' threshold."
+ (and semantic-idle-scheduler-mode
+ (not (and (boundp 'semantic-debug-enabled)
+ semantic-debug-enabled))
+ (not semantic-lex-debug)
+ (or (<= semantic-idle-scheduler-max-buffer-size 0)
+ (< (buffer-size) semantic-idle-scheduler-max-buffer-size))))
+
+(defun semantic-idle-scheduler-mode-setup ()
+ "Setup option `semantic-idle-scheduler-mode'.
+The minor mode can be turned on only if semantic feature is available
+and the current buffer was set up for parsing. When minor mode is
+enabled parse the current buffer if needed. Return non-nil if the
+minor mode is enabled."
+ (if semantic-idle-scheduler-mode
+ (if (not (and (featurep 'semantic) (semantic-active-p)))
+ (progn
+ ;; Disable minor mode if semantic stuff not available
+ (setq semantic-idle-scheduler-mode nil)
+ (error "Buffer %s was not set up idle time scheduling"
+ (buffer-name)))
+ (semantic-idle-scheduler-setup-timers)))
+ semantic-idle-scheduler-mode)
+
+;;;###autoload
+(defun semantic-idle-scheduler-mode (&optional arg)
+ "Minor mode to auto parse buffer following a change.
+When this mode is off, a buffer is only rescanned for tokens when
+some command requests the list of available tokens. When idle-scheduler
+is enabled, Emacs periodically checks to see if the buffer is out of
+date, and reparses while the user is idle (not typing.)
+
+With prefix argument ARG, turn on if positive, otherwise off. The
+minor mode can be turned on only if semantic feature is available and
+the current buffer was set up for parsing. Return non-nil if the
+minor mode is enabled."
+ (interactive
+ (list (or current-prefix-arg
+ (if semantic-idle-scheduler-mode 0 1))))
+ (setq semantic-idle-scheduler-mode
+ (if arg
+ (>
+ (prefix-numeric-value arg)
+ 0)
+ (not semantic-idle-scheduler-mode)))
+ (semantic-idle-scheduler-mode-setup)
+ (run-hooks 'semantic-idle-scheduler-mode-hook)
+ (if (interactive-p)
+ (message "idle-scheduler minor mode %sabled"
+ (if semantic-idle-scheduler-mode "en" "dis")))
+ (semantic-mode-line-update)
+ semantic-idle-scheduler-mode)
+
+(semantic-add-minor-mode 'semantic-idle-scheduler-mode
+ "ARP"
+ nil)
+
+;;; SERVICES services
+;;
+;; These are services for managing idle services.
+;;
+(defvar semantic-idle-scheduler-queue nil
+ "List of functions to execute during idle time.
+These functions will be called in the current buffer after that
+buffer has had its tags made up to date. These functions
+will not be called if there are errors parsing the
+current buffer.")
+
+(defun semantic-idle-scheduler-add (function)
+ "Schedule FUNCTION to occur during idle time."
+ (add-to-list 'semantic-idle-scheduler-queue function))
+
+(defun semantic-idle-scheduler-remove (function)
+ "Unschedule FUNCTION to occur during idle time."
+ (setq semantic-idle-scheduler-queue
+ (delete function semantic-idle-scheduler-queue)))
+
+;;; IDLE Function
+;;
+(defun semantic-idle-core-handler ()
+ "Core idle function that handles reparsing.
+And also manages services that depend on tag values."
+ (when semantic-idle-scheduler-verbose-flag
+ (message "IDLE: Core handler..."))
+ (semantic-exit-on-input 'idle-timer
+ (let* ((inhibit-quit nil)
+ (buffers (delq (current-buffer)
+ (delq nil
+ (mapcar #'(lambda (b)
+ (and (buffer-file-name b)
+ b))
+ (buffer-list)))))
+ safe ;; This safe is not used, but could be.
+ others
+ mode)
+ (when (semantic-idle-scheduler-enabled-p)
+ (save-excursion
+ ;; First, reparse the current buffer.
+ (setq mode major-mode
+ safe (semantic-safe "Idle Parse Error: %S"
+ ;(error "Goofy error 1")
+ (semantic-idle-scheduler-refresh-tags)
+ )
+ )
+ ;; Now loop over other buffers with same major mode, trying to
+ ;; update them as well. Stop on keypress.
+ (dolist (b buffers)
+ (semantic-throw-on-input 'parsing-mode-buffers)
+ (with-current-buffer b
+ (if (eq major-mode mode)
+ (and (semantic-idle-scheduler-enabled-p)
+ (semantic-safe "Idle Parse Error: %S"
+ ;(error "Goofy error")
+ (semantic-idle-scheduler-refresh-tags)))
+ (push (current-buffer) others))))
+ (setq buffers others))
+ ;; If re-parse of current buffer completed, evaluate all other
+ ;; services. Stop on keypress.
+
+ ;; NOTE ON COMMENTED SAFE HERE
+ ;; We used to not execute the services if the buffer wsa
+ ;; unparseable. We now assume that they are lexically
+ ;; safe to do, because we have marked the buffer unparseable
+ ;; if there was a problem.
+ ;;(when safe
+ (dolist (service semantic-idle-scheduler-queue)
+ (save-excursion
+ (semantic-throw-on-input 'idle-queue)
+ (when semantic-idle-scheduler-verbose-flag
+ (message "IDLE: execture service %s..." service))
+ (semantic-safe (format "Idle Service Error %s: %%S" service)
+ (funcall service))
+ (when semantic-idle-scheduler-verbose-flag
+ (message "IDLE: execture service %s...done" service))
+ )))
+ ;;)
+ ;; Finally loop over remaining buffers, trying to update them as
+ ;; well. Stop on keypress.
+ (save-excursion
+ (dolist (b buffers)
+ (semantic-throw-on-input 'parsing-other-buffers)
+ (with-current-buffer b
+ (and (semantic-idle-scheduler-enabled-p)
+ (semantic-idle-scheduler-refresh-tags)))))
+ ))
+ (when semantic-idle-scheduler-verbose-flag
+ (message "IDLE: Core handler...done")))
+
+(defun semantic-debug-idle-function ()
+ "Run the Semantic idle function with debugging turned on."
+ (interactive)
+ (let ((debug-on-error t))
+ (semantic-idle-core-handler)
+ ))
+
+(defun semantic-idle-scheduler-function ()
+ "Function run when after `semantic-idle-scheduler-idle-time'.
+This function will reparse the current buffer, and if successful,
+call additional functions registered with the timer calls."
+ (when (zerop (recursion-depth))
+ (let ((debug-on-error nil))
+ (save-match-data (semantic-idle-core-handler))
+ )))
+
+
+;;; WORK FUNCTION
+;;
+;; Unlike the shorter timer, the WORK timer will kick of tasks that
+;; may take a long time to complete.
+(defcustom semantic-idle-work-parse-neighboring-files-flag t
+ "*Non-nil means to parse files in the same dir as the current buffer.
+Disable to prevent lots of excessive parsing in idle time."
+ :group 'semantic
+ :type 'boolean)
+
+
+(defun semantic-idle-work-for-one-buffer (buffer)
+ "Do long-processing work for for BUFFER.
+Uses `semantic-safe' and returns the output.
+Returns t of all processing succeeded."
+ (save-excursion
+ (set-buffer buffer)
+ (not (and
+ ;; Just in case
+ (semantic-safe "Idle Work Parse Error: %S"
+ (semantic-idle-scheduler-refresh-tags)
+ t)
+
+ ;; Force all our include files to get read in so we
+ ;; are ready to provide good smart completion and idle
+ ;; summary information
+ (semantic-safe "Idle Work Including Error: %S"
+ ;; Get the include related path.
+ (when (and (featurep 'semantic/db) (semanticdb-minor-mode-p))
+ (require 'semantic/db-find)
+ (semanticdb-find-translate-path buffer nil)
+ )
+ t)
+
+ ;; Pre-build the typecaches as needed.
+ (semantic-safe "Idle Work Typecaching Error: %S"
+ (when (featurep 'semantic/db-typecache)
+ (semanticdb-typecache-refresh-for-buffer buffer))
+ t)
+ ))
+ ))
+
+(defun semantic-idle-work-core-handler ()
+ "Core handler for idle work processing of long running tasks.
+Visits semantic controlled buffers, and makes sure all needed
+include files have been parsed, and that the typecache is up to date.
+Uses `semantic-idle-work-for-on-buffer' to do the work."
+ (let ((errbuf nil)
+ (interrupted
+ (semantic-exit-on-input 'idle-work-timer
+ (let* ((inhibit-quit nil)
+ (cb (current-buffer))
+ (buffers (delq (current-buffer)
+ (delq nil
+ (mapcar #'(lambda (b)
+ (and (buffer-file-name b)
+ b))
+ (buffer-list)))))
+ safe errbuf)
+ ;; First, handle long tasks in the current buffer.
+ (when (semantic-idle-scheduler-enabled-p)
+ (save-excursion
+ (setq safe (semantic-idle-work-for-one-buffer (current-buffer))
+ )))
+ (when (not safe) (push (current-buffer) errbuf))
+
+ ;; Now loop over other buffers with same major mode, trying to
+ ;; update them as well. Stop on keypress.
+ (dolist (b buffers)
+ (semantic-throw-on-input 'parsing-mode-buffers)
+ (with-current-buffer b
+ (when (semantic-idle-scheduler-enabled-p)
+ (and (semantic-idle-scheduler-enabled-p)
+ (unless (semantic-idle-work-for-one-buffer
(current-buffer))
+ (push (current-buffer) errbuf)))
+ ))
+ )
+
+ (when (and (featurep 'semantic/db) (semanticdb-minor-mode-p))
+ ;; Save everything.
+ (semanticdb-save-all-db-idle)
+
+ ;; Parse up files near our active buffer
+ (when semantic-idle-work-parse-neighboring-files-flag
+ (semantic-safe "Idle Work Parse Neighboring Files: %S"
+ (set-buffer cb)
+ (semantic-idle-scheduler-work-parse-neighboring-files))
+ t)
+
+ ;; Save everything... again
+ (semanticdb-save-all-db-idle)
+ )
+
+ ;; Done w/ processing
+ nil))))
+
+ ;; Done
+ (if interrupted
+ "Interrupted"
+ (cond ((not errbuf)
+ "done")
+ ((not (cdr errbuf))
+ (format "done with 1 error in %s" (car errbuf)))
+ (t
+ (format "done with errors in %d buffers."
+ (length errbuf)))))))
+
+(defun semantic-debug-idle-work-function ()
+ "Run the Semantic idle work function with debugging turned on."
+ (interactive)
+ (let ((debug-on-error t))
+ (semantic-idle-work-core-handler)
+ ))
+
+(defun semantic-idle-scheduler-work-function ()
+ "Function run when after `semantic-idle-scheduler-work-idle-time'.
+This routine handles difficult tasks that require a lot of parsing, such as
+parsing all the header files used by our active sources, or building up complex
+datasets."
+ (when semantic-idle-scheduler-verbose-flag
+ (message "Long Work Idle Timer..."))
+ (let ((exit-type (save-match-data
+ (semantic-idle-work-core-handler))))
+ (when semantic-idle-scheduler-verbose-flag
+ (message "Long Work Idle Timer...%s" exit-type)))
+ )
+
+(defun semantic-idle-scheduler-work-parse-neighboring-files ()
+ "Parse all the files in similar directories to buffers being edited."
+ ;; Lets check to see if EDE matters.
+ (let ((ede-auto-add-method 'never))
+ (dolist (a auto-mode-alist)
+ (when (eq (cdr a) major-mode)
+ (dolist (file (directory-files default-directory t (car a) t))
+ (semantic-throw-on-input 'parsing-mode-buffers)
+ (save-excursion
+ (semanticdb-file-table-object file)
+ ))))
+ ))
+
+
+;;; REPARSING
+;;
+;; Reparsing is installed as semantic idle service.
+;; This part ALWAYS happens, and other services occur
+;; afterwards.
+
+(defvar semantic-before-idle-scheduler-reparse-hook nil
+ "Hook run before option `semantic-idle-scheduler' begins parsing.
+If any hook function throws an error, this variable is reset to nil.
+This hook is not protected from lexical errors.")
+
+(defvar semantic-after-idle-scheduler-reparse-hook nil
+ "Hook run after option `semantic-idle-scheduler' has parsed.
+If any hook function throws an error, this variable is reset to nil.
+This hook is not protected from lexical errors.")
+
+(semantic-varalias-obsolete 'semantic-before-idle-scheduler-reparse-hooks
+ 'semantic-before-idle-scheduler-reparse-hook)
+(semantic-varalias-obsolete 'semantic-after-idle-scheduler-reparse-hooks
+ 'semantic-after-idle-scheduler-reparse-hook)
+
+(defun semantic-idle-scheduler-refresh-tags ()
+ "Refreshes the current buffer's tags.
+This is called by `semantic-idle-scheduler-function' to update the
+tags in the current buffer.
+
+Return non-nil if the refresh was successful.
+Return nil if there is some sort of syntax error preventing a full
+reparse.
+
+Does nothing if the current buffer doesn't need reparsing."
+
+ (prog1
+ ;; These checks actually occur in `semantic-fetch-tags', but if we
+ ;; do them here, then all the bovination hooks are not run, and
+ ;; we save lots of time.
+ (cond
+ ;; If the buffer was previously marked unparseable,
+ ;; then don't waste our time.
+ ((semantic-parse-tree-unparseable-p)
+ nil)
+ ;; The parse tree is already ok.
+ ((semantic-parse-tree-up-to-date-p)
+ t)
+ (t
+ ;; If the buffer might need a reparse and it is safe to do so,
+ ;; give it a try.
+ (let* (;(semantic-working-type nil)
+ (inhibit-quit nil)
+ ;; (working-use-echo-area-p
+ ;; (not semantic-idle-scheduler-working-in-modeline-flag))
+ ;; (working-status-dynamic-type
+ ;; (if semantic-idle-scheduler-no-working-message
+ ;; nil
+ ;; working-status-dynamic-type))
+ ;; (working-status-percentage-type
+ ;; (if semantic-idle-scheduler-no-working-message
+ ;; nil
+ ;; working-status-percentage-type))
+ (lexically-safe t)
+ )
+ ;; Let people hook into this, but don't let them hose
+ ;; us over!
+ (condition-case nil
+ (run-hooks 'semantic-before-idle-scheduler-reparse-hook)
+ (error (setq semantic-before-idle-scheduler-reparse-hook nil)))
+
+ (unwind-protect
+ ;; Perform the parsing.
+ (progn
+ (when semantic-idle-scheduler-verbose-flag
+ (message "IDLE: reparse %s..." (buffer-name)))
+ (when (semantic-lex-catch-errors idle-scheduler
+ (save-excursion (semantic-fetch-tags))
+ nil)
+ ;; If we are here, it is because the lexical step failed,
+ ;; proably due to unterminated lists or something like that.
+
+ ;; We do nothing, and just wait for the next idle timer
+ ;; to go off. In the meantime, remember this, and make sure
+ ;; no other idle services can get executed.
+ (setq lexically-safe nil))
+ (when semantic-idle-scheduler-verbose-flag
+ (message "IDLE: reparse %s...done" (buffer-name))))
+ ;; Let people hook into this, but don't let them hose
+ ;; us over!
+ (condition-case nil
+ (run-hooks 'semantic-after-idle-scheduler-reparse-hook)
+ (error (setq semantic-after-idle-scheduler-reparse-hook nil))))
+ ;; Return if we are lexically safe (from prog1)
+ lexically-safe)))
+
+ ;; After updating the tags, handle any pending decorations for this
+ ;; buffer.
+ (require 'semantic/decorate/mode)
+ (semantic-decorate-flush-pending-decorations (current-buffer))
+ ))
+
+
+;;; IDLE SERVICES
+;;
+;; Idle Services are minor modes which enable or disable a services in
+;; the idle scheduler. Creating a new services only requires calling
+;; `semantic-create-idle-services' which does all the setup
+;; needed to create the minor mode that will enable or disable
+;; a services. The services must provide a single function.
+
+(defmacro define-semantic-idle-service (name doc &rest forms)
+ "Create a new idle services with NAME.
+DOC will be a documentation string describing FORMS.
+FORMS will be called during idle time after the current buffer's
+semantic tag information has been updated.
+This routines creates the following functions and variables:"
+ (let ((global (intern (concat "global-" (symbol-name name) "-mode")))
+ (mode (intern (concat (symbol-name name) "-mode")))
+ (hook (intern (concat (symbol-name name) "-mode-hook")))
+ (map (intern (concat (symbol-name name) "-mode-map")))
+ (setup (intern (concat (symbol-name name) "-mode-setup")))
+ (func (intern (concat (symbol-name name) "-idle-function")))
+ )
+
+ `(eval-and-compile
+ (defun ,global (&optional arg)
+ ,(concat "Toggle global use of `" (symbol-name mode) "'.
+If ARG is positive, enable, if it is negative, disable.
+If ARG is nil, then toggle.")
+ (interactive "P")
+ (setq ,global
+ (semantic-toggle-minor-mode-globally
+ ',mode arg)))
+
+ (defcustom ,global nil
+ (concat "*If non-nil, enable global use of `" (symbol-name ',mode) "'.
+" ,doc)
+ :group 'semantic
+ :group 'semantic-modes
+ :type 'boolean
+ :require 'semantic/idle
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (,global (if val 1 -1))))
+
+ (defcustom ,hook nil
+ (concat "*Hook run at the end of function `" (symbol-name ',mode) "'.")
+ :group 'semantic
+ :type 'hook)
+
+ (defvar ,map
+ (let ((km (make-sparse-keymap)))
+ km)
+ (concat "Keymap for `" (symbol-name ',mode) "'."))
+
+ (defvar ,mode nil
+ (concat "Non-nil if summary minor mode is enabled.
+Use the command `" (symbol-name ',mode) "' to change this variable."))
+ (make-variable-buffer-local ',mode)
+
+ (defun ,setup ()
+ ,(concat "Setup option `" (symbol-name mode) "'.
+The minor mode can be turned on only if semantic feature is available
+and the idle scheduler is active.
+Return non-nil if the minor mode is enabled.")
+ (if ,mode
+ (if (not (and (featurep 'semantic) (semantic-active-p)))
+ (progn
+ ;; Disable minor mode if semantic stuff not available
+ (setq ,mode nil)
+ (error "Buffer %s was not set up for parsing"
+ (buffer-name)))
+ ;; Enable the mode mode
+ (semantic-idle-scheduler-add #',func)
+ )
+ ;; Disable the mode mode
+ (semantic-idle-scheduler-remove #',func)
+ )
+ ,mode)
+
+ (defun ,mode (&optional arg)
+ ,(concat doc "
+This is a minor mode which performs actions during idle time.
+With prefix argument ARG, turn on if positive, otherwise off. The
+minor mode can be turned on only if semantic feature is available and
+the current buffer was set up for parsing. Return non-nil if the
+minor mode is enabled.")
+ (interactive
+ (list (or current-prefix-arg
+ (if ,mode 0 1))))
+ (setq ,mode
+ (if arg
+ (>
+ (prefix-numeric-value arg)
+ 0)
+ (not ,mode)))
+ (,setup)
+ (run-hooks ,hook)
+ (if (interactive-p)
+ (message "%s %sabled"
+ (symbol-name ',mode)
+ (if ,mode "en" "dis")))
+ (semantic-mode-line-update)
+ ,mode)
+
+ (semantic-add-minor-mode ',mode
+ "" ; idle schedulers are quiet?
+ ,map)
+
+ (defun ,func ()
+ ,doc
+ ,@forms)
+
+ )))
+(put 'define-semantic-idle-service 'lisp-indent-function 1)
+
+
+;;; SUMMARY MODE
+;;
+;; A mode similar to eldoc using semantic
+
+(defcustom semantic-idle-summary-function
+ 'semantic-format-tag-summarize-with-file
+ "*Function to use when displaying tag information during idle time.
+Some useful functions are found in `semantic-format-tag-functions'."
+ :group 'semantic
+ :type semantic-format-tag-custom-list)
+
+(defsubst semantic-idle-summary-find-current-symbol-tag (sym)
+ "Search for a semantic tag with name SYM in database tables.
+Return the tag found or nil if not found.
+If semanticdb is not in use, use the current buffer only."
+ (car (if (and (featurep 'semantic/db)
+ semanticdb-current-database
+ (require 'semantic/db-find))
+ (cdar (semanticdb-deep-find-tags-by-name sym))
+ (semantic-deep-find-tags-by-name sym (current-buffer)))))
+
+(defun semantic-idle-summary-current-symbol-info-brutish ()
+ "Return a string message describing the current context.
+Gets a symbol with `semantic-ctxt-current-thing' and then
+trys to find it with a deep targetted search."
+ ;; Try the current "thing".
+ (let ((sym (car (semantic-ctxt-current-thing))))
+ (when sym
+ (semantic-idle-summary-find-current-symbol-tag sym))))
+
+(defun semantic-idle-summary-current-symbol-keyword ()
+ "Return a string message describing the current symbol.
+Returns a value only if it is a keyword."
+ ;; Try the current "thing".
+ (let ((sym (car (semantic-ctxt-current-thing))))
+ (if (and sym (semantic-lex-keyword-p sym))
+ (semantic-lex-keyword-get sym 'summary))))
+
+(defun semantic-idle-summary-current-symbol-info-context ()
+ "Return a string message describing the current context.
+Use the semantic analyzer to find the symbol information."
+ (let ((analysis (condition-case nil
+ (semantic-analyze-current-context (point))
+ (error nil))))
+ (when analysis
+ (require 'semantic/analyze)
+ (semantic-analyze-interesting-tag analysis))))
+
+(defun semantic-idle-summary-current-symbol-info-default ()
+ "Return a string message describing the current context.
+This functin will disable loading of previously unloaded files
+by semanticdb as a time-saving measure."
+ (let (
+ (semanticdb-find-default-throttle
+ (if (featurep 'semantic/db-find)
+ (remq 'unloaded semanticdb-find-default-throttle)
+ nil))
+ )
+ (save-excursion
+ ;; use whicever has success first.
+ (or
+ (semantic-idle-summary-current-symbol-keyword)
+
+ (semantic-idle-summary-current-symbol-info-context)
+
+ (semantic-idle-summary-current-symbol-info-brutish)
+ ))))
+
+(defvar semantic-idle-summary-out-of-context-faces
+ '(
+ font-lock-comment-face
+ font-lock-string-face
+ font-lock-doc-string-face ; XEmacs.
+ font-lock-doc-face ; Emacs 21 and later.
+ )
+ "List of font-lock faces that indicate a useless summary context.
+Those are generally faces used to highlight comments.
+
+It might be useful to override this variable to add comment faces
+specific to a major mode. For example, in jde mode:
+
+\(defvar-mode-local jde-mode semantic-idle-summary-out-of-context-faces
+ (append (default-value 'semantic-idle-summary-out-of-context-faces)
+ '(jde-java-font-lock-doc-tag-face
+ jde-java-font-lock-link-face
+ jde-java-font-lock-bold-face
+ jde-java-font-lock-underline-face
+ jde-java-font-lock-pre-face
+ jde-java-font-lock-code-face)))")
+
+(defun semantic-idle-summary-useful-context-p ()
+ "Non-nil of we should show a summary based on context."
+ (if (and (boundp 'font-lock-mode)
+ font-lock-mode
+ (memq (get-text-property (point) 'face)
+ semantic-idle-summary-out-of-context-faces))
+ ;; The best I can think of at the moment is to disable
+ ;; in comments by detecting with font-lock.
+ nil
+ t))
+
+(define-overloadable-function semantic-idle-summary-current-symbol-info ()
+ "Return a string message describing the current context.")
+
+(make-obsolete-overload 'semantic-eldoc-current-symbol-info
+ 'semantic-idle-summary-current-symbol-info)
+
+(define-semantic-idle-service semantic-idle-summary
+ "Display a tag summary of the lexical token under the cursor.
+Call `semantic-idle-summary-current-symbol-info' for getting the
+current tag to display information."
+ (or (eq major-mode 'emacs-lisp-mode)
+ (not (semantic-idle-summary-useful-context-p))
+ (let* ((found (semantic-idle-summary-current-symbol-info))
+ (str (cond ((stringp found) found)
+ ((semantic-tag-p found)
+ (funcall semantic-idle-summary-function
+ found nil t))))
+ )
+ ;; Show the message with eldoc functions
+ (require 'eldoc)
+ (unless (and str (boundp 'eldoc-echo-area-use-multiline-p)
+ eldoc-echo-area-use-multiline-p)
+ (let ((w (1- (window-width (minibuffer-window)))))
+ (if (> (length str) w)
+ (setq str (substring str 0 w)))))
+ (eldoc-message str))))
+
+;;; Current symbol highlight
+;;
+;; This mode will use context analysis to perform highlighting
+;; of all uses of the symbol that is under the cursor.
+;;
+;; This is to mimic the Eclipse tool of a similar nature.
+(defvar semantic-idle-summary-highlight-face 'region
+ "Face used for the summary highlight.")
+
+(defun semantic-idle-summary-maybe-highlight (tag)
+ "Perhaps add highlighting onto TAG.
+TAG was found as the thing under point. If it happens to be
+visible, then highlight it."
+ (require 'pulse)
+ (let* ((region (when (and (semantic-tag-p tag)
+ (semantic-tag-with-position-p tag))
+ (semantic-tag-overlay tag)))
+ (file (when (and (semantic-tag-p tag)
+ (semantic-tag-with-position-p tag))
+ (semantic-tag-file-name tag)))
+ (buffer (when file (get-file-buffer file)))
+ ;; We use pulse, but we don't want the flashy version,
+ ;; just the stable version.
+ (pulse-flag nil)
+ )
+ (cond ((semantic-overlay-p region)
+ (save-excursion
+ (set-buffer (semantic-overlay-buffer region))
+ (goto-char (semantic-overlay-start region))
+ (when (pos-visible-in-window-p
+ (point) (get-buffer-window (current-buffer) 'visible))
+ (if (< (semantic-overlay-end region) (point-at-eol))
+ (pulse-momentary-highlight-overlay
+ region semantic-idle-summary-highlight-face)
+ ;; Not the same
+ (pulse-momentary-highlight-region
+ (semantic-overlay-start region)
+ (point-at-eol)
+ semantic-idle-summary-highlight-face)))
+ ))
+ ((vectorp region)
+ (let ((start (aref region 0))
+ (end (aref region 1)))
+ (save-excursion
+ (when buffer (set-buffer buffer))
+ ;; As a vector, we have no filename. Perhaps it is a
+ ;; local variable?
+ (when (and (<= end (point-max))
+ (pos-visible-in-window-p
+ start (get-buffer-window (current-buffer) 'visible)))
+ (goto-char start)
+ (when (re-search-forward
+ (regexp-quote (semantic-tag-name tag))
+ end t)
+ ;; This is likely it, give it a try.
+ (pulse-momentary-highlight-region
+ start (if (<= end (point-at-eol)) end
+ (point-at-eol))
+ semantic-idle-summary-highlight-face)))
+ ))))
+ nil))
+
+(define-semantic-idle-service semantic-idle-tag-highlight
+ "Highlight the tag, and references of the symbol under point.
+Call `semantic-analyze-current-context' to find the reference tag.
+Call `semantic-symref-hits-in-region' to identify local references."
+ (require 'pulse)
+ (when (semantic-idle-summary-useful-context-p)
+ (let* ((ctxt (semantic-analyze-current-context))
+ (Hbounds (when ctxt (oref ctxt bounds)))
+ (target (when ctxt (car (reverse (oref ctxt prefix)))))
+ (tag (semantic-current-tag))
+ ;; We use pulse, but we don't want the flashy version,
+ ;; just the stable version.
+ (pulse-flag nil))
+ (when ctxt
+ ;; Highlight the original tag? Protect against problems.
+ (condition-case nil
+ (semantic-idle-summary-maybe-highlight target)
+ (error nil))
+ ;; Identify all hits in this current tag.
+ (when (semantic-tag-p target)
+ (require 'semantic/symref/filter)
+ (semantic-symref-hits-in-region
+ target (lambda (start end prefix)
+ (when (/= start (car Hbounds))
+ (pulse-momentary-highlight-region
+ start end))
+ (semantic-throw-on-input 'symref-highlight)
+ )
+ (semantic-tag-start tag)
+ (semantic-tag-end tag)))
+ ))))
+
+
+;;; Completion Popup Mode
+;;
+;; This mode uses tooltips to display a (hopefully) short list of possible
+;; completions available for the text under point. It provides
+;; NO provision for actually filling in the values from those completions.
+
+(defun semantic-idle-completion-list-default ()
+ "Calculate and display a list of completions."
+ (when (semantic-idle-summary-useful-context-p)
+ ;; This mode can be fragile. Ignore problems.
+ ;; If something doesn't do what you expect, run
+ ;; the below command by hand instead.
+ (condition-case nil
+ (let (
+ ;; Don't go loading in oodles of header libraries in
+ ;; IDLE time.
+ (semanticdb-find-default-throttle
+ (if (featurep 'semantic/db-find)
+ (remq 'unloaded semanticdb-find-default-throttle)
+ nil))
+ )
+ ;; Use idle version.
+ (require 'semantic/complete)
+ (semantic-complete-analyze-inline-idle)
+ )
+ (error nil))
+ ))
+
+(define-semantic-idle-service semantic-idle-completions
+ "Display a list of possible completions in a tooltip."
+ ;; Add the ability to override sometime.
+ (semantic-idle-completion-list-default))
+
+(provide 'semantic/idle)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/idle"
+;; End:
+
+;;; semantic-idle.el ends here
Index: cedet/semantic/java.el
===================================================================
RCS file: cedet/semantic/java.el
diff -N cedet/semantic/java.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/java.el 28 Sep 2009 15:15:08 -0000 1.2
@@ -0,0 +1,462 @@
+;;; semantic/java.el --- Semantic functions for Java
+
+;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+;;; 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: David Ponce <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Common function for Java parsers.
+
+;;; Code:
+(require 'semantic)
+(require 'semantic/ctxt)
+(require 'semantic/doc)
+(require 'semantic/format)
+
+(eval-when-compile
+ (require 'semantic/find)
+ (require 'semantic/dep))
+
+
+;;; Lexical analysis
+;;
+(defconst semantic-java-number-regexp
+ (eval-when-compile
+ (concat "\\("
+ "\\<[0-9]+[.][0-9]+\\([eE][-+]?[0-9]+\\)?[fFdD]?\\>"
+ "\\|"
+ "\\<[0-9]+[.][eE][-+]?[0-9]+[fFdD]?\\>"
+ "\\|"
+ "\\<[0-9]+[.][fFdD]\\>"
+ "\\|"
+ "\\<[0-9]+[.]"
+ "\\|"
+ "[.][0-9]+\\([eE][-+]?[0-9]+\\)?[fFdD]?\\>"
+ "\\|"
+ "\\<[0-9]+[eE][-+]?[0-9]+[fFdD]?\\>"
+ "\\|"
+ "\\<0[xX][0-9a-fA-F]+[lL]?\\>"
+ "\\|"
+ "\\<[0-9]+[lLfFdD]?\\>"
+ "\\)"
+ ))
+ "Lexer regexp to match Java number terminals.
+Following is the specification of Java number literals.
+
+DECIMAL_LITERAL:
+ [1-9][0-9]*
+ ;
+HEX_LITERAL:
+ 0[xX][0-9a-fA-F]+
+ ;
+OCTAL_LITERAL:
+ 0[0-7]*
+ ;
+INTEGER_LITERAL:
+ <DECIMAL_LITERAL>[lL]?
+ | <HEX_LITERAL>[lL]?
+ | <OCTAL_LITERAL>[lL]?
+ ;
+EXPONENT:
+ [eE][+-]?[09]+
+ ;
+FLOATING_POINT_LITERAL:
+ [0-9]+[.][0-9]*<EXPONENT>?[fFdD]?
+ | [.][0-9]+<EXPONENT>?[fFdD]?
+ | [0-9]+<EXPONENT>[fFdD]?
+ | [0-9]+<EXPONENT>?[fFdD]
+ ;")
+
+;;; Parsing
+;;
+(defsubst semantic-java-dim (id)
+ "Split ID string into a pair (NAME . DIM).
+NAME is ID without trailing brackets: \"[]\".
+DIM is the dimension of NAME deduced from the number of trailing
+brackets, or 0 if there is no trailing brackets."
+ (let ((dim (string-match "\\(\\[]\\)+\\'" id)))
+ (if dim
+ (cons (substring id 0 dim)
+ (/ (length (match-string 0 id)) 2))
+ (cons id 0))))
+
+(defsubst semantic-java-type (tag)
+ "Return the type of TAG, taking care of array notation."
+ (let ((type (semantic-tag-type tag))
+ (dim (semantic-tag-get-attribute tag :dereference)))
+ (when dim
+ (while (> dim 0)
+ (setq type (concat type "[]")
+ dim (1- dim))))
+ type))
+
+(defun semantic-java-expand-tag (tag)
+ "Expand compound declarations found in TAG into separate tags.
+TAG contains compound declarations when its class is `variable', and
+its name is a list of elements (NAME START . END), where NAME is a
+compound variable name, and START/END are the bounds of the
+corresponding compound declaration."
+ (let* ((class (semantic-tag-class tag))
+ (elts (semantic-tag-name tag))
+ dim type dim0 elt clone start end xpand)
+ (cond
+ ((and (eq class 'function)
+ (> (cdr (setq dim (semantic-java-dim elts))) 0))
+ (setq clone (semantic-tag-clone tag (car dim))
+ xpand (cons clone xpand))
+ (semantic-tag-put-attribute clone :dereference (cdr dim)))
+ ((eq class 'variable)
+ (or (consp elts) (setq elts (list (list elts))))
+ (setq dim (semantic-java-dim (semantic-tag-get-attribute tag :type))
+ type (car dim)
+ dim0 (cdr dim))
+ (while elts
+ ;; For each compound element, clone the initial tag with the
+ ;; name and bounds of the compound variable declaration.
+ (setq elt (car elts)
+ elts (cdr elts)
+ start (if elts (cadr elt) (semantic-tag-start tag))
+ end (if xpand (cddr elt) (semantic-tag-end tag))
+ dim (semantic-java-dim (car elt))
+ clone (semantic-tag-clone tag (car dim))
+ xpand (cons clone xpand))
+ (semantic-tag-put-attribute clone :type type)
+ (semantic-tag-put-attribute clone :dereference (+ dim0 (cdr dim)))
+ (semantic-tag-set-bounds clone start end)))
+ )
+ xpand))
+
+;;; Environment
+;;
+(defcustom-mode-local-semantic-dependency-system-include-path
+ java-mode semantic-java-dependency-system-include-path
+ ;; @todo - Use JDEE to get at the include path, or something else?
+ nil
+ "The system include path used by Java langauge.")
+
+;; Local context
+;;
+(define-mode-local-override semantic-ctxt-scoped-types
+ java-mode (&optional point)
+ "Return a list of type names currently in scope at POINT."
+ (mapcar 'semantic-tag-name
+ (semantic-find-tags-by-class
+ 'type (semantic-find-tag-by-overlay point))))
+
+;; Prototype handler
+;;
+(defun semantic-java-prototype-function (tag &optional parent color)
+ "Return a function (method) prototype for TAG.
+Optional argument PARENT is a parent (containing) item.
+Optional argument COLOR indicates that color should be mixed in.
+See also `semantic-format-tag-prototype'."
+ (let ((name (semantic-tag-name tag))
+ (type (semantic-java-type tag))
+ (tmpl (semantic-tag-get-attribute tag :template-specifier))
+ (args (semantic-tag-function-arguments tag))
+ (argp "")
+ arg argt)
+ (while args
+ (setq arg (car args)
+ args (cdr args))
+ (if (semantic-tag-p arg)
+ (setq argt (if color
+ (semantic--format-colorize-text
+ (semantic-java-type arg) 'type)
+ (semantic-java-type arg))
+ argp (concat argp argt (if args "," "")))))
+ (when color
+ (when type
+ (setq type (semantic--format-colorize-text type 'type)))
+ (setq name (semantic--format-colorize-text name 'function)))
+ (concat (or tmpl "") (if tmpl " " "")
+ (or type "") (if type " " "")
+ name "(" argp ")")))
+
+(defun semantic-java-prototype-variable (tag &optional parent color)
+ "Return a variable (field) prototype for TAG.
+Optional argument PARENT is a parent (containing) item.
+Optional argument COLOR indicates that color should be mixed in.
+See also `semantic-format-tag-prototype'."
+ (let ((name (semantic-tag-name tag))
+ (type (semantic-java-type tag)))
+ (concat (if color
+ (semantic--format-colorize-text type 'type)
+ type)
+ " "
+ (if color
+ (semantic--format-colorize-text name 'variable)
+ name))))
+
+(defun semantic-java-prototype-type (tag &optional parent color)
+ "Return a type (class/interface) prototype for TAG.
+Optional argument PARENT is a parent (containing) item.
+Optional argument COLOR indicates that color should be mixed in.
+See also `semantic-format-tag-prototype'."
+ (let ((name (semantic-tag-name tag))
+ (type (semantic-tag-type tag))
+ (tmpl (semantic-tag-get-attribute tag :template-specifier)))
+ (concat type " "
+ (if color
+ (semantic--format-colorize-text name 'type)
+ name)
+ (or tmpl ""))))
+
+(define-mode-local-override semantic-format-tag-prototype
+ java-mode (tag &optional parent color)
+ "Return a prototype for TOKEN.
+Optional argument PARENT is a parent (containing) item.
+Optional argument COLOR indicates that color should be mixed in."
+ (let ((f (intern-soft (format "semantic-java-prototype-%s"
+ (semantic-tag-class tag)))))
+ (funcall (if (fboundp f)
+ f
+ 'semantic-format-tag-prototype-default)
+ tag parent color)))
+
+(semantic-alias-obsolete 'semantic-java-prototype-nonterminal
+ 'semantic-format-tag-prototype-java-mode)
+
+;; Include Tag Name
+;;
+
+;; Thanks Bruce Stephens
+(define-mode-local-override semantic-tag-include-filename java-mode (tag)
+ "Return a suitable path for (some) Java imports"
+ (let ((name (semantic-tag-name tag)))
+ (concat (mapconcat 'identity (split-string name "\\.") "/") ".java")))
+
+
+;; Documentation handler
+;;
+(defsubst semantic-java-skip-spaces-backward ()
+ "Move point backward, skipping Java whitespaces."
+ (skip-chars-backward " \n\r\t"))
+
+(defsubst semantic-java-skip-spaces-forward ()
+ "Move point forward, skipping Java whitespaces."
+ (skip-chars-forward " \n\r\t"))
+
+(define-mode-local-override semantic-documentation-for-tag
+ java-mode (&optional tag nosnarf)
+ "Find documentation from TAG and return it as a clean string.
+Java have documentation set in a comment preceeding TAG's definition.
+Attempt to strip out comment syntactic sugar, unless optional argument
+NOSNARF is non-nil.
+If NOSNARF is 'lex, then return the semantic lex token."
+ (when (or tag (setq tag (semantic-current-tag)))
+ (with-current-buffer (semantic-tag-buffer tag)
+ (save-excursion
+ ;; Move the point at token start
+ (goto-char (semantic-tag-start tag))
+ (semantic-java-skip-spaces-forward)
+ ;; If the point already at "/**" (this occurs after a doc fix)
+ (if (looking-at "/\\*\\*")
+ nil
+ ;; Skip previous spaces
+ (semantic-java-skip-spaces-backward)
+ ;; Ensure point is after "*/" (javadoc block comment end)
+ (condition-case nil
+ (backward-char 2)
+ (error nil))
+ (when (looking-at "\\*/")
+ ;; Move the point backward across the comment
+ (forward-char 2) ; return just after "*/"
+ (forward-comment -1) ; to skip the entire block
+ ))
+ ;; Verify the point is at "/**" (javadoc block comment start)
+ (if (looking-at "/\\*\\*")
+ (let ((p (point))
+ (c (semantic-doc-snarf-comment-for-tag 'lex)))
+ (when c
+ ;; Verify that the token just following the doc
+ ;; comment is the current one!
+ (goto-char (semantic-lex-token-end c))
+ (semantic-java-skip-spaces-forward)
+ (when (eq tag (semantic-current-tag))
+ (goto-char p)
+ (semantic-doc-snarf-comment-for-tag nosnarf)))))
+ ))))
+
+;;; Javadoc facilities
+;;
+
+;; Javadoc elements
+;;
+(defvar semantic-java-doc-line-tags nil
+ "Valid javadoc line tags.
+Ordered following Sun's Tag Convention at
+<http://java.sun.com/products/jdk/javadoc/writingdoccomments/index.html>")
+
+(defvar semantic-java-doc-with-name-tags nil
+ "Javadoc tags which have a name.")
+
+(defvar semantic-java-doc-with-ref-tags nil
+ "Javadoc tags which have a reference.")
+
+;; Optional javadoc tags by classes of semantic tag
+;;
+(defvar semantic-java-doc-extra-type-tags nil
+ "Optional tags used in class/interface documentation.
+Ordered following Sun's Tag Convention.")
+
+(defvar semantic-java-doc-extra-function-tags nil
+ "Optional tags used in method/constructor documentation.
+Ordered following Sun's Tag Convention.")
+
+(defvar semantic-java-doc-extra-variable-tags nil
+ "Optional tags used in field documentation.
+Ordered following Sun's Tag Convention.")
+
+;; All javadoc tags by classes of semantic tag
+;;
+(defvar semantic-java-doc-type-tags nil
+ "Tags allowed in class/interface documentation.
+Ordered following Sun's Tag Convention.")
+
+(defvar semantic-java-doc-function-tags nil
+ "Tags allowed in method/constructor documentation.
+Ordered following Sun's Tag Convention.")
+
+(defvar semantic-java-doc-variable-tags nil
+ "Tags allowed in field documentation.
+Ordered following Sun's Tag Convention.")
+
+;; Access to Javadoc elements
+;;
+(defmacro semantic-java-doc-tag (name)
+ "Return doc tag from NAME.
+That is @NAME."
+ `(concat "@" ,name))
+
+(defsubst semantic-java-doc-tag-name (tag)
+ "Return name of the doc TAG symbol.
+That is TAG `symbol-name' without the leading '@'."
+ (substring (symbol-name tag) 1))
+
+(defun semantic-java-doc-keyword-before-p (k1 k2)
+ "Return non-nil if javadoc keyword K1 is before K2."
+ (let* ((t1 (semantic-java-doc-tag k1))
+ (t2 (semantic-java-doc-tag k2))
+ (seq1 (and (semantic-lex-keyword-p t1)
+ (plist-get (semantic-lex-keyword-get t1 'javadoc)
+ 'seq)))
+ (seq2 (and (semantic-lex-keyword-p t2)
+ (plist-get (semantic-lex-keyword-get t2 'javadoc)
+ 'seq))))
+ (if (and (numberp seq1) (numberp seq2))
+ (<= seq1 seq2)
+ ;; Unknown tags (probably custom ones) are always after official
+ ;; ones and are not themselves ordered.
+ (or (numberp seq1)
+ (and (not seq1) (not seq2))))))
+
+(defun semantic-java-doc-keywords-map (fun &optional property)
+ "Run function FUN for each javadoc keyword.
+Return the list of FUN results. If optional PROPERTY is non nil only
+call FUN for javadoc keyword which have a value for PROPERTY. FUN
+receives two arguments: the javadoc keyword and its associated
+'javadoc property list. It can return any value. Nil values are
+removed from the result list."
+ (delq nil
+ (mapcar
+ #'(lambda (k)
+ (let* ((tag (semantic-java-doc-tag k))
+ (plist (semantic-lex-keyword-get tag 'javadoc)))
+ (if (or (not property) (plist-get plist property))
+ (funcall fun k plist))))
+ semantic-java-doc-line-tags)))
+
+
+;;; Mode setup
+;;
+
+(defun semantic-java-doc-setup ()
+ "Lazy initialization of javadoc elements."
+ (or semantic-java-doc-line-tags
+ (setq semantic-java-doc-line-tags
+ (sort (mapcar #'semantic-java-doc-tag-name
+ (semantic-lex-keywords 'javadoc))
+ #'semantic-java-doc-keyword-before-p)))
+
+ (or semantic-java-doc-with-name-tags
+ (setq semantic-java-doc-with-name-tags
+ (semantic-java-doc-keywords-map
+ #'(lambda (k p)
+ k)
+ 'with-name)))
+
+ (or semantic-java-doc-with-ref-tags
+ (setq semantic-java-doc-with-ref-tags
+ (semantic-java-doc-keywords-map
+ #'(lambda (k p)
+ k)
+ 'with-ref)))
+
+ (or semantic-java-doc-extra-type-tags
+ (setq semantic-java-doc-extra-type-tags
+ (semantic-java-doc-keywords-map
+ #'(lambda (k p)
+ (if (memq 'type (plist-get p 'usage))
+ k))
+ 'opt)))
+
+ (or semantic-java-doc-extra-function-tags
+ (setq semantic-java-doc-extra-function-tags
+ (semantic-java-doc-keywords-map
+ #'(lambda (k p)
+ (if (memq 'function (plist-get p 'usage))
+ k))
+ 'opt)))
+
+ (or semantic-java-doc-extra-variable-tags
+ (setq semantic-java-doc-extra-variable-tags
+ (semantic-java-doc-keywords-map
+ #'(lambda (k p)
+ (if (memq 'variable (plist-get p 'usage))
+ k))
+ 'opt)))
+
+ (or semantic-java-doc-type-tags
+ (setq semantic-java-doc-type-tags
+ (semantic-java-doc-keywords-map
+ #'(lambda (k p)
+ (if (memq 'type (plist-get p 'usage))
+ k)))))
+
+ (or semantic-java-doc-function-tags
+ (setq semantic-java-doc-function-tags
+ (semantic-java-doc-keywords-map
+ #'(lambda (k p)
+ (if (memq 'function (plist-get p 'usage))
+ k)))))
+
+ (or semantic-java-doc-variable-tags
+ (setq semantic-java-doc-variable-tags
+ (semantic-java-doc-keywords-map
+ #'(lambda (k p)
+ (if (memq 'variable (plist-get p 'usage))
+ k)))))
+
+ )
+
+(provide 'semantic/java)
+
+;;; semantic/java.el ends here
Index: cedet/semantic/lex-spp.el
===================================================================
RCS file: cedet/semantic/lex-spp.el
diff -N cedet/semantic/lex-spp.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/lex-spp.el 28 Sep 2009 15:15:08 -0000 1.2
@@ -0,0 +1,1198 @@
+;;; lex-spp.el --- Semantic Lexical Pre-processor
+
+;;; Copyright (C) 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; The Semantic Preprocessor works with semantic-lex to provide a phase
+;; during lexical analysis to do the work of a pre-processor.
+;;
+;; A pre-processor identifies lexical syntax mixed in with another language
+;; and replaces some keyword tokens with streams of alternate tokens.
+;;
+;; If you use SPP in your language, be sure to specify this in your
+;; semantic language setup function:
+;;
+;; (add-hook 'semantic-lex-reset-hooks 'semantic-lex-spp-reset-hook nil t)
+;;
+;;
+;; Special Lexical Tokens:
+;;
+;; There are several special lexical tokens that are used by the
+;; Semantic PreProcessor lexer. They are:
+;;
+;; Declarations:
+;; spp-macro-def - A definition of a lexical macro.
+;; spp-macro-undef - A removal of a definition of a lexical macro.
+;; spp-system-include - A system level include file
+;; spp-include - An include file
+;; spp-concat - A lexical token representing textual concatenation
+;; of symbol parts.
+;;
+;; Operational tokens:
+;; spp-arg-list - Represents an argument list to a macro.
+;; spp-symbol-merge - A request for multiple symbols to be textually merged.
+;;
+;;; TODO:
+;;
+;; Use `semantic-push-parser-warning' for situations where there are likely
+;; macros that are undefined unexpectedly, or other problem.
+;;
+;; TODO:
+;;
+;; Try to handle the case of:
+;;
+;; #define NN namespace nn {
+;; #define NN_END }
+;;
+;; NN
+;; int mydecl() {}
+;; NN_END
+;;
+
+(require 'semantic)
+(require 'semantic/lex)
+
+;;; Code:
+(defvar semantic-lex-spp-macro-symbol-obarray nil
+ "Table of macro keywords used by the Semantic Preprocessor.
+These symbols will be used in addition to those in
+`semantic-lex-spp-dynamic-macro-symbol-obarray'.")
+(make-variable-buffer-local 'semantic-lex-spp-macro-symbol-obarray)
+
+(defvar semantic-lex-spp-project-macro-symbol-obarray nil
+ "Table of macro keywords for this project.
+These symbols will be used in addition to those in
+`semantic-lex-spp-dynamic-macro-symbol-obarray'.")
+(make-variable-buffer-local 'semantic-lex-spp-project-macro-symbol-obarray)
+
+(defvar semantic-lex-spp-dynamic-macro-symbol-obarray nil
+ "Table of macro keywords used during lexical analysis.
+Macros are lexical symbols which are replaced by other lexical
+tokens during lexical analysis. During analysis symbols can be
+added and removed from this symbol table.")
+(make-variable-buffer-local 'semantic-lex-spp-dynamic-macro-symbol-obarray)
+
+(defvar semantic-lex-spp-dynamic-macro-symbol-obarray-stack nil
+ "A stack of obarrays for temporarilly scoped macro values.")
+(make-variable-buffer-local
'semantic-lex-spp-dynamic-macro-symbol-obarray-stack)
+
+(defvar semantic-lex-spp-expanded-macro-stack nil
+ "The stack of lexical SPP macros we have expanded.")
+;; The above is not buffer local. Some macro expansions need to be
+;; dumped into a secondary buffer for re-lexing.
+
+;;; NON-RECURSIVE MACRO STACK
+;; C Pre-processor does not allow recursive macros. Here are some utils
+;; for managing the symbol stack of where we've been.
+
+(defmacro semantic-lex-with-macro-used (name &rest body)
+ "With the macro NAME currently being expanded, execute BODY.
+Pushes NAME into the macro stack. The above stack is checked
+by `semantic-lex-spp-symbol' to not return true for any symbol
+currently being expanded."
+ `(unwind-protect
+ (progn
+ (push ,name semantic-lex-spp-expanded-macro-stack)
+ ,@body)
+ (pop semantic-lex-spp-expanded-macro-stack)))
+(put 'semantic-lex-with-macro-used 'lisp-indent-function 1)
+
+(add-hook
+ 'edebug-setup-hook
+ #'(lambda ()
+
+ (def-edebug-spec semantic-lex-with-macro-used
+ (symbolp def-body)
+ )
+
+ ))
+
+;;; MACRO TABLE UTILS
+;;
+;; The dynamic macro table is a buffer local variable that is modified
+;; during the analysis. OBARRAYs are used, so the language must
+;; have symbols that are compatible with Emacs Lisp symbols.
+;;
+(defsubst semantic-lex-spp-symbol (name)
+ "Return spp symbol with NAME or nil if not found.
+The searcy priority is:
+ 1. DYNAMIC symbols
+ 2. PROJECT specified symbols.
+ 3. SYSTEM specified symbols."
+ (and
+ ;; Only strings...
+ (stringp name)
+ ;; Make sure we don't recurse.
+ (not (member name semantic-lex-spp-expanded-macro-stack))
+ ;; Do the check of the various tables.
+ (or
+ ;; DYNAMIC
+ (and (arrayp semantic-lex-spp-dynamic-macro-symbol-obarray)
+ (intern-soft name semantic-lex-spp-dynamic-macro-symbol-obarray))
+ ;; PROJECT
+ (and (arrayp semantic-lex-spp-project-macro-symbol-obarray)
+ (intern-soft name semantic-lex-spp-project-macro-symbol-obarray))
+ ;; SYSTEM
+ (and (arrayp semantic-lex-spp-macro-symbol-obarray)
+ (intern-soft name semantic-lex-spp-macro-symbol-obarray))
+ ;; ...
+ )))
+
+(defsubst semantic-lex-spp-symbol-p (name)
+ "Return non-nil if a keyword with NAME exists in any keyword table."
+ (if (semantic-lex-spp-symbol name)
+ t))
+
+(defsubst semantic-lex-spp-dynamic-map ()
+ "Return the dynamic macro map for the current buffer."
+ (or semantic-lex-spp-dynamic-macro-symbol-obarray
+ (setq semantic-lex-spp-dynamic-macro-symbol-obarray
+ (make-vector 13 0))))
+
+(defsubst semantic-lex-spp-dynamic-map-stack ()
+ "Return the dynamic macro map for the current buffer."
+ (or semantic-lex-spp-dynamic-macro-symbol-obarray-stack
+ (setq semantic-lex-spp-dynamic-macro-symbol-obarray-stack
+ (make-vector 13 0))))
+
+(defun semantic-lex-spp-symbol-set (name value &optional obarray-in)
+ "Set value of spp symbol with NAME to VALUE and return VALUE.
+If optional OBARRAY-IN is non-nil, then use that obarray instead of
+the dynamic map."
+ (if (and (stringp value) (string= value "")) (setq value nil))
+ (set (intern name (or obarray-in
+ (semantic-lex-spp-dynamic-map)))
+ value))
+
+(defsubst semantic-lex-spp-symbol-remove (name &optional obarray)
+ "Remove the spp symbol with NAME.
+If optional OBARRAY is non-nil, then use that obarray instead of
+the dynamic map."
+ (unintern name (or obarray
+ (semantic-lex-spp-dynamic-map))))
+
+(defun semantic-lex-spp-symbol-push (name value)
+ "Push macro NAME with VALUE into the map.
+Reverse with `semantic-lex-spp-symbol-pop'."
+ (let* ((map (semantic-lex-spp-dynamic-map))
+ (stack (semantic-lex-spp-dynamic-map-stack))
+ (mapsym (intern name map))
+ (stacksym (intern name stack))
+ (mapvalue (when (boundp mapsym) (symbol-value mapsym)))
+ )
+ (when (boundp mapsym)
+ ;; Make sure there is a stack
+ (if (not (boundp stacksym)) (set stacksym nil))
+ ;; If there is a value to push, then push it.
+ (set stacksym (cons mapvalue (symbol-value stacksym)))
+ )
+ ;; Set our new value here.
+ (set mapsym value)
+ ))
+
+(defun semantic-lex-spp-symbol-pop (name)
+ "Pop macro NAME from the stackmap into the orig map.
+Reverse with `semantic-lex-spp-symbol-pop'."
+ (let* ((map (semantic-lex-spp-dynamic-map))
+ (stack (semantic-lex-spp-dynamic-map-stack))
+ (mapsym (intern name map))
+ (stacksym (intern name stack))
+ (oldvalue nil)
+ )
+ (if (or (not (boundp stacksym) )
+ (= (length (symbol-value stacksym)) 0))
+ ;; Nothing to pop, remove it.
+ (unintern name map)
+ ;; If there is a value to pop, then add it to the map.
+ (set mapsym (car (symbol-value stacksym)))
+ (set stacksym (cdr (symbol-value stacksym)))
+ )))
+
+(defsubst semantic-lex-spp-symbol-stream (name)
+ "Return replacement stream of macro with NAME."
+ (let ((spp (semantic-lex-spp-symbol name)))
+ (if spp
+ (symbol-value spp))))
+
+(defun semantic-lex-make-spp-table (specs)
+ "Convert spp macro list SPECS into an obarray and return it.
+SPECS must be a list of (NAME . REPLACEMENT) elements, where:
+
+NAME is the name of the spp macro symbol to define.
+REPLACEMENT a string that would be substituted in for NAME."
+
+ ;; Create the symbol hash table
+ (let ((semantic-lex-spp-macro-symbol-obarray (make-vector 13 0))
+ spec)
+ ;; fill it with stuff
+ (while specs
+ (setq spec (car specs)
+ specs (cdr specs))
+ (semantic-lex-spp-symbol-set
+ (car spec)
+ (cdr spec)
+ semantic-lex-spp-macro-symbol-obarray))
+ semantic-lex-spp-macro-symbol-obarray))
+
+(defun semantic-lex-spp-save-table ()
+ "Return a list of spp macros and values.
+The return list is meant to be saved in a semanticdb table."
+ (let (macros)
+ (when (arrayp semantic-lex-spp-dynamic-macro-symbol-obarray)
+ (mapatoms
+ #'(lambda (symbol)
+ (setq macros (cons (cons (symbol-name symbol)
+ (symbol-value symbol))
+ macros)))
+ semantic-lex-spp-dynamic-macro-symbol-obarray))
+ macros))
+
+(defun semantic-lex-spp-macros ()
+ "Return a list of spp macros as Lisp symbols.
+The value of each symbol is the replacement stream."
+ (let (macros)
+ (when (arrayp semantic-lex-spp-macro-symbol-obarray)
+ (mapatoms
+ #'(lambda (symbol)
+ (setq macros (cons symbol macros)))
+ semantic-lex-spp-macro-symbol-obarray))
+ (when (arrayp semantic-lex-spp-project-macro-symbol-obarray)
+ (mapatoms
+ #'(lambda (symbol)
+ (setq macros (cons symbol macros)))
+ semantic-lex-spp-project-macro-symbol-obarray))
+ (when (arrayp semantic-lex-spp-dynamic-macro-symbol-obarray)
+ (mapatoms
+ #'(lambda (symbol)
+ (setq macros (cons symbol macros)))
+ semantic-lex-spp-dynamic-macro-symbol-obarray))
+ macros))
+
+(defun semantic-lex-spp-set-dynamic-table (new-entries)
+ "Set the dynamic symbol table to NEW-ENTRIES.
+For use with semanticdb restoration of state."
+ (dolist (e new-entries)
+ ;; Default obarray for below is the dynamic map.
+ (semantic-lex-spp-symbol-set (car e) (cdr e))))
+
+(defun semantic-lex-spp-reset-hook (start end)
+ "Reset anything needed by SPP for parsing.
+In this case, reset the dynamic macro symbol table if
+START is (point-min).
+END is not used."
+ (when (= start (point-min))
+ (setq semantic-lex-spp-dynamic-macro-symbol-obarray nil
+ semantic-lex-spp-dynamic-macro-symbol-obarray-stack nil
+ ;; This shouldn't not be nil, but reset just in case.
+ semantic-lex-spp-expanded-macro-stack nil)
+ ))
+
+;;; MACRO EXPANSION: Simple cases
+;;
+;; If a user fills in the table with simple strings, we can
+;; support that by converting them into tokens with the
+;; various analyzers that are available.
+
+(defun semantic-lex-spp-extract-regex-and-compare (analyzer value)
+ "Extract a regexp from an ANALYZER and use to match VALUE.
+Return non-nil if it matches"
+ (let* ((condition (car analyzer))
+ (regex (cond ((eq (car condition) 'looking-at)
+ (nth 1 condition))
+ (t
+ nil))))
+ (when regex
+ (string-match regex value))
+ ))
+
+(defun semantic-lex-spp-simple-macro-to-macro-stream (val beg end argvalues)
+ "Convert lexical macro contents VAL into a macro expansion stream.
+These are for simple macro expansions that a user may have typed in directly.
+As such, we need to analyze the input text, to figure out what kind of real
+lexical token we should be inserting in its place.
+
+Argument VAL is the value of some macro to be converted into a stream.
+BEG and END are the token bounds of the macro to be expanded
+that will somehow gain a much longer token stream.
+ARGVALUES are values for any arg list, or nil."
+ (cond
+ ;; We perform a replacement. Technically, this should
+ ;; be a full lexical step over the "val" string, but take
+ ;; a guess that its just a keyword or existing symbol.
+ ;;
+ ;; Probably a really bad idea. See how it goes.
+ ((semantic-lex-spp-extract-regex-and-compare
+ semantic-lex-symbol-or-keyword val)
+ (semantic-lex-push-token
+ (semantic-lex-token (or (semantic-lex-keyword-p val) 'symbol)
+ beg end
+ val)))
+
+ ;; Ok, the rest of these are various types of syntax.
+ ;; Conveniences for users that type in their symbol table.
+ ((semantic-lex-spp-extract-regex-and-compare
+ semantic-lex-punctuation val)
+ (semantic-lex-token 'punctuation beg end val))
+ ((semantic-lex-spp-extract-regex-and-compare
+ semantic-lex-number val)
+ (semantic-lex-token 'number beg end val))
+ ((semantic-lex-spp-extract-regex-and-compare
+ semantic-lex-paren-or-list val)
+ (semantic-lex-token 'semantic-list beg end val))
+ ((semantic-lex-spp-extract-regex-and-compare
+ semantic-lex-string val)
+ (semantic-lex-token 'string beg end val))
+ (t nil)
+ ))
+
+;;; MACRO EXPANSION : Lexical token replacement
+;;
+;; When substituting in a macro from a token stream of formatted
+;; semantic lex tokens, things can be much more complicated.
+;;
+;; Some macros have arguments that get set into the dynamic macro
+;; table during replacement.
+;;
+;; In general, the macro tokens are substituted into the regular
+;; token stream, but placed under the characters of the original
+;; macro symbol.
+;;
+;; Argument lists are saved as a lexical token at the beginning
+;; of a replacement value.
+
+(defun semantic-lex-spp-one-token-to-txt (tok &optional blocktok)
+ "Convert the token TOK into a string.
+If TOK is made of multiple tokens, convert those to text. This
+conversion is needed if a macro has a merge symbol in it that
+combines the text of two previously distinct symbols. For
+exampe, in c:
+
+#define (a,b) a ## b;
+
+If optional string BLOCKTOK matches the expanded value, then do not
+continue processing recursively."
+ (let ((txt (semantic-lex-token-text tok))
+ (sym nil)
+ )
+ (cond
+ ;; Recursion prevention
+ ((and (stringp blocktok) (string= txt blocktok))
+ blocktok)
+ ;; A complex symbol
+ ((and (eq (car tok) 'symbol)
+ (setq sym (semantic-lex-spp-symbol txt))
+ (not (semantic-lex-spp-macro-with-args (symbol-value sym)))
+ )
+ ;; Now that we have a symbol,
+ (let ((val (symbol-value sym)))
+ (cond
+ ;; This is another lexical token.
+ ((and (consp val)
+ (symbolp (car val)))
+ (semantic-lex-spp-one-token-to-txt val txt))
+ ;; This is a list of tokens.
+ ((and (consp val)
+ (consp (car val))
+ (symbolp (car (car val))))
+ (mapconcat (lambda (subtok)
+ (semantic-lex-spp-one-token-to-txt subtok))
+ val
+ ""))
+ ;; If val is nil, that's probably wrong.
+ ;; Found a system header case where this was true.
+ ((null val) "")
+ ;; Debug wierd stuff.
+ (t (debug)))
+ ))
+ ((stringp txt)
+ txt)
+ (t nil))
+ ))
+
+(defun semantic-lex-spp-macro-with-args (val)
+ "If the macro value VAL has an argument list, return the arglist."
+ (when (and val (consp val) (consp (car val))
+ (eq 'spp-arg-list (car (car val))))
+ (car (cdr (car val)))))
+
+(defun semantic-lex-spp-token-macro-to-macro-stream (val beg end argvalues)
+ "Convert lexical macro contents VAL into a macro expansion stream.
+Argument VAL is the value of some macro to be converted into a stream.
+BEG and END are the token bounds of the macro to be expanded
+that will somehow gain a much longer token stream.
+ARGVALUES are values for any arg list, or nil.
+See comments in code for information about how token streams are processed
+and what valid VAL values are."
+
+ ;; A typical VAL value might be either a stream of tokens.
+ ;; Tokens saved into a macro stream always includes the text from the
+ ;; buffer, since the locations specified probably don't represent
+ ;; that text anymore, or even the same buffer.
+ ;;
+ ;; CASE 1: Simple token stream
+ ;;
+ ;; #define SUPER mysuper::
+ ;; ==>
+ ;;((symbol "mysuper" 480 . 487)
+ ;; (punctuation ":" 487 . 488)
+ ;; (punctuation ":" 488 . 489))
+ ;;
+ ;; CASE 2: Token stream with argument list
+ ;;
+ ;; #define INT_FCN(name) int name (int in)
+ ;; ==>
+ ;; ((spp-arg-list ("name") 558 . 564)
+ ;; (INT "int" 565 . 568)
+ ;; (symbol "name" 569 . 573)
+ ;; (semantic-list "(int in)" 574 . 582))
+ ;;
+ ;; In the second case, a macro with an argument list as the a rgs as the
+ ;; first entry.
+ ;;
+ ;; CASE 3: Symbol text merge
+ ;;
+ ;; #define TMP(a) foo_ ## a
+ ;; ==>
+ ;; ((spp-arg-list ("a") 20 . 23)
+ ;; (spp-symbol-merge ((symbol "foo_" 24 . 28) (symbol "a" 32 . 33))
+ ;; 24 . 33))
+ ;;
+ ;; Usually in conjunction with a macro with an argument, merging symbol
+ ;; parts is a way of fabricating new symbols from pieces inside the macro.
+ ;; These macros use `spp-symbol-merge' tokens whose TEXT part is another
+ ;; token stream. This sub-stream ought to consist of only 2 SYMBOL pieces,
+ ;; though I suppose keywords might be ok. The end result of this example
+ ;; merge symbol would be (symbol "foo_A" 24 . 33) where A is the symbol
+ ;; passed in from the arg list "a".
+ ;;
+ ;; CASE 4: Nested token streams
+ ;;
+ ;; #define FOO(f) f
+ ;; #define BLA bla FOO(foo)
+ ;; ==>
+ ;; ((INT "int" 82 . 85)
+ ;; (symbol "FOO" 86 . 89)
+ ;; (semantic-list "(foo)" 89 . 94))
+ ;;
+ ;; Nested token FOO shows up in the table of macros, and gets replace
+ ;; inline. This is the same as case 2.
+
+ (let ((arglist (semantic-lex-spp-macro-with-args val))
+ (argalist nil)
+ (val-tmp nil)
+ (v nil)
+ )
+ ;; CASE 2: Dealing with the arg list.
+ (when arglist
+ ;; Skip the arg list.
+ (setq val (cdr val))
+
+ ;; Push args into the replacement list.
+ (let ((AV argvalues))
+ (dolist (A arglist)
+ (let* ((argval (car AV)))
+
+ (semantic-lex-spp-symbol-push A argval)
+ (setq argalist (cons (cons A argval) argalist))
+ (setq AV (cdr AV)))))
+ )
+
+ ;; Set val-tmp after stripping arguments.
+ (setq val-tmp val)
+
+ ;; CASE 1: Push everything else onto the list.
+ ;; Once the arg list is stripped off, CASE 2 is the same
+ ;; as CASE 1.
+ (while val-tmp
+ (setq v (car val-tmp))
+ (setq val-tmp (cdr val-tmp))
+
+ (let* (;; The text of the current lexical token.
+ (txt (car (cdr v)))
+ ;; Try to convert txt into a macro declaration. If it is
+ ;; not a macro, use nil.
+ (txt-macro-or-nil (semantic-lex-spp-symbol txt))
+ ;; If our current token is a macro, then pull off the argument
+ ;; list.
+ (macro-and-args
+ (when txt-macro-or-nil
+ (semantic-lex-spp-macro-with-args (symbol-value
txt-macro-or-nil)))
+ )
+ ;; We need to peek at the next token when testing for
+ ;; used macros with arg lists.
+ (next-tok-class (semantic-lex-token-class (car val-tmp)))
+ )
+
+ (cond
+ ;; CASE 3: Merge symbols together.
+ ((eq (semantic-lex-token-class v) 'spp-symbol-merge)
+ ;; We need to merge the tokens in the 'text segement together,
+ ;; and produce a single symbol from it.
+ (let ((newsym
+ (mapconcat (lambda (tok)
+ (semantic-lex-spp-one-token-to-txt tok))
+ txt
+ "")))
+ (semantic-lex-push-token
+ (semantic-lex-token 'symbol beg end newsym))
+ ))
+
+ ;; CASE 2: Argument replacement. If a discovered symbol is in
+ ;; the active list of arguments, then we need to substitute
+ ;; in the new value.
+ ((and (eq (semantic-lex-token-class v) 'symbol) txt-macro-or-nil
+ (or (and macro-and-args (eq next-tok-class 'semantic-list))
+ (not macro-and-args))
+ )
+ (let ((AV nil))
+ (when macro-and-args
+ (setq AV
+ (semantic-lex-spp-stream-for-arglist (car val-tmp)))
+ ;; We used up these args. Pull from the stream.
+ (setq val-tmp (cdr val-tmp))
+ )
+
+ (semantic-lex-with-macro-used txt
+ ;; Don't recurse directly into this same fcn, because it is
+ ;; convenient to have plain string replacements too.
+ (semantic-lex-spp-macro-to-macro-stream
+ (symbol-value txt-macro-or-nil)
+ beg end AV))
+ ))
+
+ ;; This is a HACK for the C parser. The 'macros text
+ ;; property is some storage so that the parser can do
+ ;; some C specific text manipulations.
+ ((eq (semantic-lex-token-class v) 'semantic-list)
+ ;; Push our arg list onto the semantic list.
+ (when argalist
+ (setq txt (concat txt)) ; Copy the text.
+ (put-text-property 0 1 'macros argalist txt))
+ (semantic-lex-push-token
+ (semantic-lex-token (semantic-lex-token-class v) beg end txt))
+ )
+
+ ;; CASE 1: Just another token in the stream.
+ (t
+ ;; Nothing new.
+ (semantic-lex-push-token
+ (semantic-lex-token (semantic-lex-token-class v) beg end txt))
+ )
+ )))
+
+ ;; CASE 2: The arg list we pushed onto the symbol table
+ ;; must now be removed.
+ (dolist (A arglist)
+ (semantic-lex-spp-symbol-pop A))
+ ))
+
+;;; Macro Merging
+;;
+;; Used when token streams from different macros include eachother.
+;; Merged macro streams perform in place replacements.
+
+(defun semantic-lex-spp-merge-streams (raw-stream)
+ "Merge elements from the RAW-STREAM together.
+Handle spp-concat symbol concatenation.
+Handle Nested macro replacements.
+Return the cooked stream."
+ (let ((cooked-stream nil))
+ ;; Merge the stream
+ (while raw-stream
+ (cond ((eq (semantic-lex-token-class (car raw-stream)) 'spp-concat)
+ ;; handle hashhash, by skipping it.
+ (setq raw-stream (cdr raw-stream))
+ ;; Now merge the symbols.
+ (let ((prev-tok (car cooked-stream))
+ (next-tok (car raw-stream)))
+ (setq cooked-stream (cdr cooked-stream))
+ (push (semantic-lex-token
+ 'spp-symbol-merge
+ (semantic-lex-token-start prev-tok)
+ (semantic-lex-token-end next-tok)
+ (list prev-tok next-tok))
+ cooked-stream)
+ ))
+ (t
+ (push (car raw-stream) cooked-stream))
+ )
+ (setq raw-stream (cdr raw-stream))
+ )
+
+ (nreverse cooked-stream))
+ )
+
+;;; MACRO EXPANSION
+;;
+;; There are two types of expansion.
+;;
+;; 1. Expansion using a value made up of lexical tokens.
+;; 2. User input replacement from a plain string.
+
+(defun semantic-lex-spp-macro-to-macro-stream (val beg end argvalues)
+ "Convert lexical macro contents VAL into a macro expansion stream.
+Argument VAL is the value of some macro to be converted into a stream.
+BEG and END are the token bounds of the macro to be expanded
+that will somehow gain a much longer token stream.
+ARGVALUES are values for any arg list, or nil."
+ (cond
+ ;; If val is nil, then just skip it.
+ ((null val) t)
+ ;; If it is a token, then return that token rebuilt.
+ ((and (consp val) (car val) (symbolp (car val)))
+ (semantic-lex-push-token
+ (semantic-lex-token (car val) beg end (semantic-lex-token-text val))))
+ ;; Test for a token list.
+ ((and (consp val) (consp (car val)) (car (car val))
+ (symbolp (car (car val))))
+ (semantic-lex-spp-token-macro-to-macro-stream val beg end argvalues))
+ ;; Test for miscellaneous strings.
+ ((stringp val)
+ (semantic-lex-spp-simple-macro-to-macro-stream val beg end argvalues))
+ ))
+
+;;; --------------------------------------------------------
+;;;
+;;; ANALYZERS:
+;;;
+
+;;; Symbol Is Macro
+;;
+;; An analyser that will push tokens from a macro in place
+;; of the macro symbol.
+;;
+(defun semantic-lex-spp-anlyzer-do-replace (sym val beg end)
+ "Do the lexical replacement for SYM with VAL.
+Argument BEG and END specify the bounds of SYM in the buffer."
+ (if (not val)
+ (setq semantic-lex-end-point end)
+ (let ((arg-in nil)
+ (arg-parsed nil)
+ (arg-split nil)
+ )
+
+ ;; Check for arguments.
+ (setq arg-in (semantic-lex-spp-macro-with-args val))
+
+ (when arg-in
+ (save-excursion
+ (goto-char end)
+ (setq arg-parsed
+ (semantic-lex-spp-one-token-and-move-for-macro
+ (point-at-eol)))
+ (setq end (semantic-lex-token-end arg-parsed))
+
+ (when (and (listp arg-parsed) (eq (car arg-parsed) 'semantic-list))
+ (setq arg-split
+ ;; Use lex to split up the contents of the argument list.
+ (semantic-lex-spp-stream-for-arglist arg-parsed)
+ ))
+ ))
+
+ ;; if we have something to sub in, then do it.
+ (semantic-lex-spp-macro-to-macro-stream val beg end arg-split)
+ (setq semantic-lex-end-point end)
+ )
+ ))
+
+(defvar semantic-lex-spp-replacements-enabled t
+ "Non-nil means do replacements when finding keywords.
+Disable this only to prevent recursive expansion issues.")
+
+(defun semantic-lex-spp-analyzer-push-tokens-for-symbol (str beg end)
+ "Push lexical tokens for the symbol or keyword STR.
+STR occurs in the current buffer between BEG and END."
+ (let (sym val count)
+ (cond
+ ;;
+ ;; It is a macro. Prepare for a replacement.
+ ((and semantic-lex-spp-replacements-enabled
+ (semantic-lex-spp-symbol-p str))
+ (setq sym (semantic-lex-spp-symbol str)
+ val (symbol-value sym)
+ count 0)
+
+ (let ((semantic-lex-spp-expanded-macro-stack
+ semantic-lex-spp-expanded-macro-stack))
+
+ (semantic-lex-with-macro-used str
+ ;; Do direct replacements of single value macros of macros.
+ ;; This solves issues with a macro containing one symbol that
+ ;; is another macro, and get arg lists passed around.
+ (while (and val (consp val)
+ (semantic-lex-token-p (car val))
+ (eq (length val) 1)
+ (eq (semantic-lex-token-class (car val)) 'symbol)
+ (semantic-lex-spp-symbol-p (semantic-lex-token-text (car
val)))
+ (< count 10)
+ )
+ (setq str (semantic-lex-token-text (car val)))
+ (setq sym (semantic-lex-spp-symbol str)
+ val (symbol-value sym))
+ ;; Prevent recursion
+ (setq count (1+ count))
+ ;; This prevents a different kind of recursion.
+ (push str semantic-lex-spp-expanded-macro-stack)
+ )
+
+ (semantic-lex-spp-anlyzer-do-replace sym val beg end))
+
+ ))
+ ;; Anything else.
+ (t
+ ;; A regular keyword.
+ (semantic-lex-push-token
+ (semantic-lex-token (or (semantic-lex-keyword-p str) 'symbol)
+ beg end))))
+ ))
+
+(define-lex-regex-analyzer semantic-lex-spp-replace-or-symbol-or-keyword
+ "Like 'semantic-lex-symbol-or-keyword' plus preprocessor macro replacement."
+ "\\(\\sw\\|\\s_\\)+"
+ (let ((str (match-string 0))
+ (beg (match-beginning 0))
+ (end (match-end 0)))
+ (semantic-lex-spp-analyzer-push-tokens-for-symbol str beg end)))
+
+;;; ANALYZERS FOR NEW MACROS
+;;
+;; These utilities and analyzer declaration function are for
+;; creating an analyzer which produces new macros in the macro table.
+;;
+;; There are two analyzers. One for new macros, and one for removing
+;; a macro.
+
+(defun semantic-lex-spp-first-token-arg-list (token)
+ "If TOKEN is a semantic-list, turn it into a an SPP ARG LIST."
+ (when (and (consp token)
+ (symbolp (car token))
+ (eq 'semantic-list (car token)))
+ ;; Convert TOKEN in place.
+ (let ((argsplit (split-string (semantic-lex-token-text token)
+ "[(), ]" t)))
+ (setcar token 'spp-arg-list)
+ (setcar (nthcdr 1 token) argsplit))
+ ))
+
+(defun semantic-lex-spp-one-token-and-move-for-macro (max)
+ "Lex up one token, and move to end of that token.
+Don't go past MAX."
+ (let ((ans (semantic-lex (point) max 0 0)))
+ (if (not ans)
+ (progn (goto-char max)
+ nil)
+ (when (> (semantic-lex-token-end (car ans)) max)
+ (let ((bounds (semantic-lex-token-bounds (car ans))))
+ (setcdr bounds max)))
+ (goto-char (semantic-lex-token-end (car ans)))
+ (car ans))
+ ))
+
+(defun semantic-lex-spp-stream-for-arglist (token)
+ "Lex up the contents of the arglist TOKEN.
+Parsing starts inside the parens, and ends at the end of TOKEN."
+ (let ((end (semantic-lex-token-end token))
+ (fresh-toks nil)
+ (toks nil))
+ (save-excursion
+
+ (if (stringp (nth 1 token))
+ ;; If the 2nd part of the token is a string, then we have
+ ;; a token specifically extracted from a buffer. Possibly
+ ;; a different buffer. This means we need to do something
+ ;; nice to parse its contents.
+ (let ((txt (semantic-lex-token-text token)))
+ (semantic-lex-spp-lex-text-string
+ (substring txt 1 (1- (length txt)))))
+
+ ;; This part is like the original
+ (goto-char (semantic-lex-token-start token))
+ ;; A cheat for going into the semantic list.
+ (forward-char 1)
+ (setq fresh-toks (semantic-lex-spp-stream-for-macro (1- end)))
+ (dolist (tok fresh-toks)
+ (when (memq (semantic-lex-token-class tok) '(symbol semantic-list))
+ (setq toks (cons tok toks))))
+
+ (nreverse toks)))))
+
+(defvar semantic-lex-spp-hack-depth 0
+ "Current depth of recursive calls to `semantic-lex-spp-lex-text-string'.")
+
+(defun semantic-lex-spp-lex-text-string (text)
+ "Lex the text string TEXT using the current buffer's state.
+Use this to parse text extracted from a macro as if it came from
+the current buffer. Since the lexer is designed to only work in
+a buffer, we need to create a new buffer, and populate it with rules
+and variable state from the current buffer."
+ (let* ((semantic-lex-spp-hack-depth (1+ semantic-lex-spp-hack-depth))
+ (buf (get-buffer-create (format " *SPP parse hack %d*"
+ semantic-lex-spp-hack-depth)))
+ (mode major-mode)
+ (fresh-toks nil)
+ (toks nil)
+ (origbuff (current-buffer))
+ (important-vars '(semantic-lex-spp-macro-symbol-obarray
+ semantic-lex-spp-project-macro-symbol-obarray
+ semantic-lex-spp-dynamic-macro-symbol-obarray
+ semantic-lex-spp-dynamic-macro-symbol-obarray-stack
+ semantic-lex-spp-expanded-macro-stack
+ ))
+ )
+ (save-excursion
+ (set-buffer buf)
+ (erase-buffer)
+ ;; Below is a painful hack to make sure everything is setup correctly.
+ (when (not (eq major-mode mode))
+ (save-match-data
+
+ ;; Protect against user-hooks that throw errors.
+ (condition-case nil
+ (funcall mode)
+ (error nil))
+
+ ;; Hack in mode-local
+ (activate-mode-local-bindings)
+ ;; CHEATER! The following 3 lines are from
+ ;; `semantic-new-buffer-fcn', but we don't want to turn
+ ;; on all the other annoying modes for this little task.
+ (setq semantic-new-buffer-fcn-was-run t)
+ (semantic-lex-init)
+ (semantic-clear-toplevel-cache)
+ (remove-hook 'semantic-lex-reset-hooks 'semantic-lex-spp-reset-hook
+ t)
+ ))
+
+ ;; Second Cheat: copy key variables regarding macro state from the
+ ;; the originating buffer we are parsing. We need to do this every time
+ ;; since the state changes.
+ (dolist (V important-vars)
+ (set V (semantic-buffer-local-value V origbuff)))
+ (insert text)
+ (goto-char (point-min))
+
+ (setq fresh-toks (semantic-lex-spp-stream-for-macro (point-max))))
+
+ (dolist (tok fresh-toks)
+ (when (memq (semantic-lex-token-class tok) '(symbol semantic-list))
+ (setq toks (cons tok toks))))
+
+ (nreverse toks)))
+
+;;;; FIRST DRAFT
+;; This is the fist version of semantic-lex-spp-stream-for-arglist
+;; that worked pretty well. It doesn't work if the TOKEN was derived
+;; from some other buffer, in which case it can get the wrong answer
+;; or throw an error if the token location in the originating buffer is
+;; larger than the current buffer.
+;;(defun semantic-lex-spp-stream-for-arglist-orig (token)
+;; "Lex up the contents of the arglist TOKEN.
+;; Parsing starts inside the parens, and ends at the end of TOKEN."
+;; (save-excursion
+;; (let ((end (semantic-lex-token-end token))
+;; (fresh-toks nil)
+;; (toks nil))
+;; (goto-char (semantic-lex-token-start token))
+;; ;; A cheat for going into the semantic list.
+;; (forward-char 1)
+;; (setq fresh-toks (semantic-lex-spp-stream-for-macro (1- end)))
+;; (dolist (tok fresh-toks)
+;; (when (memq (semantic-lex-token-class tok) '(symbol semantic-list))
+;; (setq toks (cons tok toks))))
+;; (nreverse toks))
+;; ))
+
+;;;; USING SPLIT
+;; This doesn't work, because some arguments passed into a macro
+;; might contain non-simple symbol words, which this doesn't handle.
+;;
+;; Thus, you need a full lex to occur.
+;; (defun semantic-lex-spp-stream-for-arglist-split (token)
+;; "Lex up the contents of the arglist TOKEN.
+;; Parsing starts inside the parens, and ends at the end of TOKEN."
+;; (let* ((txt (semantic-lex-token-text token))
+;; (split (split-string (substring txt 1 (1- (length txt)))
+;; "(), " t))
+;; ;; Hack for lexing.
+;; (semantic-lex-spp-analyzer-push-tokens-for-symbol nil))
+;; (dolist (S split)
+;; (semantic-lex-spp-analyzer-push-tokens-for-symbol S 0 1))
+;; (reverse semantic-lex-spp-analyzer-push-tokens-for-symbol)))
+
+
+(defun semantic-lex-spp-stream-for-macro (eos)
+ "Lex up a stream of tokens for a #define statement.
+Parsing starts at the current point location.
+EOS is the end of the stream to lex for this macro."
+ (let ((stream nil))
+ (while (< (point) eos)
+ (let* ((tok (semantic-lex-spp-one-token-and-move-for-macro eos))
+ (str (when tok
+ (semantic-lex-token-text tok)))
+ )
+ (if str
+ (push (semantic-lex-token (semantic-lex-token-class tok)
+ (semantic-lex-token-start tok)
+ (semantic-lex-token-end tok)
+ str)
+ stream)
+ ;; Nothing to push.
+ nil)))
+ (goto-char eos)
+ ;; Fix the order
+ (nreverse stream)
+ ))
+
+(defmacro define-lex-spp-macro-declaration-analyzer (name doc regexp tokidx
+ &rest valform)
+ "Define a lexical analyzer for defining new MACROS.
+NAME is the name of the analyzer.
+DOC is the documentation for the analyzer.
+REGEXP is a regular expression for the analyzer to match.
+See `define-lex-regex-analyzer' for more on regexp.
+TOKIDX is an index into REGEXP for which a new lexical token
+of type `spp-macro-def' is to be created.
+VALFORM are forms that return the value to be saved for this macro, or nil.
+When implementing a macro, you can use `semantic-lex-spp-stream-for-macro'
+to convert text into a lexical stream for storage in the macro."
+ (let ((start (make-symbol "start"))
+ (end (make-symbol "end"))
+ (val (make-symbol "val"))
+ (startpnt (make-symbol "startpnt"))
+ (endpnt (make-symbol "endpnt")))
+ `(define-lex-regex-analyzer ,name
+ ,doc
+ ,regexp
+ (let ((,start (match-beginning ,tokidx))
+ (,end (match-end ,tokidx))
+ (,startpnt semantic-lex-end-point)
+ (,val (save-match-data ,@valform))
+ (,endpnt semantic-lex-end-point))
+ (semantic-lex-spp-symbol-set
+ (buffer-substring-no-properties ,start ,end)
+ ,val)
+ (semantic-lex-push-token
+ (semantic-lex-token 'spp-macro-def
+ ,start ,end))
+ ;; Preserve setting of the end point from the calling macro.
+ (when (and (/= ,startpnt ,endpnt)
+ (/= ,endpnt semantic-lex-end-point))
+ (setq semantic-lex-end-point ,endpnt))
+ ))))
+
+(defmacro define-lex-spp-macro-undeclaration-analyzer (name doc regexp tokidx)
+ "Undefine a lexical analyzer for defining new MACROS.
+NAME is the name of the analyzer.
+DOC is the documentation for the analyzer.
+REGEXP is a regular expression for the analyzer to match.
+See `define-lex-regex-analyzer' for more on regexp.
+TOKIDX is an index into REGEXP for which a new lexical token
+of type `spp-macro-undef' is to be created."
+ (let ((start (make-symbol "start"))
+ (end (make-symbol "end")))
+ `(define-lex-regex-analyzer ,name
+ ,doc
+ ,regexp
+ (let ((,start (match-beginning ,tokidx))
+ (,end (match-end ,tokidx))
+ )
+ (semantic-lex-spp-symbol-remove
+ (buffer-substring-no-properties ,start ,end))
+ (semantic-lex-push-token
+ (semantic-lex-token 'spp-macro-undef
+ ,start ,end))
+ ))))
+
+;;; INCLUDES
+;;
+;; These analyzers help a language define how include files
+;; are identified. These are ONLY for languages that perform
+;; an actual textual includesion, and not for imports.
+;;
+;; This section is supposed to allow the macros from the headers to be
+;; added to the local dynamic macro table, but that hasn't been
+;; written yet.
+;;
+(defcustom semantic-lex-spp-use-headers-flag nil
+ "*Non-nil means to pre-parse headers as we go.
+For languages that use the Semantic pre-processor, this can
+improve the accuracy of parsed files where include files
+can change the state of what's parsed in the current file.
+
+Note: Note implemented yet"
+ :group 'semantic
+ :type 'boolean)
+
+(defun semantic-lex-spp-merge-header (name)
+ "Extract and merge any macros from the header with NAME.
+Finds the header file belonging to NAME, gets the macros
+from that file, and then merge the macros with our current
+symbol table."
+ (when semantic-lex-spp-use-headers-flag
+ ;; @todo - do this someday, ok?
+ ))
+
+(defmacro define-lex-spp-include-analyzer (name doc regexp tokidx
+ &rest valform)
+ "Define a lexical analyzer for defining a new INCLUDE lexical token.
+Macros defined in the found include will be added to our running table
+at the time the include statement is found.
+NAME is the name of the analyzer.
+DOC is the documentation for the analyzer.
+REGEXP is a regular expression for the analyzer to match.
+See `define-lex-regex-analyzer' for more on regexp.
+TOKIDX is an index into REGEXP for which a new lexical token
+of type `spp-macro-include' is to be created.
+VALFORM are forms that return the name of the thing being included, and the
+type of include. The return value should be of the form:
+ (NAME . TYPE)
+where NAME is the name of the include, and TYPE is the type of the include,
+where a valid symbol is 'system, or nil."
+ (let ((start (make-symbol "start"))
+ (end (make-symbol "end"))
+ (val (make-symbol "val"))
+ (startpnt (make-symbol "startpnt"))
+ (endpnt (make-symbol "endpnt")))
+ `(define-lex-regex-analyzer ,name
+ ,doc
+ ,regexp
+ (let ((,start (match-beginning ,tokidx))
+ (,end (match-end ,tokidx))
+ (,startpnt semantic-lex-end-point)
+ (,val (save-match-data ,@valform))
+ (,endpnt semantic-lex-end-point))
+ ;;(message "(car ,val) -> %S" (car ,val))
+ (semantic-lex-spp-merge-header (car ,val))
+ (semantic-lex-push-token
+ (semantic-lex-token (if (eq (cdr ,val) 'system)
+ 'spp-system-include
+ 'spp-include)
+ ,start ,end
+ (car ,val)))
+ ;; Preserve setting of the end point from the calling macro.
+ (when (and (/= ,startpnt ,endpnt)
+ (/= ,endpnt semantic-lex-end-point))
+ (setq semantic-lex-end-point ,endpnt))
+ ))))
+
+;;; EIEIO USAGE
+;;
+;; Semanticdb can save off macro tables for quick lookup later.
+;;
+;; These routines are for saving macro lists into an EIEIO persistent
+;; file.
+(defvar semantic-lex-spp-macro-max-length-to-save 200
+ "*Maximum length of an SPP macro before we opt to not save it.")
+
+;;;###autoload
+(defun semantic-lex-spp-table-write-slot-value (value)
+ "Write out the VALUE of a slot for EIEIO.
+The VALUE is a spp lexical table."
+ (if (not value)
+ (princ "nil")
+ (princ "\n '(")
+ ;(princ value)
+ (dolist (sym value)
+ (princ "(")
+ (prin1 (car sym))
+ (let* ((first (car (cdr sym)))
+ (rest (cdr sym)))
+ (when (not (listp first))
+ (error "Error in macro \"%s\"" (car sym)))
+ (when (eq (car first) 'spp-arg-list)
+ (princ " ")
+ (prin1 first)
+ (setq rest (cdr rest))
+ )
+
+ (when rest
+ (princ " . ")
+ (let ((len (length (cdr rest))))
+ (cond ((< len 2)
+ (condition-case nil
+ (prin1 rest)
+ (error
+ (princ "nil ;; Error writing macro\n"))))
+ ((< len semantic-lex-spp-macro-max-length-to-save)
+ (princ "\n ")
+ (condition-case nil
+ (prin1 rest)
+ (error
+ (princ "nil ;; Error writing macro\n ")))
+ )
+ (t ;; Too Long!
+ (princ "nil ;; Too Long!\n ")
+ ))))
+ )
+ (princ ")\n ")
+ )
+ (princ ")\n"))
+)
+
+;;; MACRO TABLE DEBUG
+;;
+(defun semantic-lex-spp-describe (&optional buffer)
+ "Describe the current list of spp macros for BUFFER.
+If BUFFER is not provided, use the current buffer."
+ (interactive)
+ (let ((syms (save-excursion
+ (if buffer (set-buffer buffer))
+ (semantic-lex-spp-macros)))
+ (sym nil))
+ (with-output-to-temp-buffer "*SPP MACROS*"
+ (princ "Macro\t\tValue\n")
+ (while syms
+ (setq sym (car syms)
+ syms (cdr syms))
+ (princ (symbol-name sym))
+ (princ "\t")
+ (if (< (length (symbol-name sym)) 8)
+ (princ "\t"))
+ (prin1 (symbol-value sym))
+ (princ "\n")
+ ))))
+
+;;; EDEBUG Handlers
+;;
+(add-hook
+ 'edebug-setup-hook
+ #'(lambda ()
+
+ (def-edebug-spec define-lex-spp-macro-declaration-analyzer
+ (&define name stringp stringp form def-body)
+ )
+
+ (def-edebug-spec define-lex-spp-macro-undeclaration-analyzer
+ (&define name stringp stringp form)
+ )
+
+ (def-edebug-spec define-lex-spp-include-analyzer
+ (&define name stringp stringp form def-body))))
+
+(provide 'semantic/lex-spp)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/lex-spp"
+;; End:
+
+;;; semantic-lex-spp.el ends here
Index: cedet/semantic/lex.el
===================================================================
RCS file: cedet/semantic/lex.el
diff -N cedet/semantic/lex.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/lex.el 28 Sep 2009 15:15:08 -0000 1.2
@@ -0,0 +1,2053 @@
+;;; semantic/lex.el --- Lexical Analyzer builder
+
+;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+;;; 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; This file handles the creation of lexical analyzers for different
+;; languages in Emacs Lisp. The purpose of a lexical analyzer is to
+;; convert a buffer into a list of lexical tokens. Each token
+;; contains the token class (such as 'number, 'symbol, 'IF, etc) and
+;; the location in the buffer it was found. Optionally, a token also
+;; contains a string representing what is at the designated buffer
+;; location.
+;;
+;; Tokens are pushed onto a token stream, which is basically a list of
+;; all the lexical tokens from the analyzed region. The token stream
+;; is then handed to the grammar which parsers the file.
+;;
+;;; How it works
+;;
+;; Each analyzer specifies a condition and forms. These conditions
+;; and forms are assembled into a function by `define-lex' that does
+;; the lexical analysis.
+;;
+;; In the lexical analyzer created with `define-lex', each condition
+;; is tested for a given point. When the conditin is true, the forms
+;; run.
+;;
+;; The forms can push a lexical token onto the token stream. The
+;; analyzer forms also must move the current analyzer point. If the
+;; analyzer point is moved without pushing a token, then tne matched
+;; syntax is effectively ignored, or skipped.
+;;
+;; Thus, starting at the beginning of a region to be analyzed, each
+;; condition is tested. One will match, and a lexical token might be
+;; pushed, and the point is moved to the end of the lexical token
+;; identified. At the new position, the process occurs again until
+;; the end of the specified region is reached.
+;;
+;;; How to use semantic-lex
+;;
+;; To create a lexer for a language, use the `define-lex' macro.
+;;
+;; The `define-lex' macro accepts a list of lexical analyzers. Each
+;; analyzer is created with `define-lex-analyzer', or one of the
+;; derivitive macros. A single analyzer defines a regular expression
+;; to match text in a buffer, and a short segment of code to create
+;; one lexical token.
+;;
+;; Each analyzer has a NAME, DOC, a CONDITION, and possibly some
+;; FORMS. The NAME is the name used in `define-lex'. The DOC
+;; describes what the analyzer should do.
+;;
+;; The CONDITION evaluates the text at the current point in the
+;; current buffer. If CONDITION is true, then the FORMS will be
+;; executed.
+;;
+;; The purpose of the FORMS is to push new lexical tokens onto the
+;; list of tokens for the current buffer, and to move point after the
+;; matched text.
+;;
+;; Some macros for creating one analyzer are:
+;;
+;; define-lex-analyzer - A generic analyzer associating any style of
+;; condition to forms.
+;; define-lex-regex-analyzer - Matches a regular expression.
+;; define-lex-simple-regex-analyzer - Matches a regular expressions,
+;; and pushes the match.
+;; define-lex-block-analyzer - Matches list syntax, and defines
+;; handles open/close delimiters.
+;;
+;; These macros are used by the grammar compiler when lexical
+;; information is specified in a grammar:
+;; define-lex- * -type-analyzer - Matches syntax specified in
+;; a grammar, and pushes one token for it. The * would
+;; be `sexp' for things like lists or strings, and
+;; `string' for things that need to match some special
+;; string, such as "\\." where a literal match is needed.
+;;
+;;; Lexical Tables
+;;
+;; There are tables of different symbols managed in semantic-lex.el.
+;; They are:
+;;
+;; Lexical keyword table - A Table of symbols declared in a grammar
+;; file with the %keyword declaration.
+;; Keywords are used by `semantic-lex-symbol-or-keyword'
+;; to create lexical tokens based on the keyword.
+;;
+;; Lexical type table - A table of symbols declared in a grammer
+;; file with the %type declaration.
+;; The grammar compiler uses the type table to create new
+;; lexical analyzers. These analyzers are then used to when
+;; a new lexical analyzer is made for a language.
+;;
+;;; Lexical Types
+;;
+;; A lexical type defines a kind of lexical analyzer that will be
+;; automatically generated from a grammar file based on some
+;; predetermined attributes. For now these two attributes are
+;; recognized :
+;;
+;; * matchdatatype : define the kind of lexical analyzer. That is :
+;;
+;; - regexp : define a regexp analyzer (see
+;; `define-lex-regex-type-analyzer')
+;;
+;; - string : define a string analyzer (see
+;; `define-lex-string-type-analyzer')
+;;
+;; - block : define a block type analyzer (see
+;; `define-lex-block-type-analyzer')
+;;
+;; - sexp : define a sexp analyzer (see
+;; `define-lex-sexp-type-analyzer')
+;;
+;; - keyword : define a keyword analyzer (see
+;; `define-lex-keyword-type-analyzer')
+;;
+;; * syntax : define the syntax that matches a syntactic
+;; expression. When syntax is matched the corresponding type
+;; analyzer is entered and the resulting match data will be
+;; interpreted based on the kind of analyzer (see matchdatatype
+;; above).
+;;
+;; The following lexical types are predefined :
+;;
+;; +-------------+---------------+--------------------------------+
+;; | type | matchdatatype | syntax |
+;; +-------------+---------------+--------------------------------+
+;; | punctuation | string | "\\(\\s.\\|\\s$\\|\\s'\\)+" |
+;; | keyword | keyword | "\\(\\sw\\|\\s_\\)+" |
+;; | symbol | regexp | "\\(\\sw\\|\\s_\\)+" |
+;; | string | sexp | "\\s\"" |
+;; | number | regexp | semantic-lex-number-expression |
+;; | block | block | "\\s(\\|\\s)" |
+;; +-------------+---------------+--------------------------------+
+;;
+;; In a grammar you must use a %type expression to automatically generate
+;; the corresponding analyzers of that type.
+;;
+;; Here is an example to auto-generate punctuation analyzers
+;; with 'matchdatatype and 'syntax predefined (see table above)
+;;
+;; %type <punctuation> ;; will auto-generate this kind of analyzers
+;;
+;; It is equivalent to write :
+;;
+;; %type <punctuation> syntax "\\(\\s.\\|\\s$\\|\\s'\\)+" matchdatatype string
+;;
+;; ;; Some punctuations based on the type defines above
+;;
+;; %token <punctuation> NOT "!"
+;; %token <punctuation> NOTEQ "!="
+;; %token <punctuation> MOD "%"
+;; %token <punctuation> MODEQ "%="
+;;
+
+;;; On the Semantic 1.x lexer
+;;
+;; In semantic 1.x, the lexical analyzer was an all purpose routine.
+;; To boost efficiency, the analyzer is now a series of routines that
+;; are constructed at build time into a single routine. This will
+;; eliminate unneeded if statements to speed the lexer.
+
+(require 'semantic/fw)
+
+;;; Code:
+
+;;; Semantic 2.x lexical analysis
+;;
+(defun semantic-lex-map-symbols (fun table &optional property)
+ "Call function FUN on every symbol in TABLE.
+If optional PROPERTY is non-nil, call FUN only on every symbol which
+as a PROPERTY value. FUN receives a symbol as argument."
+ (if (arrayp table)
+ (mapatoms
+ #'(lambda (symbol)
+ (if (or (null property) (get symbol property))
+ (funcall fun symbol)))
+ table)))
+
+;;; Lexical keyword table handling.
+;;
+;; These keywords are keywords defined for using in a grammar with the
+;; %keyword declaration, and are not keywords used in Emacs Lisp.
+
+(defvar semantic-flex-keywords-obarray nil
+ "Buffer local keyword obarray for the lexical analyzer.
+These keywords are matched explicitly, and converted into special symbols.")
+(make-variable-buffer-local 'semantic-flex-keywords-obarray)
+
+(defmacro semantic-lex-keyword-invalid (name)
+ "Signal that NAME is an invalid keyword name."
+ `(signal 'wrong-type-argument '(semantic-lex-keyword-p ,name)))
+
+(defsubst semantic-lex-keyword-symbol (name)
+ "Return keyword symbol with NAME or nil if not found."
+ (and (arrayp semantic-flex-keywords-obarray)
+ (stringp name)
+ (intern-soft name semantic-flex-keywords-obarray)))
+
+(defsubst semantic-lex-keyword-p (name)
+ "Return non-nil if a keyword with NAME exists in the keyword table.
+Return nil otherwise."
+ (and (setq name (semantic-lex-keyword-symbol name))
+ (symbol-value name)))
+
+(defsubst semantic-lex-keyword-set (name value)
+ "Set value of keyword with NAME to VALUE and return VALUE."
+ (set (intern name semantic-flex-keywords-obarray) value))
+
+(defsubst semantic-lex-keyword-value (name)
+ "Return value of keyword with NAME.
+Signal an error if a keyword with NAME does not exist."
+ (let ((keyword (semantic-lex-keyword-symbol name)))
+ (if keyword
+ (symbol-value keyword)
+ (semantic-lex-keyword-invalid name))))
+
+(defsubst semantic-lex-keyword-put (name property value)
+ "For keyword with NAME, set its PROPERTY to VALUE."
+ (let ((keyword (semantic-lex-keyword-symbol name)))
+ (if keyword
+ (put keyword property value)
+ (semantic-lex-keyword-invalid name))))
+
+(defsubst semantic-lex-keyword-get (name property)
+ "For keyword with NAME, return its PROPERTY value."
+ (let ((keyword (semantic-lex-keyword-symbol name)))
+ (if keyword
+ (get keyword property)
+ (semantic-lex-keyword-invalid name))))
+
+(defun semantic-lex-make-keyword-table (specs &optional propspecs)
+ "Convert keyword SPECS into an obarray and return it.
+SPECS must be a list of (NAME . TOKSYM) elements, where:
+
+ NAME is the name of the keyword symbol to define.
+ TOKSYM is the lexical token symbol of that keyword.
+
+If optional argument PROPSPECS is non nil, then interpret it, and
+apply those properties.
+PROPSPECS must be a list of (NAME PROPERTY VALUE) elements."
+ ;; Create the symbol hash table
+ (let ((semantic-flex-keywords-obarray (make-vector 13 0))
+ spec)
+ ;; fill it with stuff
+ (while specs
+ (setq spec (car specs)
+ specs (cdr specs))
+ (semantic-lex-keyword-set (car spec) (cdr spec)))
+ ;; Apply all properties
+ (while propspecs
+ (setq spec (car propspecs)
+ propspecs (cdr propspecs))
+ (semantic-lex-keyword-put (car spec) (nth 1 spec) (nth 2 spec)))
+ semantic-flex-keywords-obarray))
+
+(defsubst semantic-lex-map-keywords (fun &optional property)
+ "Call function FUN on every lexical keyword.
+If optional PROPERTY is non-nil, call FUN only on every keyword which
+as a PROPERTY value. FUN receives a lexical keyword as argument."
+ (semantic-lex-map-symbols
+ fun semantic-flex-keywords-obarray property))
+
+(defun semantic-lex-keywords (&optional property)
+ "Return a list of lexical keywords.
+If optional PROPERTY is non-nil, return only keywords which have a
+PROPERTY set."
+ (let (keywords)
+ (semantic-lex-map-keywords
+ #'(lambda (symbol) (setq keywords (cons symbol keywords)))
+ property)
+ keywords))
+
+;;; Inline functions:
+
+(defvar semantic-lex-unterminated-syntax-end-function)
+(defvar semantic-lex-analysis-bounds)
+(defvar semantic-lex-end-point)
+
+(defsubst semantic-lex-token-bounds (token)
+ "Fetch the start and end locations of the lexical token TOKEN.
+Return a pair (START . END)."
+ (if (not (numberp (car (cdr token))))
+ (cdr (cdr token))
+ (cdr token)))
+
+(defsubst semantic-lex-token-start (token)
+ "Fetch the start position of the lexical token TOKEN.
+See also the function `semantic-lex-token'."
+ (car (semantic-lex-token-bounds token)))
+
+(defsubst semantic-lex-token-end (token)
+ "Fetch the end position of the lexical token TOKEN.
+See also the function `semantic-lex-token'."
+ (cdr (semantic-lex-token-bounds token)))
+
+(defsubst semantic-lex-unterminated-syntax-detected (syntax)
+ "Inside a lexical analyzer, use this when unterminated syntax was found.
+Argument SYNTAX indicates the type of syntax that is unterminated.
+The job of this function is to move (point) to a new logical location
+so that analysis can continue, if possible."
+ (goto-char
+ (funcall semantic-lex-unterminated-syntax-end-function
+ syntax
+ (car semantic-lex-analysis-bounds)
+ (cdr semantic-lex-analysis-bounds)
+ ))
+ (setq semantic-lex-end-point (point)))
+
+;;; Type table handling.
+;;
+;; The lexical type table manages types that occur in a grammar file
+;; with the %type declaration. Types represent different syntaxes.
+;; See code for `semantic-lex-preset-default-types' for the classic
+;; types of syntax.
+(defvar semantic-lex-types-obarray nil
+ "Buffer local types obarray for the lexical analyzer.")
+(make-variable-buffer-local 'semantic-lex-types-obarray)
+
+(defmacro semantic-lex-type-invalid (type)
+ "Signal that TYPE is an invalid lexical type name."
+ `(signal 'wrong-type-argument '(semantic-lex-type-p ,type)))
+
+(defsubst semantic-lex-type-symbol (type)
+ "Return symbol with TYPE or nil if not found."
+ (and (arrayp semantic-lex-types-obarray)
+ (stringp type)
+ (intern-soft type semantic-lex-types-obarray)))
+
+(defsubst semantic-lex-type-p (type)
+ "Return non-nil if a symbol with TYPE name exists."
+ (and (setq type (semantic-lex-type-symbol type))
+ (symbol-value type)))
+
+(defsubst semantic-lex-type-set (type value)
+ "Set value of symbol with TYPE name to VALUE and return VALUE."
+ (set (intern type semantic-lex-types-obarray) value))
+
+(defsubst semantic-lex-type-value (type &optional noerror)
+ "Return value of symbol with TYPE name.
+If optional argument NOERROR is non-nil return nil if a symbol with
+TYPE name does not exist. Otherwise signal an error."
+ (let ((sym (semantic-lex-type-symbol type)))
+ (if sym
+ (symbol-value sym)
+ (unless noerror
+ (semantic-lex-type-invalid type)))))
+
+(defsubst semantic-lex-type-put (type property value &optional add)
+ "For symbol with TYPE name, set its PROPERTY to VALUE.
+If optional argument ADD is non-nil, create a new symbol with TYPE
+name if it does not already exist. Otherwise signal an error."
+ (let ((sym (semantic-lex-type-symbol type)))
+ (unless sym
+ (or add (semantic-lex-type-invalid type))
+ (semantic-lex-type-set type nil)
+ (setq sym (semantic-lex-type-symbol type)))
+ (put sym property value)))
+
+(defsubst semantic-lex-type-get (type property &optional noerror)
+ "For symbol with TYPE name, return its PROPERTY value.
+If optional argument NOERROR is non-nil return nil if a symbol with
+TYPE name does not exist. Otherwise signal an error."
+ (let ((sym (semantic-lex-type-symbol type)))
+ (if sym
+ (get sym property)
+ (unless noerror
+ (semantic-lex-type-invalid type)))))
+
+(defun semantic-lex-preset-default-types ()
+ "Install useful default properties for well known types."
+ (semantic-lex-type-put "punctuation" 'matchdatatype 'string t)
+ (semantic-lex-type-put "punctuation" 'syntax "\\(\\s.\\|\\s$\\|\\s'\\)+")
+ (semantic-lex-type-put "keyword" 'matchdatatype 'keyword t)
+ (semantic-lex-type-put "keyword" 'syntax "\\(\\sw\\|\\s_\\)+")
+ (semantic-lex-type-put "symbol" 'matchdatatype 'regexp t)
+ (semantic-lex-type-put "symbol" 'syntax "\\(\\sw\\|\\s_\\)+")
+ (semantic-lex-type-put "string" 'matchdatatype 'sexp t)
+ (semantic-lex-type-put "string" 'syntax "\\s\"")
+ (semantic-lex-type-put "number" 'matchdatatype 'regexp t)
+ (semantic-lex-type-put "number" 'syntax 'semantic-lex-number-expression)
+ (semantic-lex-type-put "block" 'matchdatatype 'block t)
+ (semantic-lex-type-put "block" 'syntax "\\s(\\|\\s)")
+ )
+
+(defun semantic-lex-make-type-table (specs &optional propspecs)
+ "Convert type SPECS into an obarray and return it.
+SPECS must be a list of (TYPE . TOKENS) elements, where:
+
+ TYPE is the name of the type symbol to define.
+ TOKENS is an list of (TOKSYM . MATCHER) elements, where:
+
+ TOKSYM is any lexical token symbol.
+ MATCHER is a string or regexp a text must match to be a such
+ lexical token.
+
+If optional argument PROPSPECS is non nil, then interpret it, and
+apply those properties.
+PROPSPECS must be a list of (TYPE PROPERTY VALUE)."
+ ;; Create the symbol hash table
+ (let* ((semantic-lex-types-obarray (make-vector 13 0))
+ spec type tokens token alist default)
+ ;; fill it with stuff
+ (while specs
+ (setq spec (car specs)
+ specs (cdr specs)
+ type (car spec)
+ tokens (cdr spec)
+ default nil
+ alist nil)
+ (while tokens
+ (setq token (car tokens)
+ tokens (cdr tokens))
+ (if (cdr token)
+ (setq alist (cons token alist))
+ (setq token (car token))
+ (if default
+ (message
+ "*Warning* default value of <%s> tokens changed to %S, was %S"
+ type default token))
+ (setq default token)))
+ ;; Ensure the default matching spec is the first one.
+ (semantic-lex-type-set type (cons default (nreverse alist))))
+ ;; Install useful default types & properties
+ (semantic-lex-preset-default-types)
+ ;; Apply all properties
+ (while propspecs
+ (setq spec (car propspecs)
+ propspecs (cdr propspecs))
+ ;; Create the type if necessary.
+ (semantic-lex-type-put (car spec) (nth 1 spec) (nth 2 spec) t))
+ semantic-lex-types-obarray))
+
+(defsubst semantic-lex-map-types (fun &optional property)
+ "Call function FUN on every lexical type.
+If optional PROPERTY is non-nil, call FUN only on every type symbol
+which as a PROPERTY value. FUN receives a type symbol as argument."
+ (semantic-lex-map-symbols
+ fun semantic-lex-types-obarray property))
+
+(defun semantic-lex-types (&optional property)
+ "Return a list of lexical type symbols.
+If optional PROPERTY is non-nil, return only type symbols which have
+PROPERTY set."
+ (let (types)
+ (semantic-lex-map-types
+ #'(lambda (symbol) (setq types (cons symbol types)))
+ property)
+ types))
+
+;;; Lexical Analyzer framework settings
+;;
+
+(defvar semantic-lex-analyzer 'semantic-flex
+ "The lexical analyzer used for a given buffer.
+See `semantic-lex' for documentation.
+For compatibility with Semantic 1.x it defaults to `semantic-flex'.")
+(make-variable-buffer-local 'semantic-lex-analyzer)
+
+(defvar semantic-lex-tokens
+ '(
+ (bol)
+ (charquote)
+ (close-paren)
+ (comment)
+ (newline)
+ (open-paren)
+ (punctuation)
+ (semantic-list)
+ (string)
+ (symbol)
+ (whitespace)
+ )
+ "An alist of of semantic token types.
+As of December 2001 (semantic 1.4beta13), this variable is not used in
+any code. The only use is to refer to the doc-string from elsewhere.
+
+The key to this alist is the symbol representing token type that
+\\[semantic-flex] returns. These are
+
+ - bol: Empty string matching a beginning of line.
+ This token is produced with
+ `semantic-lex-beginning-of-line'.
+
+ - charquote: String sequences that match `\\s\\+' regexp.
+ This token is produced with `semantic-lex-charquote'.
+
+ - close-paren: Characters that match `\\s)' regexp.
+ These are typically `)', `}', `]', etc.
+ This token is produced with
+ `semantic-lex-close-paren'.
+
+ - comment: A comment chunk. These token types are not
+ produced by default.
+ This token is produced with `semantic-lex-comments'.
+ Comments are ignored with `semantic-lex-ignore-comments'.
+ Comments are treated as whitespace with
+ `semantic-lex-comments-as-whitespace'.
+
+ - newline Characters matching `\\s-*\\(\n\\|\\s>\\)' regexp.
+ This token is produced with `semantic-lex-newline'.
+
+ - open-paren: Characters that match `\\s(' regexp.
+ These are typically `(', `{', `[', etc.
+ If `semantic-lex-paren-or-list' is used,
+ then `open-paren' is not usually generated unless
+ the `depth' argument to \\[semantic-lex] is
+ greater than 0.
+ This token is always produced if the analyzer
+ `semantic-lex-open-paren' is used.
+
+ - punctuation: Characters matching `{\\(\\s.\\|\\s$\\|\\s'\\)'
+ regexp.
+ This token is produced with `semantic-lex-punctuation'.
+ Always specify this analyzer after the comment
+ analyzer.
+
+ - semantic-list: String delimited by matching parenthesis, braces,
+ etc. that the lexer skipped over, because the
+ `depth' parameter to \\[semantic-flex] was not high
+ enough.
+ This token is produced with `semantic-lex-paren-or-list'.
+
+ - string: Quoted strings, i.e., string sequences that start
+ and end with characters matching `\\s\"'
+ regexp. The lexer relies on @code{forward-sexp} to
+ find the matching end.
+ This token is produced with `semantic-lex-string'.
+
+ - symbol: String sequences that match `\\(\\sw\\|\\s_\\)+'
+ regexp.
+ This token is produced with
+ `semantic-lex-symbol-or-keyword'. Always add this analyzer
+ after `semantic-lex-number', or other analyzers that
+ match its regular expression.
+
+ - whitespace: Characters that match `\\s-+' regexp.
+ This token is produced with `semantic-lex-whitespace'.")
+
+(defvar semantic-lex-syntax-modifications nil
+ "Changes to the syntax table for this buffer.
+These changes are active only while the buffer is being flexed.
+This is a list where each element has the form:
+ (CHAR CLASS)
+CHAR is the char passed to `modify-syntax-entry',
+and CLASS is the string also passed to `modify-syntax-entry' to define
+what syntax class CHAR has.")
+(make-variable-buffer-local 'semantic-lex-syntax-modifications)
+
+(defvar semantic-lex-syntax-table nil
+ "Syntax table used by lexical analysis.
+See also `semantic-lex-syntax-modifications'.")
+(make-variable-buffer-local 'semantic-lex-syntax-table)
+
+(defvar semantic-lex-comment-regex nil
+ "Regular expression for identifying comment start during lexical analysis.
+This may be automatically set when semantic initializes in a mode, but
+may need to be overriden for some special languages.")
+(make-variable-buffer-local 'semantic-lex-comment-regex)
+
+(defvar semantic-lex-number-expression
+ ;; This expression was written by David Ponce for Java, and copied
+ ;; here for C and any other similar language.
+ (eval-when-compile
+ (concat "\\("
+ "\\<[0-9]+[.][0-9]+\\([eE][-+]?[0-9]+\\)?[fFdD]?\\>"
+ "\\|"
+ "\\<[0-9]+[.][eE][-+]?[0-9]+[fFdD]?\\>"
+ "\\|"
+ "\\<[0-9]+[.][fFdD]\\>"
+ "\\|"
+ "\\<[0-9]+[.]"
+ "\\|"
+ "[.][0-9]+\\([eE][-+]?[0-9]+\\)?[fFdD]?\\>"
+ "\\|"
+ "\\<[0-9]+[eE][-+]?[0-9]+[fFdD]?\\>"
+ "\\|"
+ "\\<0[xX][0-9a-fA-F]+[lL]?\\>"
+ "\\|"
+ "\\<[0-9]+[lLfFdD]?\\>"
+ "\\)"
+ ))
+ "Regular expression for matching a number.
+If this value is nil, no number extraction is done during lex.
+This expression tries to match C and Java like numbers.
+
+DECIMAL_LITERAL:
+ [1-9][0-9]*
+ ;
+HEX_LITERAL:
+ 0[xX][0-9a-fA-F]+
+ ;
+OCTAL_LITERAL:
+ 0[0-7]*
+ ;
+INTEGER_LITERAL:
+ <DECIMAL_LITERAL>[lL]?
+ | <HEX_LITERAL>[lL]?
+ | <OCTAL_LITERAL>[lL]?
+ ;
+EXPONENT:
+ [eE][+-]?[09]+
+ ;
+FLOATING_POINT_LITERAL:
+ [0-9]+[.][0-9]*<EXPONENT>?[fFdD]?
+ | [.][0-9]+<EXPONENT>?[fFdD]?
+ | [0-9]+<EXPONENT>[fFdD]?
+ | [0-9]+<EXPONENT>?[fFdD]
+ ;")
+(make-variable-buffer-local 'semantic-lex-number-expression)
+
+(defvar semantic-lex-depth 0
+ "Default lexing depth.
+This specifies how many lists to create tokens in.")
+(make-variable-buffer-local 'semantic-lex-depth)
+
+(defvar semantic-lex-unterminated-syntax-end-function
+ (lambda (syntax syntax-start lex-end) lex-end)
+ "Function called when unterminated syntax is encountered.
+This should be set to one function. That function should take three
+parameters. The SYNTAX, or type of syntax which is unterminated.
+SYNTAX-START where the broken syntax begins.
+LEX-END is where the lexical analysis was asked to end.
+This function can be used for languages that can intelligently fix up
+broken syntax, or the exit lexical analysis via `throw' or `signal'
+when finding unterminated syntax.")
+
+;;; Interactive testing commands
+
+(declare-function semantic-elapsed-time "semantic")
+
+(defun semantic-lex-test (arg)
+ "Test the semantic lexer in the current buffer.
+If universal argument ARG, then try the whole buffer."
+ (interactive "P")
+ (require 'semantic)
+ (let* ((start (current-time))
+ (result (semantic-lex
+ (if arg (point-min) (point))
+ (point-max)))
+ (end (current-time)))
+ (message "Elapsed Time: %.2f seconds."
+ (semantic-elapsed-time start end))
+ (pop-to-buffer "*Lexer Output*")
+ (require 'pp)
+ (erase-buffer)
+ (insert (pp-to-string result))
+ (goto-char (point-min))
+ ))
+
+(defvar semantic-lex-debug nil
+ "When non-nil, debug the local lexical analyzer.")
+
+(defun semantic-lex-debug (arg)
+ "Debug the semantic lexer in the current buffer.
+Argument ARG specifies of the analyze the whole buffer, or start at point.
+While engaged, each token identified by the lexer will be highlighted
+in the target buffer A description of the current token will be
+displayed in the minibuffer. Press SPC to move to the next lexical token."
+ (interactive "P")
+ (require 'semantic/debug)
+ (let ((semantic-lex-debug t))
+ (semantic-lex-test arg)))
+
+(defun semantic-lex-highlight-token (token)
+ "Highlight the lexical TOKEN.
+TOKEN is a lexical token with a START And END position.
+Return the overlay."
+ (let ((o (semantic-make-overlay (semantic-lex-token-start token)
+ (semantic-lex-token-end token))))
+ (semantic-overlay-put o 'face 'highlight)
+ o))
+
+(defsubst semantic-lex-debug-break (token)
+ "Break during lexical analysis at TOKEN."
+ (when semantic-lex-debug
+ (let ((o nil))
+ (unwind-protect
+ (progn
+ (when token
+ (setq o (semantic-lex-highlight-token token)))
+ (semantic-read-event
+ (format "%S :: SPC - continue" token))
+ )
+ (when o
+ (semantic-overlay-delete o))))))
+
+;;; Lexical analyzer creation
+;;
+;; Code for creating a lex function from lists of analyzers.
+;;
+;; A lexical analyzer is created from a list of individual analyzers.
+;; Each individual analyzer specifies a single match, and code that
+;; goes with it.
+;;
+;; Creation of an analyzer assembles these analyzers into a new function
+;; with the behaviors of all the individual analyzers.
+;;
+(defmacro semantic-lex-one-token (analyzers)
+ "Calculate one token from the current buffer at point.
+Uses locally bound variables from `define-lex'.
+Argument ANALYZERS is the list of analyzers being used."
+ (cons 'cond (mapcar #'symbol-value analyzers)))
+
+(defvar semantic-lex-end-point nil
+ "The end point as tracked through lexical functions.")
+
+(defvar semantic-lex-current-depth nil
+ "The current depth as tracked through lexical functions.")
+
+(defvar semantic-lex-maximum-depth nil
+ "The maximum depth of parenthisis as tracked through lexical functions.")
+
+(defvar semantic-lex-token-stream nil
+ "The current token stream we are collecting.")
+
+(defvar semantic-lex-analysis-bounds nil
+ "The bounds of the current analysis.")
+
+(defvar semantic-lex-block-streams nil
+ "Streams of tokens inside collapsed blocks.
+This is an alist of (ANCHOR . STREAM) elements where ANCHOR is the
+start position of the block, and STREAM is the list of tokens in that
+block.")
+
+(defvar semantic-lex-reset-hooks nil
+ "Abnormal hook used by major-modes to reset lexical analyzers.
+Hook functions are called with START and END values for the
+current lexical pass. Should be set with `add-hook', specifying
+a LOCAL option.")
+
+;; Stack of nested blocks.
+(defvar semantic-lex-block-stack nil)
+;;(defvar semantic-lex-timeout 5
+;; "*Number of sections of lexing before giving up.")
+
+(defmacro define-lex (name doc &rest analyzers)
+ "Create a new lexical analyzer with NAME.
+DOC is a documentation string describing this analyzer.
+ANALYZERS are small code snippets of analyzers to use when
+building the new NAMED analyzer. Only use analyzers which
+are written to be used in `define-lex'.
+Each analyzer should be an analyzer created with `define-lex-analyzer'.
+Note: The order in which analyzers are listed is important.
+If two analyzers can match the same text, it is important to order the
+analyzers so that the one you want to match first occurs first. For
+example, it is good to put a numbe analyzer in front of a symbol
+analyzer which might mistake a number for as a symbol."
+ `(defun ,name (start end &optional depth length)
+ ,(concat doc "\nSee `semantic-lex' for more information.")
+ ;; Make sure the state of block parsing starts over.
+ (setq semantic-lex-block-streams nil)
+ ;; Allow specialty reset items.
+ (run-hook-with-args 'semantic-lex-reset-hooks start end)
+ ;; Lexing state.
+ (let* (;(starttime (current-time))
+ (starting-position (point))
+ (semantic-lex-token-stream nil)
+ (semantic-lex-block-stack nil)
+ (tmp-start start)
+ (semantic-lex-end-point start)
+ (semantic-lex-current-depth 0)
+ ;; Use the default depth when not specified.
+ (semantic-lex-maximum-depth
+ (or depth semantic-lex-depth))
+ ;; Bounds needed for unterminated syntax
+ (semantic-lex-analysis-bounds (cons start end))
+ ;; This entry prevents text properties from
+ ;; confusing our lexical analysis. See Emacs 22 (CVS)
+ ;; version of C++ mode with template hack text properties.
+ (parse-sexp-lookup-properties nil)
+ )
+ ;; Maybe REMOVE THIS LATER.
+ ;; Trying to find incremental parser bug.
+ (when (> end (point-max))
+ (error ,(format "%s: end (%%d) > point-max (%%d)" name)
+ end (point-max)))
+ (with-syntax-table semantic-lex-syntax-table
+ (goto-char start)
+ (while (and (< (point) end)
+ (or (not length)
+ (<= (length semantic-lex-token-stream) length)))
+ (semantic-lex-one-token ,analyzers)
+ (when (eq semantic-lex-end-point tmp-start)
+ (error ,(format "%s: endless loop at %%d, after %%S" name)
+ tmp-start (car semantic-lex-token-stream)))
+ (setq tmp-start semantic-lex-end-point)
+ (goto-char semantic-lex-end-point)
+ ;;(when (> (semantic-elapsed-time starttime (current-time))
+ ;; semantic-lex-timeout)
+ ;; (error "Timeout during lex at char %d" (point)))
+ (semantic-throw-on-input 'lex)
+ (semantic-lex-debug-break (car semantic-lex-token-stream))
+ ))
+ ;; Check that there is no unterminated block.
+ (when semantic-lex-block-stack
+ (let* ((last (pop semantic-lex-block-stack))
+ (blk last))
+ (while blk
+ (message
+ ,(format "%s: `%%s' block from %%S is unterminated" name)
+ (car blk) (cadr blk))
+ (setq blk (pop semantic-lex-block-stack)))
+ (semantic-lex-unterminated-syntax-detected (car last))))
+ ;; Return to where we started.
+ ;; Do not wrap in protective stuff so that if there is an error
+ ;; thrown, the user knows where.
+ (goto-char starting-position)
+ ;; Return the token stream
+ (nreverse semantic-lex-token-stream))))
+
+;;; Collapsed block tokens delimited by any tokens.
+;;
+(defun semantic-lex-start-block (syntax)
+ "Mark the last read token as the beginning of a SYNTAX block."
+ (if (or (not semantic-lex-maximum-depth)
+ (< semantic-lex-current-depth semantic-lex-maximum-depth))
+ (setq semantic-lex-current-depth (1+ semantic-lex-current-depth))
+ (push (list syntax (car semantic-lex-token-stream))
+ semantic-lex-block-stack)))
+
+(defun semantic-lex-end-block (syntax)
+ "Process the end of a previously marked SYNTAX block.
+That is, collapse the tokens inside that block, including the
+beginning and end of block tokens, into a high level block token of
+class SYNTAX.
+The token at beginning of block is the one marked by a previous call
+to `semantic-lex-start-block'. The current token is the end of block.
+The collapsed tokens are saved in `semantic-lex-block-streams'."
+ (if (null semantic-lex-block-stack)
+ (setq semantic-lex-current-depth (1- semantic-lex-current-depth))
+ (let* ((stream semantic-lex-token-stream)
+ (blk (pop semantic-lex-block-stack))
+ (bstream (cdr blk))
+ (first (car bstream))
+ (last (pop stream)) ;; The current token mark the EOBLK
+ tok)
+ (if (not (eq (car blk) syntax))
+ ;; SYNTAX doesn't match the syntax of the current block in
+ ;; the stack. So we encountered the end of the SYNTAX block
+ ;; before the end of the current one in the stack which is
+ ;; signaled unterminated.
+ (semantic-lex-unterminated-syntax-detected (car blk))
+ ;; Move tokens found inside the block from the main stream
+ ;; into a separate block stream.
+ (while (and stream (not (eq (setq tok (pop stream)) first)))
+ (push tok bstream))
+ ;; The token marked as beginning of block was not encountered.
+ ;; This should not happen!
+ (or (eq tok first)
+ (error "Token %S not found at beginning of block `%s'"
+ first syntax))
+ ;; Save the block stream for future reuse, to avoid to redo
+ ;; the lexical analysis of the block content!
+ ;; Anchor the block stream with its start position, so we can
+ ;; use: (cdr (assq start semantic-lex-block-streams)) to
+ ;; quickly retrieve the lexical stream associated to a block.
+ (setcar blk (semantic-lex-token-start first))
+ (setcdr blk (nreverse bstream))
+ (push blk semantic-lex-block-streams)
+ ;; In the main stream, replace the tokens inside the block by
+ ;; a high level block token of class SYNTAX.
+ (setq semantic-lex-token-stream stream)
+ (semantic-lex-push-token
+ (semantic-lex-token
+ syntax (car blk) (semantic-lex-token-end last)))
+ ))))
+
+;;; Lexical token API
+;;
+;; Functions for accessing parts of a token. Use these functions
+;; instead of accessing the list structure directly because the
+;; contents of the lexical may change.
+;;
+(defmacro semantic-lex-token (symbol start end &optional str)
+ "Create a lexical token.
+SYMBOL is a symbol representing the class of syntax found.
+START and END define the bounds of the token in the current buffer.
+Optional STR is the string for the token iff the the bounds
+in the buffer do not cover the string they represent. (As from
+macro expansion.)"
+ ;; This if statement checks the existance of a STR argument at
+ ;; compile time, where STR is some symbol or constant. If the
+ ;; variable STr (runtime) is nil, this will make an incorrect decision.
+ ;;
+ ;; It is like this to maintain the original speed of the compiled
+ ;; code.
+ (if str
+ `(cons ,symbol (cons ,str (cons ,start ,end)))
+ `(cons ,symbol (cons ,start ,end))))
+
+(defun semantic-lex-token-p (thing)
+ "Return non-nil if THING is a semantic lex token.
+This is an exhaustively robust check."
+ (and (consp thing)
+ (symbolp (car thing))
+ (or (and (numberp (nth 1 thing))
+ (numberp (nthcdr 2 thing)))
+ (and (stringp (nth 1 thing))
+ (numberp (nth 2 thing))
+ (numberp (nthcdr 3 thing)))
+ ))
+ )
+
+(defun semantic-lex-token-with-text-p (thing)
+ "Return non-nil if THING is a semantic lex token.
+This is an exhaustively robust check."
+ (and (consp thing)
+ (symbolp (car thing))
+ (= (length thing) 4)
+ (stringp (nth 1 thing))
+ (numberp (nth 2 thing))
+ (numberp (nth 3 thing)))
+ )
+
+(defun semantic-lex-token-without-text-p (thing)
+ "Return non-nil if THING is a semantic lex token.
+This is an exhaustively robust check."
+ (and (consp thing)
+ (symbolp (car thing))
+ (= (length thing) 3)
+ (numberp (nth 1 thing))
+ (numberp (nth 2 thing)))
+ )
+
+(eval-and-compile
+
+(defun semantic-lex-expand-block-specs (specs)
+ "Expand block specifications SPECS into a Lisp form.
+SPECS is a list of (BLOCK BEGIN END) elements where BLOCK, BEGIN, and
+END are token class symbols that indicate to produce one collapsed
+BLOCK token from tokens found between BEGIN and END ones.
+BLOCK must be a non-nil symbol, and at least one of the BEGIN or END
+symbols must be non-nil too.
+When BEGIN is non-nil, generate a call to `semantic-lex-start-block'
+when a BEGIN token class is encountered.
+When END is non-nil, generate a call to `semantic-lex-end-block' when
+an END token class is encountered."
+ (let ((class (make-symbol "class"))
+ (form nil))
+ (dolist (spec specs)
+ (when (car spec)
+ (when (nth 1 spec)
+ (push `((eq ',(nth 1 spec) ,class)
+ (semantic-lex-start-block ',(car spec)))
+ form))
+ (when (nth 2 spec)
+ (push `((eq ',(nth 2 spec) ,class)
+ (semantic-lex-end-block ',(car spec)))
+ form))))
+ (when form
+ `((let ((,class (semantic-lex-token-class
+ (car semantic-lex-token-stream))))
+ (cond ,@(nreverse form))))
+ )))
+)
+
+(defmacro semantic-lex-push-token (token &rest blockspecs)
+ "Push TOKEN in the lexical analyzer token stream.
+Return the lexical analysis current end point.
+If optional arguments BLOCKSPECS is non-nil, it specifies to process
+collapsed block tokens. See `semantic-lex-expand-block-specs' for
+more details.
+This macro should only be called within the bounds of
+`define-lex-analyzer'. It changes the values of the lexical analyzer
+variables `token-stream' and `semantic-lex-end-point'. If you need to
+move `semantic-lex-end-point' somewhere else, just modify this
+variable after calling `semantic-lex-push-token'."
+ `(progn
+ (push ,token semantic-lex-token-stream)
+ ,@(semantic-lex-expand-block-specs blockspecs)
+ (setq semantic-lex-end-point
+ (semantic-lex-token-end (car semantic-lex-token-stream)))
+ ))
+
+(defsubst semantic-lex-token-class (token)
+ "Fetch the class of the lexical token TOKEN.
+See also the function `semantic-lex-token'."
+ (car token))
+
+(defsubst semantic-lex-token-text (token)
+ "Fetch the text associated with the lexical token TOKEN.
+See also the function `semantic-lex-token'."
+ (if (stringp (car (cdr token)))
+ (car (cdr token))
+ (buffer-substring-no-properties
+ (semantic-lex-token-start token)
+ (semantic-lex-token-end token))))
+
+(defun semantic-lex-init ()
+ "Initialize any lexical state for this buffer."
+ (unless semantic-lex-comment-regex
+ (setq semantic-lex-comment-regex
+ (if comment-start-skip
+ (concat "\\(\\s<\\|" comment-start-skip "\\)")
+ "\\(\\s<\\)")))
+ ;; Setup the lexer syntax-table
+ (setq semantic-lex-syntax-table (copy-syntax-table (syntax-table)))
+ (dolist (mod semantic-lex-syntax-modifications)
+ (modify-syntax-entry
+ (car mod) (nth 1 mod) semantic-lex-syntax-table)))
+
+;;;###autoload
+(define-overloadable-function semantic-lex (start end &optional depth length)
+ "Lexically analyze text in the current buffer between START and END.
+Optional argument DEPTH indicates at what level to scan over entire
+lists. The last argument, LENGTH specifies that `semantic-lex'
+should only return LENGTH tokens. The return value is a token stream.
+Each element is a list, such of the form
+ (symbol start-expression . end-expression)
+where SYMBOL denotes the token type.
+See `semantic-lex-tokens' variable for details on token types. END
+does not mark the end of the text scanned, only the end of the
+beginning of text scanned. Thus, if a string extends past END, the
+end of the return token will be larger than END. To truly restrict
+scanning, use `narrow-to-region'."
+ (funcall semantic-lex-analyzer start end depth length))
+
+(defsubst semantic-lex-buffer (&optional depth)
+ "Lex the current buffer.
+Optional argument DEPTH is the depth to scan into lists."
+ (semantic-lex (point-min) (point-max) depth))
+
+(defsubst semantic-lex-list (semlist depth)
+ "Lex the body of SEMLIST to DEPTH."
+ (semantic-lex (semantic-lex-token-start semlist)
+ (semantic-lex-token-end semlist)
+ depth))
+
+;;; Analyzer creation macros
+;;
+;; An individual analyzer is a condition and code that goes with it.
+;;
+;; Created analyzers become variables with the code associated with them
+;; as the symbol value. These analyzers are assembled into a lexer
+;; to create new lexical analyzers.
+
+(defcustom semantic-lex-debug-analyzers nil
+ "Non nil means to debug analyzers with syntax protection.
+Only in effect if `debug-on-error' is also non-nil."
+ :group 'semantic
+ :type 'boolean)
+
+(defmacro semantic-lex-unterminated-syntax-protection (syntax &rest forms)
+ "For SYNTAX, execute FORMS with protection for unterminated syntax.
+If FORMS throws an error, treat this as a syntax problem, and
+execute the unterminated syntax code. FORMS should return a position.
+Irreguardless of an error, the cursor should be moved to the end of
+the desired syntax, and a position returned.
+If `debug-on-error' is set, errors are not caught, so that you can
+debug them.
+Avoid using a large FORMS since it is duplicated."
+ `(if (and debug-on-error semantic-lex-debug-analyzers)
+ (progn ,@forms)
+ (condition-case nil
+ (progn ,@forms)
+ (error
+ (semantic-lex-unterminated-syntax-detected ,syntax)))))
+(put 'semantic-lex-unterminated-syntax-protection
+ 'lisp-indent-function 1)
+
+(defmacro define-lex-analyzer (name doc condition &rest forms)
+ "Create a single lexical analyzer NAME with DOC.
+When an analyzer is called, the current buffer and point are
+positioned in a buffer at the location to be analyzed.
+CONDITION is an expression which returns t if FORMS should be run.
+Within the bounds of CONDITION and FORMS, the use of backquote
+can be used to evaluate expressions at compile time.
+While forms are running, the following variables will be locally bound:
+ `semantic-lex-analysis-bounds' - The bounds of the current analysis.
+ of the form (START . END)
+ `semantic-lex-maximum-depth' - The maximum depth of semantic-list
+ for the current analysis.
+ `semantic-lex-current-depth' - The current depth of `semantic-list' that has
+ been decended.
+ `semantic-lex-end-point' - End Point after match.
+ Analyzers should set this to a buffer location if their
+ match string does not represent the end of the matched text.
+ `semantic-lex-token-stream' - The token list being collected.
+ Add new lexical tokens to this list.
+Proper action in FORMS is to move the value of `semantic-lex-end-point' to
+after the location of the analyzed entry, and to add any discovered tokens
+at the beginning of `semantic-lex-token-stream'.
+This can be done by using `semantic-lex-push-token'."
+ `(eval-and-compile
+ (defvar ,name nil ,doc)
+ (defun ,name nil)
+ ;; Do this part separately so that re-evaluation rebuilds this code.
+ (setq ,name '(,condition ,@forms))
+ ;; Build a single lexical analyzer function, so the doc for
+ ;; function help is automatically provided, and perhaps the
+ ;; function could be useful for testing and debugging one
+ ;; analyzer.
+ (fset ',name (lambda () ,doc
+ (let ((semantic-lex-token-stream nil)
+ (semantic-lex-end-point (point))
+ (semantic-lex-analysis-bounds
+ (cons (point) (point-max)))
+ (semantic-lex-current-depth 0)
+ (semantic-lex-maximum-depth
+ semantic-lex-depth)
+ )
+ (when ,condition ,@forms)
+ semantic-lex-token-stream)))
+ ))
+
+(defmacro define-lex-regex-analyzer (name doc regexp &rest forms)
+ "Create a lexical analyzer with NAME and DOC that will match REGEXP.
+FORMS are evaluated upon a successful match.
+See `define-lex-analyzer' for more about analyzers."
+ `(define-lex-analyzer ,name
+ ,doc
+ (looking-at ,regexp)
+ ,@forms
+ ))
+
+(defmacro define-lex-simple-regex-analyzer (name doc regexp toksym
+ &optional index
+ &rest forms)
+ "Create a lexical analyzer with NAME and DOC that match REGEXP.
+TOKSYM is the symbol to use when creating a semantic lexical token.
+INDEX is the index into the match that defines the bounds of the token.
+Index should be a plain integer, and not specified in the macro as an
+expression.
+FORMS are evaluated upon a successful match BEFORE the new token is
+created. It is valid to ignore FORMS.
+See `define-lex-analyzer' for more about analyzers."
+ `(define-lex-analyzer ,name
+ ,doc
+ (looking-at ,regexp)
+ ,@forms
+ (semantic-lex-push-token
+ (semantic-lex-token ,toksym
+ (match-beginning ,(or index 0))
+ (match-end ,(or index 0))))
+ ))
+
+(defmacro define-lex-block-analyzer (name doc spec1 &rest specs)
+ "Create a lexical analyzer NAME for paired delimiters blocks.
+It detects a paired delimiters block or the corresponding open or
+close delimiter depending on the value of the variable
+`semantic-lex-current-depth'. DOC is the documentation string of the lexical
+analyzer. SPEC1 and SPECS specify the token symbols and open, close
+delimiters used. Each SPEC has the form:
+
+\(BLOCK-SYM (OPEN-DELIM OPEN-SYM) (CLOSE-DELIM CLOSE-SYM))
+
+where BLOCK-SYM is the symbol returned in a block token. OPEN-DELIM
+and CLOSE-DELIM are respectively the open and close delimiters
+identifying a block. OPEN-SYM and CLOSE-SYM are respectively the
+symbols returned in open and close tokens."
+ (let ((specs (cons spec1 specs))
+ spec open olist clist)
+ (while specs
+ (setq spec (car specs)
+ specs (cdr specs)
+ open (nth 1 spec)
+ ;; build alist ((OPEN-DELIM OPEN-SYM BLOCK-SYM) ...)
+ olist (cons (list (car open) (cadr open) (car spec)) olist)
+ ;; build alist ((CLOSE-DELIM CLOSE-SYM) ...)
+ clist (cons (nth 2 spec) clist)))
+ `(define-lex-analyzer ,name
+ ,doc
+ (and
+ (looking-at "\\(\\s(\\|\\s)\\)")
+ (let ((text (match-string 0)) match)
+ (cond
+ ((setq match (assoc text ',olist))
+ (if (or (not semantic-lex-maximum-depth)
+ (< semantic-lex-current-depth semantic-lex-maximum-depth))
+ (progn
+ (setq semantic-lex-current-depth (1+
semantic-lex-current-depth))
+ (semantic-lex-push-token
+ (semantic-lex-token
+ (nth 1 match)
+ (match-beginning 0) (match-end 0))))
+ (semantic-lex-push-token
+ (semantic-lex-token
+ (nth 2 match)
+ (match-beginning 0)
+ (save-excursion
+ (semantic-lex-unterminated-syntax-protection (nth 2 match)
+ (forward-list 1)
+ (point)))
+ ))
+ ))
+ ((setq match (assoc text ',clist))
+ (setq semantic-lex-current-depth (1- semantic-lex-current-depth))
+ (semantic-lex-push-token
+ (semantic-lex-token
+ (nth 1 match)
+ (match-beginning 0) (match-end 0)))))))
+ )))
+
+;;; Analyzers
+;;
+;; Pre-defined common analyzers.
+;;
+(define-lex-analyzer semantic-lex-default-action
+ "The default action when no other lexical actions match text.
+This action will just throw an error."
+ t
+ (error "Unmatched Text during Lexical Analysis"))
+
+(define-lex-analyzer semantic-lex-beginning-of-line
+ "Detect and create a beginning of line token (BOL)."
+ (and (bolp)
+ ;; Just insert a (bol N . N) token in the token stream,
+ ;; without moving the point. N is the point at the
+ ;; beginning of line.
+ (semantic-lex-push-token (semantic-lex-token 'bol (point) (point)))
+ nil) ;; CONTINUE
+ ;; We identify and add the BOL token onto the stream, but since
+ ;; semantic-lex-end-point doesn't move, we always fail CONDITION, and have no
+ ;; FORMS body.
+ nil)
+
+(define-lex-simple-regex-analyzer semantic-lex-newline
+ "Detect and create newline tokens."
+ "\\s-*\\(\n\\|\\s>\\)" 'newline 1)
+
+(define-lex-regex-analyzer semantic-lex-newline-as-whitespace
+ "Detect and create newline tokens.
+Use this ONLY if newlines are not whitespace characters (such as when
+they are comment end characters) AND when you want whitespace tokens."
+ "\\s-*\\(\n\\|\\s>\\)"
+ ;; Language wants whitespaces. Create a token for it.
+ (if (eq (semantic-lex-token-class (car semantic-lex-token-stream))
+ 'whitespace)
+ ;; Merge whitespace tokens together if they are adjacent. Two
+ ;; whitespace tokens may be sperated by a comment which is not in
+ ;; the token stream.
+ (setcdr (semantic-lex-token-bounds (car semantic-lex-token-stream))
+ (match-end 0))
+ (semantic-lex-push-token
+ (semantic-lex-token
+ 'whitespace (match-beginning 0) (match-end 0)))))
+
+(define-lex-regex-analyzer semantic-lex-ignore-newline
+ "Detect and ignore newline tokens.
+Use this ONLY if newlines are not whitespace characters (such as when
+they are comment end characters)."
+ "\\s-*\\(\n\\|\\s>\\)"
+ (setq semantic-lex-end-point (match-end 0)))
+
+(define-lex-regex-analyzer semantic-lex-whitespace
+ "Detect and create whitespace tokens."
+ ;; catch whitespace when needed
+ "\\s-+"
+ ;; Language wants whitespaces. Create a token for it.
+ (if (eq (semantic-lex-token-class (car semantic-lex-token-stream))
+ 'whitespace)
+ ;; Merge whitespace tokens together if they are adjacent. Two
+ ;; whitespace tokens may be sperated by a comment which is not in
+ ;; the token stream.
+ (progn
+ (setq semantic-lex-end-point (match-end 0))
+ (setcdr (semantic-lex-token-bounds (car semantic-lex-token-stream))
+ semantic-lex-end-point))
+ (semantic-lex-push-token
+ (semantic-lex-token
+ 'whitespace (match-beginning 0) (match-end 0)))))
+
+(define-lex-regex-analyzer semantic-lex-ignore-whitespace
+ "Detect and skip over whitespace tokens."
+ ;; catch whitespace when needed
+ "\\s-+"
+ ;; Skip over the detected whitespace, do not create a token for it.
+ (setq semantic-lex-end-point (match-end 0)))
+
+(define-lex-simple-regex-analyzer semantic-lex-number
+ "Detect and create number tokens.
+See `semantic-lex-number-expression' for details on matching numbers,
+and number formats."
+ semantic-lex-number-expression 'number)
+
+(define-lex-regex-analyzer semantic-lex-symbol-or-keyword
+ "Detect and create symbol and keyword tokens."
+ "\\(\\sw\\|\\s_\\)+"
+ (semantic-lex-push-token
+ (semantic-lex-token
+ (or (semantic-lex-keyword-p (match-string 0)) 'symbol)
+ (match-beginning 0) (match-end 0))))
+
+(define-lex-simple-regex-analyzer semantic-lex-charquote
+ "Detect and create charquote tokens."
+ ;; Character quoting characters (ie, \n as newline)
+ "\\s\\+" 'charquote)
+
+(define-lex-simple-regex-analyzer semantic-lex-punctuation
+ "Detect and create punctuation tokens."
+ "\\(\\s.\\|\\s$\\|\\s'\\)" 'punctuation)
+
+(define-lex-analyzer semantic-lex-punctuation-type
+ "Detect and create a punctuation type token.
+Recognized punctuations are defined in the current table of lexical
+types, as the value of the `punctuation' token type."
+ (and (looking-at "\\(\\s.\\|\\s$\\|\\s'\\)+")
+ (let* ((key (match-string 0))
+ (pos (match-beginning 0))
+ (end (match-end 0))
+ (len (- end pos))
+ (lst (semantic-lex-type-value "punctuation" t))
+ (def (car lst)) ;; default lexical symbol or nil
+ (lst (cdr lst)) ;; alist of (LEX-SYM . PUNCT-STRING)
+ (elt nil))
+ (if lst
+ ;; Starting with the longest one, search if the
+ ;; punctuation string is defined for this language.
+ (while (and (> len 0) (not (setq elt (rassoc key lst))))
+ (setq len (1- len)
+ key (substring key 0 len))))
+ (if elt ;; Return the punctuation token found
+ (semantic-lex-push-token
+ (semantic-lex-token (car elt) pos (+ pos len)))
+ (if def ;; Return a default generic token
+ (semantic-lex-push-token
+ (semantic-lex-token def pos end))
+ ;; Nothing match
+ )))))
+
+(define-lex-regex-analyzer semantic-lex-paren-or-list
+ "Detect open parenthesis.
+Return either a paren token or a semantic list token depending on
+`semantic-lex-current-depth'."
+ "\\s("
+ (if (or (not semantic-lex-maximum-depth)
+ (< semantic-lex-current-depth semantic-lex-maximum-depth))
+ (progn
+ (setq semantic-lex-current-depth (1+ semantic-lex-current-depth))
+ (semantic-lex-push-token
+ (semantic-lex-token
+ 'open-paren (match-beginning 0) (match-end 0))))
+ (semantic-lex-push-token
+ (semantic-lex-token
+ 'semantic-list (match-beginning 0)
+ (save-excursion
+ (semantic-lex-unterminated-syntax-protection 'semantic-list
+ (forward-list 1)
+ (point))
+ )))
+ ))
+
+(define-lex-simple-regex-analyzer semantic-lex-open-paren
+ "Detect and create an open parenthisis token."
+ "\\s(" 'open-paren 0 (setq semantic-lex-current-depth (1+
semantic-lex-current-depth)))
+
+(define-lex-simple-regex-analyzer semantic-lex-close-paren
+ "Detect and create a close paren token."
+ "\\s)" 'close-paren 0 (setq semantic-lex-current-depth (1-
semantic-lex-current-depth)))
+
+(define-lex-regex-analyzer semantic-lex-string
+ "Detect and create a string token."
+ "\\s\""
+ ;; Zing to the end of this string.
+ (semantic-lex-push-token
+ (semantic-lex-token
+ 'string (point)
+ (save-excursion
+ (semantic-lex-unterminated-syntax-protection 'string
+ (forward-sexp 1)
+ (point))
+ ))))
+
+(define-lex-regex-analyzer semantic-lex-comments
+ "Detect and create a comment token."
+ semantic-lex-comment-regex
+ (save-excursion
+ (forward-comment 1)
+ ;; Generate newline token if enabled
+ (if (bolp) (backward-char 1))
+ (setq semantic-lex-end-point (point))
+ ;; Language wants comments or want them as whitespaces,
+ ;; link them together.
+ (if (eq (semantic-lex-token-class (car semantic-lex-token-stream))
'comment)
+ (setcdr (semantic-lex-token-bounds (car semantic-lex-token-stream))
+ semantic-lex-end-point)
+ (semantic-lex-push-token
+ (semantic-lex-token
+ 'comment (match-beginning 0) semantic-lex-end-point)))))
+
+(define-lex-regex-analyzer semantic-lex-comments-as-whitespace
+ "Detect comments and create a whitespace token."
+ semantic-lex-comment-regex
+ (save-excursion
+ (forward-comment 1)
+ ;; Generate newline token if enabled
+ (if (bolp) (backward-char 1))
+ (setq semantic-lex-end-point (point))
+ ;; Language wants comments or want them as whitespaces,
+ ;; link them together.
+ (if (eq (semantic-lex-token-class (car semantic-lex-token-stream))
'whitespace)
+ (setcdr (semantic-lex-token-bounds (car semantic-lex-token-stream))
+ semantic-lex-end-point)
+ (semantic-lex-push-token
+ (semantic-lex-token
+ 'whitespace (match-beginning 0) semantic-lex-end-point)))))
+
+(define-lex-regex-analyzer semantic-lex-ignore-comments
+ "Detect and create a comment token."
+ semantic-lex-comment-regex
+ (let ((comment-start-point (point)))
+ (forward-comment 1)
+ (if (eq (point) comment-start-point)
+ ;; In this case our start-skip string failed
+ ;; to work properly. Lets try and move over
+ ;; whatever white space we matched to begin
+ ;; with.
+ (skip-syntax-forward "-.'"
+ (save-excursion
+ (end-of-line)
+ (point)))
+ ;; We may need to back up so newlines or whitespace is generated.
+ (if (bolp)
+ (backward-char 1)))
+ (if (eq (point) comment-start-point)
+ (error "Strange comment syntax prevents lexical analysis"))
+ (setq semantic-lex-end-point (point))))
+
+;;; Comment lexer
+;;
+;; Predefined lexers that could be used instead of creating new
+;; analyers.
+
+(define-lex semantic-comment-lexer
+ "A simple lexical analyzer that handles comments.
+This lexer will only return comment tokens. It is the default lexer
+used by `semantic-find-doc-snarf-comment' to snarf up the comment at
+point."
+ semantic-lex-ignore-whitespace
+ semantic-lex-ignore-newline
+ semantic-lex-comments
+ semantic-lex-default-action)
+
+;;; Test Lexer
+;;
+(define-lex semantic-simple-lexer
+ "A simple lexical analyzer that handles simple buffers.
+This lexer ignores comments and whitespace, and will return
+syntax as specified by the syntax table."
+ semantic-lex-ignore-whitespace
+ semantic-lex-ignore-newline
+ semantic-lex-number
+ semantic-lex-symbol-or-keyword
+ semantic-lex-charquote
+ semantic-lex-paren-or-list
+ semantic-lex-close-paren
+ semantic-lex-string
+ semantic-lex-ignore-comments
+ semantic-lex-punctuation
+ semantic-lex-default-action)
+
+;;; Analyzers generated from grammar.
+;;
+;; Some analyzers are hand written. Analyzers created with these
+;; functions are generated from the grammar files.
+
+(defmacro define-lex-keyword-type-analyzer (name doc syntax)
+ "Define a keyword type analyzer NAME with DOC string.
+SYNTAX is the regexp that matches a keyword syntactic expression."
+ (let ((key (make-symbol "key")))
+ `(define-lex-analyzer ,name
+ ,doc
+ (and (looking-at ,syntax)
+ (let ((,key (semantic-lex-keyword-p (match-string 0))))
+ (when ,key
+ (semantic-lex-push-token
+ (semantic-lex-token
+ ,key (match-beginning 0) (match-end 0)))))))
+ ))
+
+(defmacro define-lex-sexp-type-analyzer (name doc syntax token)
+ "Define a sexp type analyzer NAME with DOC string.
+SYNTAX is the regexp that matches the beginning of the s-expression.
+TOKEN is the lexical token returned when SYNTAX matches."
+ `(define-lex-regex-analyzer ,name
+ ,doc
+ ,syntax
+ (semantic-lex-push-token
+ (semantic-lex-token
+ ,token (point)
+ (save-excursion
+ (semantic-lex-unterminated-syntax-protection ,token
+ (forward-sexp 1)
+ (point))))))
+ )
+
+(defmacro define-lex-regex-type-analyzer (name doc syntax matches default)
+ "Define a regexp type analyzer NAME with DOC string.
+SYNTAX is the regexp that matches a syntactic expression.
+MATCHES is an alist of lexical elements used to refine the syntactic
+expression.
+DEFAULT is the default lexical token returned when no MATCHES."
+ (if matches
+ (let* ((val (make-symbol "val"))
+ (lst (make-symbol "lst"))
+ (elt (make-symbol "elt"))
+ (pos (make-symbol "pos"))
+ (end (make-symbol "end")))
+ `(define-lex-analyzer ,name
+ ,doc
+ (and (looking-at ,syntax)
+ (let* ((,val (match-string 0))
+ (,pos (match-beginning 0))
+ (,end (match-end 0))
+ (,lst ,matches)
+ ,elt)
+ (while (and ,lst (not ,elt))
+ (if (string-match (cdar ,lst) ,val)
+ (setq ,elt (caar ,lst))
+ (setq ,lst (cdr ,lst))))
+ (semantic-lex-push-token
+ (semantic-lex-token (or ,elt ,default) ,pos ,end))))
+ ))
+ `(define-lex-simple-regex-analyzer ,name
+ ,doc
+ ,syntax ,default)
+ ))
+
+(defmacro define-lex-string-type-analyzer (name doc syntax matches default)
+ "Define a string type analyzer NAME with DOC string.
+SYNTAX is the regexp that matches a syntactic expression.
+MATCHES is an alist of lexical elements used to refine the syntactic
+expression.
+DEFAULT is the default lexical token returned when no MATCHES."
+ (if matches
+ (let* ((val (make-symbol "val"))
+ (lst (make-symbol "lst"))
+ (elt (make-symbol "elt"))
+ (pos (make-symbol "pos"))
+ (end (make-symbol "end"))
+ (len (make-symbol "len")))
+ `(define-lex-analyzer ,name
+ ,doc
+ (and (looking-at ,syntax)
+ (let* ((,val (match-string 0))
+ (,pos (match-beginning 0))
+ (,end (match-end 0))
+ (,len (- ,end ,pos))
+ (,lst ,matches)
+ ,elt)
+ ;; Starting with the longest one, search if a lexical
+ ;; value match a token defined for this language.
+ (while (and (> ,len 0) (not (setq ,elt (rassoc ,val ,lst))))
+ (setq ,len (1- ,len)
+ ,val (substring ,val 0 ,len)))
+ (when ,elt ;; Adjust token end position.
+ (setq ,elt (car ,elt)
+ ,end (+ ,pos ,len)))
+ (semantic-lex-push-token
+ (semantic-lex-token (or ,elt ,default) ,pos ,end))))
+ ))
+ `(define-lex-simple-regex-analyzer ,name
+ ,doc
+ ,syntax ,default)
+ ))
+
+(defmacro define-lex-block-type-analyzer (name doc syntax matches)
+ "Define a block type analyzer NAME with DOC string.
+
+SYNTAX is the regexp that matches block delimiters, typically the
+open (`\\\\s(') and close (`\\\\s)') parenthesis syntax classes.
+
+MATCHES is a pair (OPEN-SPECS . CLOSE-SPECS) that defines blocks.
+
+ OPEN-SPECS is a list of (OPEN-DELIM OPEN-TOKEN BLOCK-TOKEN) elements
+ where:
+
+ OPEN-DELIM is a string: the block open delimiter character.
+
+ OPEN-TOKEN is the lexical token class associated to the OPEN-DELIM
+ delimiter.
+
+ BLOCK-TOKEN is the lexical token class associated to the block
+ that starts at the OPEN-DELIM delimiter.
+
+ CLOSE-SPECS is a list of (CLOSE-DELIM CLOSE-TOKEN) elements where:
+
+ CLOSE-DELIM is a string: the block end delimiter character.
+
+ CLOSE-TOKEN is the lexical token class associated to the
+ CLOSE-DELIM delimiter.
+
+Each element in OPEN-SPECS must have a corresponding element in
+CLOSE-SPECS.
+
+The lexer will return a BLOCK-TOKEN token when the value of
+`semantic-lex-current-depth' is greater than or equal to the maximum
+depth of parenthesis tracking (see also the function `semantic-lex').
+Otherwise it will return OPEN-TOKEN and CLOSE-TOKEN tokens.
+
+TO DO: Put the following in the developer's guide and just put a
+reference here.
+
+In the grammar:
+
+The value of a block token must be a string that contains a readable
+sexp of the form:
+
+ \"(OPEN-TOKEN CLOSE-TOKEN)\"
+
+OPEN-TOKEN and CLOSE-TOKEN represent the block delimiters, and must be
+lexical tokens of respectively `open-paren' and `close-paren' types.
+Their value is the corresponding delimiter character as a string.
+
+Here is a small example to analyze a parenthesis block:
+
+ %token <block> PAREN_BLOCK \"(LPAREN RPAREN)\"
+ %token <open-paren> LPAREN \"(\"
+ %token <close-paren> RPAREN \")\"
+
+When the lexer encounters the open-paren delimiter \"(\":
+
+ - If the maximum depth of parenthesis tracking is not reached (that
+ is, current depth < max depth), it returns a (LPAREN start . end)
+ token, then continue analysis inside the block. Later, when the
+ corresponding close-paren delimiter \")\" will be encountered, it
+ will return a (RPAREN start . end) token.
+
+ - If the maximum depth of parenthesis tracking is reached (current
+ depth >= max depth), it returns the whole parenthesis block as
+ a (PAREN_BLOCK start . end) token."
+ (let* ((val (make-symbol "val"))
+ (lst (make-symbol "lst"))
+ (elt (make-symbol "elt")))
+ `(define-lex-analyzer ,name
+ ,doc
+ (and
+ (looking-at ,syntax) ;; "\\(\\s(\\|\\s)\\)"
+ (let ((,val (match-string 0))
+ (,lst ,matches)
+ ,elt)
+ (cond
+ ((setq ,elt (assoc ,val (car ,lst)))
+ (if (or (not semantic-lex-maximum-depth)
+ (< semantic-lex-current-depth semantic-lex-maximum-depth))
+ (progn
+ (setq semantic-lex-current-depth (1+
semantic-lex-current-depth))
+ (semantic-lex-push-token
+ (semantic-lex-token
+ (nth 1 ,elt)
+ (match-beginning 0) (match-end 0))))
+ (semantic-lex-push-token
+ (semantic-lex-token
+ (nth 2 ,elt)
+ (match-beginning 0)
+ (save-excursion
+ (semantic-lex-unterminated-syntax-protection (nth 2 ,elt)
+ (forward-list 1)
+ (point)))))))
+ ((setq ,elt (assoc ,val (cdr ,lst)))
+ (setq semantic-lex-current-depth (1- semantic-lex-current-depth))
+ (semantic-lex-push-token
+ (semantic-lex-token
+ (nth 1 ,elt)
+ (match-beginning 0) (match-end 0))))
+ ))))
+ ))
+
+;;; Lexical Safety
+;;
+;; The semantic lexers, unlike other lexers, can throw errors on
+;; unbalanced syntax. Since editing is all about changeging test
+;; we need to provide a convenient way to protect against syntactic
+;; inequalities.
+
+(defmacro semantic-lex-catch-errors (symbol &rest forms)
+ "Using SYMBOL, execute FORMS catching lexical errors.
+If FORMS results in a call to the parser that throws a lexical error,
+the error will be caught here without the buffer's cache being thrown
+out of date.
+If there is an error, the syntax that failed is returned.
+If there is no error, then the last value of FORMS is returned."
+ (let ((ret (make-symbol "ret"))
+ (syntax (make-symbol "syntax"))
+ (start (make-symbol "start"))
+ (end (make-symbol "end")))
+ `(let* ((semantic-lex-unterminated-syntax-end-function
+ (lambda (,syntax ,start ,end)
+ (throw ',symbol ,syntax)))
+ ;; Delete the below when semantic-flex is fully retired.
+ (semantic-flex-unterminated-syntax-end-function
+ semantic-lex-unterminated-syntax-end-function)
+ (,ret (catch ',symbol
+ (save-excursion
+ ,@forms
+ nil))))
+ ;; Great Sadness. Assume that FORMS execute within the
+ ;; confines of the current buffer only! Mark this thing
+ ;; unparseable iff the special symbol was thrown. This
+ ;; will prevent future calls from parsing, but will allow
+ ;; then to still return the cache.
+ (when ,ret
+ ;; Leave this message off. If an APP using this fcn wants
+ ;; a message, they can do it themselves. This cleans up
+ ;; problems with the idle scheduler obscuring useful data.
+ ;;(message "Buffer not currently parsable (%S)." ,ret)
+ (semantic-parse-tree-unparseable))
+ ,ret)))
+(put 'semantic-lex-catch-errors 'lisp-indent-function 1)
+
+
+;;; Interfacing with edebug
+;;
+(add-hook
+ 'edebug-setup-hook
+ #'(lambda ()
+
+ (def-edebug-spec define-lex
+ (&define name stringp (&rest symbolp))
+ )
+ (def-edebug-spec define-lex-analyzer
+ (&define name stringp form def-body)
+ )
+ (def-edebug-spec define-lex-regex-analyzer
+ (&define name stringp form def-body)
+ )
+ (def-edebug-spec define-lex-simple-regex-analyzer
+ (&define name stringp form symbolp [ &optional form ] def-body)
+ )
+ (def-edebug-spec define-lex-block-analyzer
+ (&define name stringp form (&rest form))
+ )
+ (def-edebug-spec semantic-lex-catch-errors
+ (symbolp def-body)
+ )
+
+ ))
+
+;;; Compatibility with Semantic 1.x lexical analysis
+;;
+;; NOTE: DELETE THIS SOMEDAY SOON
+
+(semantic-alias-obsolete 'semantic-flex-start 'semantic-lex-token-start)
+(semantic-alias-obsolete 'semantic-flex-end 'semantic-lex-token-end)
+(semantic-alias-obsolete 'semantic-flex-text 'semantic-lex-token-text)
+(semantic-alias-obsolete 'semantic-flex-make-keyword-table
'semantic-lex-make-keyword-table)
+(semantic-alias-obsolete 'semantic-flex-keyword-p 'semantic-lex-keyword-p)
+(semantic-alias-obsolete 'semantic-flex-keyword-put 'semantic-lex-keyword-put)
+(semantic-alias-obsolete 'semantic-flex-keyword-get 'semantic-lex-keyword-get)
+(semantic-alias-obsolete 'semantic-flex-map-keywords
'semantic-lex-map-keywords)
+(semantic-alias-obsolete 'semantic-flex-keywords 'semantic-lex-keywords)
+(semantic-alias-obsolete 'semantic-flex-buffer 'semantic-lex-buffer)
+(semantic-alias-obsolete 'semantic-flex-list 'semantic-lex-list)
+
+;; This simple scanner uses the syntax table to generate a stream of
+;; simple tokens of the form:
+;;
+;; (SYMBOL START . END)
+;;
+;; Where symbol is the type of thing it is. START and END mark that
+;; objects boundary.
+
+(defvar semantic-flex-tokens semantic-lex-tokens
+ "An alist of of semantic token types.
+See variable `semantic-lex-tokens'.")
+
+(defvar semantic-flex-unterminated-syntax-end-function
+ (lambda (syntax syntax-start flex-end) flex-end)
+ "Function called when unterminated syntax is encountered.
+This should be set to one function. That function should take three
+parameters. The SYNTAX, or type of syntax which is unterminated.
+SYNTAX-START where the broken syntax begins.
+FLEX-END is where the lexical analysis was asked to end.
+This function can be used for languages that can intelligently fix up
+broken syntax, or the exit lexical analysis via `throw' or `signal'
+when finding unterminated syntax.")
+
+(defvar semantic-flex-extensions nil
+ "Buffer local extensions to the lexical analyzer.
+This should contain an alist with a key of a regex and a data element of
+a function. The function should both move point, and return a lexical
+token of the form:
+ ( TYPE START . END)
+nil is also a valid return value.
+TYPE can be any type of symbol, as long as it doesn't occur as a
+nonterminal in the language definition.")
+(make-variable-buffer-local 'semantic-flex-extensions)
+
+(defvar semantic-flex-syntax-modifications nil
+ "Changes to the syntax table for this buffer.
+These changes are active only while the buffer is being flexed.
+This is a list where each element has the form:
+ (CHAR CLASS)
+CHAR is the char passed to `modify-syntax-entry',
+and CLASS is the string also passed to `modify-syntax-entry' to define
+what syntax class CHAR has.")
+(make-variable-buffer-local 'semantic-flex-syntax-modifications)
+
+(defvar semantic-ignore-comments t
+ "Default comment handling.
+t means to strip comments when flexing. Nil means to keep comments
+as part of the token stream.")
+(make-variable-buffer-local 'semantic-ignore-comments)
+
+(defvar semantic-flex-enable-newlines nil
+ "When flexing, report 'newlines as syntactic elements.
+Useful for languages where the newline is a special case terminator.
+Only set this on a per mode basis, not globally.")
+(make-variable-buffer-local 'semantic-flex-enable-newlines)
+
+(defvar semantic-flex-enable-whitespace nil
+ "When flexing, report 'whitespace as syntactic elements.
+Useful for languages where the syntax is whitespace dependent.
+Only set this on a per mode basis, not globally.")
+(make-variable-buffer-local 'semantic-flex-enable-whitespace)
+
+(defvar semantic-flex-enable-bol nil
+ "When flexing, report beginning of lines as syntactic elements.
+Useful for languages like python which are indentation sensitive.
+Only set this on a per mode basis, not globally.")
+(make-variable-buffer-local 'semantic-flex-enable-bol)
+
+(defvar semantic-number-expression semantic-lex-number-expression
+ "See variable `semantic-lex-number-expression'.")
+(make-variable-buffer-local 'semantic-number-expression)
+
+(defvar semantic-flex-depth 0
+ "Default flexing depth.
+This specifies how many lists to create tokens in.")
+(make-variable-buffer-local 'semantic-flex-depth)
+
+(defun semantic-flex (start end &optional depth length)
+ "Using the syntax table, do something roughly equivalent to flex.
+Semantically check between START and END. Optional argument DEPTH
+indicates at what level to scan over entire lists.
+The return value is a token stream. Each element is a list, such of
+the form (symbol start-expression . end-expression) where SYMBOL
+denotes the token type.
+See `semantic-flex-tokens' variable for details on token types.
+END does not mark the end of the text scanned, only the end of the
+beginning of text scanned. Thus, if a string extends past END, the
+end of the return token will be larger than END. To truly restrict
+scanning, use `narrow-to-region'.
+The last argument, LENGTH specifies that `semantic-flex' should only
+return LENGTH tokens."
+ (message "`semantic-flex' is an obsolete function. Use `define-lex' to
create lexers.")
+ (if (not semantic-flex-keywords-obarray)
+ (setq semantic-flex-keywords-obarray [ nil ]))
+ (let ((ts nil)
+ (pos (point))
+ (ep nil)
+ (curdepth 0)
+ (cs (if comment-start-skip
+ (concat "\\(\\s<\\|" comment-start-skip "\\)")
+ (concat "\\(\\s<\\)")))
+ (newsyntax (copy-syntax-table (syntax-table)))
+ (mods semantic-flex-syntax-modifications)
+ ;; Use the default depth if it is not specified.
+ (depth (or depth semantic-flex-depth)))
+ ;; Update the syntax table
+ (while mods
+ (modify-syntax-entry (car (car mods)) (car (cdr (car mods))) newsyntax)
+ (setq mods (cdr mods)))
+ (with-syntax-table newsyntax
+ (goto-char start)
+ (while (and (< (point) end) (or (not length) (<= (length ts) length)))
+ (cond
+ ;; catch beginning of lines when needed.
+ ;; Must be done before catching any other tokens!
+ ((and semantic-flex-enable-bol
+ (bolp)
+ ;; Just insert a (bol N . N) token in the token stream,
+ ;; without moving the point. N is the point at the
+ ;; beginning of line.
+ (setq ts (cons (cons 'bol (cons (point) (point))) ts))
+ nil)) ;; CONTINUE
+ ;; special extensions, includes whitespace, nl, etc.
+ ((and semantic-flex-extensions
+ (let ((fe semantic-flex-extensions)
+ (r nil))
+ (while fe
+ (if (looking-at (car (car fe)))
+ (setq ts (cons (funcall (cdr (car fe))) ts)
+ r t
+ fe nil
+ ep (point)))
+ (setq fe (cdr fe)))
+ (if (and r (not (car ts))) (setq ts (cdr ts)))
+ r)))
+ ;; catch newlines when needed
+ ((looking-at "\\s-*\\(\n\\|\\s>\\)")
+ (if semantic-flex-enable-newlines
+ (setq ep (match-end 1)
+ ts (cons (cons 'newline
+ (cons (match-beginning 1) ep))
+ ts))))
+ ;; catch whitespace when needed
+ ((looking-at "\\s-+")
+ (if semantic-flex-enable-whitespace
+ ;; Language wants whitespaces, link them together.
+ (if (eq (car (car ts)) 'whitespace)
+ (setcdr (cdr (car ts)) (match-end 0))
+ (setq ts (cons (cons 'whitespace
+ (cons (match-beginning 0)
+ (match-end 0)))
+ ts)))))
+ ;; numbers
+ ((and semantic-number-expression
+ (looking-at semantic-number-expression))
+ (setq ts (cons (cons 'number
+ (cons (match-beginning 0)
+ (match-end 0)))
+ ts)))
+ ;; symbols
+ ((looking-at "\\(\\sw\\|\\s_\\)+")
+ (setq ts (cons (cons
+ ;; Get info on if this is a keyword or not
+ (or (semantic-lex-keyword-p (match-string 0))
+ 'symbol)
+ (cons (match-beginning 0) (match-end 0)))
+ ts)))
+ ;; Character quoting characters (ie, \n as newline)
+ ((looking-at "\\s\\+")
+ (setq ts (cons (cons 'charquote
+ (cons (match-beginning 0) (match-end 0)))
+ ts)))
+ ;; Open parens, or semantic-lists.
+ ((looking-at "\\s(")
+ (if (or (not depth) (< curdepth depth))
+ (progn
+ (setq curdepth (1+ curdepth))
+ (setq ts (cons (cons 'open-paren
+ (cons (match-beginning 0) (match-end 0)))
+ ts)))
+ (setq ts (cons
+ (cons 'semantic-list
+ (cons (match-beginning 0)
+ (save-excursion
+ (condition-case nil
+ (forward-list 1)
+ ;; This case makes flex robust
+ ;; to broken lists.
+ (error
+ (goto-char
+ (funcall
+
semantic-flex-unterminated-syntax-end-function
+ 'semantic-list
+ start end))))
+ (setq ep (point)))))
+ ts))))
+ ;; Close parens
+ ((looking-at "\\s)")
+ (setq ts (cons (cons 'close-paren
+ (cons (match-beginning 0) (match-end 0)))
+ ts))
+ (setq curdepth (1- curdepth)))
+ ;; String initiators
+ ((looking-at "\\s\"")
+ ;; Zing to the end of this string.
+ (setq ts (cons (cons 'string
+ (cons (match-beginning 0)
+ (save-excursion
+ (condition-case nil
+ (forward-sexp 1)
+ ;; This case makes flex
+ ;; robust to broken strings.
+ (error
+ (goto-char
+ (funcall
+
semantic-flex-unterminated-syntax-end-function
+ 'string
+ start end))))
+ (setq ep (point)))))
+ ts)))
+ ;; comments
+ ((looking-at cs)
+ (if (and semantic-ignore-comments
+ (not semantic-flex-enable-whitespace))
+ ;; If the language doesn't deal with comments nor
+ ;; whitespaces, ignore them here.
+ (let ((comment-start-point (point)))
+ (forward-comment 1)
+ (if (eq (point) comment-start-point)
+ ;; In this case our start-skip string failed
+ ;; to work properly. Lets try and move over
+ ;; whatever white space we matched to begin
+ ;; with.
+ (skip-syntax-forward "-.'"
+ (save-excursion
+ (end-of-line)
+ (point)))
+ ;;(forward-comment 1)
+ ;; Generate newline token if enabled
+ (if (and semantic-flex-enable-newlines
+ (bolp))
+ (backward-char 1)))
+ (if (eq (point) comment-start-point)
+ (error "Strange comment syntax prevents lexical analysis"))
+ (setq ep (point)))
+ (let ((tk (if semantic-ignore-comments 'whitespace 'comment)))
+ (save-excursion
+ (forward-comment 1)
+ ;; Generate newline token if enabled
+ (if (and semantic-flex-enable-newlines
+ (bolp))
+ (backward-char 1))
+ (setq ep (point)))
+ ;; Language wants comments or want them as whitespaces,
+ ;; link them together.
+ (if (eq (car (car ts)) tk)
+ (setcdr (cdr (car ts)) ep)
+ (setq ts (cons (cons tk (cons (match-beginning 0) ep))
+ ts))))))
+ ;; punctuation
+ ((looking-at "\\(\\s.\\|\\s$\\|\\s'\\)")
+ (setq ts (cons (cons 'punctuation
+ (cons (match-beginning 0) (match-end 0)))
+ ts)))
+ ;; unknown token
+ (t
+ (error "What is that?")))
+ (goto-char (or ep (match-end 0)))
+ (setq ep nil)))
+ ;; maybe catch the last beginning of line when needed
+ (and semantic-flex-enable-bol
+ (= (point) end)
+ (bolp)
+ (setq ts (cons (cons 'bol (cons (point) (point))) ts)))
+ (goto-char pos)
+ ;;(message "Flexing muscles...done")
+ (nreverse ts)))
+
+(provide 'semantic/lex)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/lex"
+;; End:
+
+;;; semantic/lex.el ends here
Index: cedet/semantic/mru-bookmark.el
===================================================================
RCS file: cedet/semantic/mru-bookmark.el
diff -N cedet/semantic/mru-bookmark.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/mru-bookmark.el 28 Sep 2009 15:15:09 -0000 1.2
@@ -0,0 +1,435 @@
+;;; semantic/mru-bookmark.el --- Automatic bookmark tracking
+
+;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Using editing hooks, track the most recently visited or poked tags,
+;; and keep a list of them, with the current point in from, and sorted
+;; by most recently used.
+;;
+;; I envision this would be used in place of switch-buffers once
+;; someone got the hang of it.
+;;
+;; I'd also like to see this used to provide some nice defaults for
+;; other programs where logical destinations or targets are the tags
+;; that have been recently edited.
+;;
+;; Quick Start:
+;;
+;; M-x global-semantic-mru-bookmark-mode RET
+;;
+;; < edit some code >
+;;
+;; C-x B <select a tag name> RET
+;;
+;; In the above, the history is pre-filled with the tags you recenetly
+;; edited in the order you edited them.
+
+;;; Code:
+
+(require 'semantic)
+(require 'eieio-base)
+(require 'ring)
+
+(declare-function data-debug-new-buffer "data-debug")
+(declare-function data-debug-insert-object-slots "eieio-datadebug")
+(declare-function semantic-momentary-highlight-tag "semantic/decorate")
+
+;;; TRACKING CORE
+;;
+;; Data structure for tracking MRU tag locations
+
+(defclass semantic-bookmark (eieio-named)
+ ((tag :initarg :tag
+ :type semantic-tag
+ :documentation "The TAG this bookmark belongs to.")
+ (parent :type (or semantic-tag null)
+ :documentation "The tag that is the parent of :tag.")
+ (offset :type number
+ :documentation "The offset from `tag' start that is
+somehow interesting.")
+ (filename :type string
+ :documentation "String the tag belongs to.
+Set this when the tag gets unlinked from the buffer it belongs to.")
+ (frequency :type number
+ :initform 0
+ :documentation "Track the frequency this tag is visited.")
+ (reason :type symbol
+ :initform t
+ :documentation
+ "The reason this tag is interesting.
+Nice values are 'edit, 'read, 'jump, and 'mark.
+ edit - created because the tag text was edited.
+ read - created because point lingered in tag text.
+ jump - jumped to another tag from this tag.
+ mark - created a regular mark in this tag.")
+ )
+ "A single bookmark.")
+
+(defmethod initialize-instance :AFTER ((sbm semantic-bookmark) &rest fields)
+ "Initialize the bookmark SBM with details about :tag."
+ (condition-case nil
+ (save-excursion
+ (oset sbm filename (semantic-tag-file-name (oref sbm tag)))
+ (semantic-go-to-tag (oref sbm tag))
+ (oset sbm parent (semantic-current-tag-parent)))
+ (error (message "Error bookmarking tag.")))
+ )
+
+(defmethod semantic-mrub-visit ((sbm semantic-bookmark))
+ "Visit the semantic tag bookmark SBM.
+Uses `semantic-go-to-tag' and highlighting."
+ (require 'semantic/decorate)
+ (with-slots (tag filename) sbm
+ ;; Go to the tag
+ (when (not (semantic-tag-in-buffer-p tag))
+ (let ((fn (or (semantic-tag-file-name tag)
+ filename)))
+ (set-buffer (find-file-noselect fn))))
+ (semantic-go-to-tag (oref sbm tag) (oref sbm parent))
+ ;; Go back to the offset.
+ (condition-case nil
+ (let ((o (oref sbm offset)))
+ (forward-char o))
+ (error nil))
+ ;; make it visible
+ (switch-to-buffer (current-buffer))
+ (semantic-momentary-highlight-tag tag)
+ ))
+
+(defmethod semantic-mrub-update ((sbm semantic-bookmark) point reason)
+ "Update the existing bookmark SBM.
+POINT is some important location.
+REASON is a symbol. See slot `reason' on `semantic-bookmark'."
+ (condition-case nil
+ (progn
+ (with-slots (tag offset frequency) sbm
+ (setq offset (- point (semantic-tag-start tag)))
+ (setq frequency (1+ frequency))
+ )
+ (oset sbm reason reason))
+ ;; This can fail on XEmacs at miscelaneous times.
+ (error nil))
+ )
+
+(defmethod semantic-mrub-preflush ((sbm semantic-bookmark))
+ "Method called on a tag before the current buffer list of tags is flushed.
+If there is a buffer match, unlink the tag."
+ (let ((tag (oref sbm tag))
+ (parent (when (slot-boundp sbm 'parent)
+ (oref sbm parent))))
+ (let ((b (semantic-tag-in-buffer-p tag)))
+ (when (and b (eq b (current-buffer)))
+ (semantic--tag-unlink-from-buffer tag)))
+
+ (when parent
+ (let ((b (semantic-tag-in-buffer-p parent)))
+ (when (and b (eq b (current-buffer)))
+ (semantic--tag-unlink-from-buffer parent))))))
+
+(defclass semantic-bookmark-ring ()
+ ((ring :initarg :ring
+ :type ring
+ :documentation
+ "List of `semantic-bookmark' objects.
+This list is maintained as a list with the first item
+being the current location, and the rest being a list of
+items that were recently visited.")
+ (current-index :initform 0
+ :type number
+ :documentation
+ "The current index into RING for some operation.
+User commands use this to move through the ring, or reset.")
+ )
+ "Track the current MRU stack of bookmarks.
+We can't use the built-in ring data structure because we need
+to delete some items from the ring when we don't have the data.")
+
+(defvar semantic-mru-bookmark-ring (semantic-bookmark-ring
+ "Ring"
+ :ring (make-ring 20))
+ "The MRU bookmark ring.
+This ring tracks the most recent active tags of interest.")
+
+(defun semantic-mrub-find-nearby-tag (point)
+ "Find a nearby tag to be pushed for this current location.
+Argument POINT is where to find the tag near."
+ ;; I thought this was a good idea, but it is not!
+ ;;(semantic-fetch-tags) ;; Make sure everything is up-to-date.
+ (let ((tag (semantic-current-tag)))
+ (when (or (not tag) (semantic-tag-of-class-p tag 'type))
+ (let ((nearby (or (semantic-find-tag-by-overlay-next point)
+ (semantic-find-tag-by-overlay-prev point))))
+ (when nearby (setq tag nearby))))
+ tag))
+
+(defmethod semantic-mrub-push ((sbr semantic-bookmark-ring) point
+ &optional reason)
+ "Add a bookmark to the ring SBR from POINT.
+REASON is why it is being pushed. See doc for `semantic-bookmark'
+for possible reasons.
+The resulting bookmark is then sorted within the ring."
+ (let* ((ring (oref sbr ring))
+ (tag (semantic-mrub-find-nearby-tag (point)))
+ (idx 0))
+ (when tag
+ (while (and (not (ring-empty-p ring)) (< idx (ring-size ring)))
+ (if (semantic-tag-similar-p (oref (ring-ref ring idx) tag)
+ tag)
+ (ring-remove ring idx))
+ (setq idx (1+ idx)))
+ ;; Create a new mark
+ (let ((sbm (semantic-bookmark (semantic-tag-name tag)
+ :tag tag)))
+ ;; Take the mark, and update it for the current state.
+ (ring-insert ring sbm)
+ (semantic-mrub-update sbm point reason))
+ )))
+
+(defun semantic-mrub-cache-flush-fcn ()
+ "Function called in the `semantic-before-toplevel-cache-flush-hook`.
+Cause tags in the ring to become unlinked."
+ (let* ((ring (oref semantic-mru-bookmark-ring ring))
+ (len (ring-length ring))
+ (idx 0)
+ )
+ (while (< idx len)
+ (semantic-mrub-preflush (ring-ref ring idx))
+ (setq idx (1+ idx)))))
+
+(add-hook 'semantic-before-toplevel-cache-flush-hook
+ 'semantic-mrub-cache-flush-fcn)
+
+;;; EDIT tracker
+;;
+(defvar semantic-mrub-last-overlay nil
+ "The last overlay bumped by `semantic-mru-bookmark-change-hook-fcn'.")
+
+(defun semantic-mru-bookmark-change-hook-fcn (overlay)
+ "Function set into `semantic-edits-new/move-change-hook's.
+Argument OVERLAY is the overlay created to mark the change.
+This function pushes tags onto the tag ring."
+ ;; Dup?
+ (when (not (eq overlay semantic-mrub-last-overlay))
+ (setq semantic-mrub-last-overlay overlay)
+ (semantic-mrub-push semantic-mru-bookmark-ring
+ (point)
+ 'edit)))
+
+;;; MINOR MODE
+;;
+;; Tracking minor mode.
+
+(defcustom global-semantic-mru-bookmark-mode nil
+ "*If non-nil enable global use of variable `semantic-mru-bookmark-mode'.
+When this mode is enabled, changes made to a buffer are highlighted
+until the buffer is reparsed."
+ :group 'semantic
+ :group 'semantic-modes
+ :type 'boolean
+ :require 'semantic-util-modes
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (global-semantic-mru-bookmark-mode (if val 1 -1))))
+
+;;;###autoload
+(defun global-semantic-mru-bookmark-mode (&optional arg)
+ "Toggle global use of option `semantic-mru-bookmark-mode'.
+If ARG is positive, enable, if it is negative, disable.
+If ARG is nil, then toggle."
+ (interactive "P")
+ (setq global-semantic-mru-bookmark-mode
+ (semantic-toggle-minor-mode-globally
+ 'semantic-mru-bookmark-mode arg)))
+
+(defcustom semantic-mru-bookmark-mode-hook nil
+ "*Hook run at the end of function `semantic-mru-bookmark-mode'."
+ :group 'semantic
+ :type 'hook)
+
+(defvar semantic-mru-bookmark-mode-map
+ (let ((km (make-sparse-keymap)))
+ (define-key km "\C-xB" 'semantic-mrub-switch-tags)
+ km)
+ "Keymap for mru-bookmark minor mode.")
+
+(defvar semantic-mru-bookmark-mode nil
+ "Non-nil if mru-bookmark minor mode is enabled.
+Use the command `semantic-mru-bookmark-mode' to change this variable.")
+(make-variable-buffer-local 'semantic-mru-bookmark-mode)
+
+(defun semantic-mru-bookmark-mode-setup ()
+ "Setup option `semantic-mru-bookmark-mode'.
+The minor mode can be turned on only if semantic feature is available
+and the current buffer was set up for parsing. When minor mode is
+enabled parse the current buffer if needed. Return non-nil if the
+minor mode is enabled."
+ (if semantic-mru-bookmark-mode
+ (if (not (and (featurep 'semantic) (semantic-active-p)))
+ (progn
+ ;; Disable minor mode if semantic stuff not available
+ (setq semantic-mru-bookmark-mode nil)
+ (error "Buffer %s was not set up for parsing"
+ (buffer-name)))
+ (semantic-make-local-hook 'semantic-edits-new-change-hooks)
+ (add-hook 'semantic-edits-new-change-hooks
+ 'semantic-mru-bookmark-change-hook-fcn nil t)
+ (add-hook 'semantic-edits-move-change-hooks
+ 'semantic-mru-bookmark-change-hook-fcn nil t)
+ )
+ ;; Remove hooks
+ (remove-hook 'semantic-edits-new-change-hooks
+ 'semantic-mru-bookmark-change-hook-fcn t)
+ (remove-hook 'semantic-edits-move-change-hooks
+ 'semantic-mru-bookmark-change-hook-fcn t)
+ )
+ semantic-mru-bookmark-mode)
+
+(defun semantic-mru-bookmark-mode (&optional arg)
+ "Minor mode for tracking tag-based bookmarks automatically.
+Tag based bookmarks a tracked based on editing and viewing habits
+and can then be navigated via the MRU bookmark keymap.
+
+\\{semantic-mru-bookmark-mode-map}
+
+With prefix argument ARG, turn on if positive, otherwise off. The
+minor mode can be turned on only if semantic feature is available and
+the current buffer was set up for parsing. Return non-nil if the
+minor mode is enabled."
+ (interactive
+ (list (or current-prefix-arg
+ (if semantic-mru-bookmark-mode 0 1))))
+ (setq semantic-mru-bookmark-mode
+ (if arg
+ (>
+ (prefix-numeric-value arg)
+ 0)
+ (not semantic-mru-bookmark-mode)))
+ (semantic-mru-bookmark-mode-setup)
+ (run-hooks 'semantic-mru-bookmark-mode-hook)
+ (if (interactive-p)
+ (message "mru-bookmark minor mode %sabled"
+ (if semantic-mru-bookmark-mode "en" "dis")))
+ (semantic-mode-line-update)
+ semantic-mru-bookmark-mode)
+
+(semantic-add-minor-mode 'semantic-mru-bookmark-mode
+ "k"
+ semantic-mru-bookmark-mode-map)
+
+;;; COMPLETING READ
+;;
+;; Ask the user for a tag in MRU order.
+(defun semantic-mrub-read-history nil
+ "History of `semantic-mrub-completing-read'.")
+
+(defun semantic-mrub-ring-to-assoc-list (ring)
+ "Convert RING into an association list for completion."
+ (let ((idx 0)
+ (len (ring-length ring))
+ (al nil))
+ (while (< idx len)
+ (let ((r (ring-ref ring idx)))
+ (setq al (cons (cons (oref r :object-name) r)
+ al)))
+ (setq idx (1+ idx)))
+ (nreverse al)))
+
+(defun semantic-mrub-completing-read (prompt)
+ "Do a `completing-read' on elements from the mru bookmark ring.
+Argument PROMPT is the promot to use when reading."
+ (if (ring-empty-p (oref semantic-mru-bookmark-ring ring))
+ (error "Semantic Bookmark ring is currently empty"))
+ (let* ((ring (oref semantic-mru-bookmark-ring ring))
+ (ans nil)
+ (alist (semantic-mrub-ring-to-assoc-list ring))
+ (first (cdr (car alist)))
+ (semantic-mrub-read-history nil)
+ )
+ ;; Don't include the current tag.. only those that come after.
+ (if (semantic-equivalent-tag-p (oref first tag)
+ (semantic-current-tag))
+ (setq first (cdr (car (cdr alist)))))
+ ;; Create a fake history list so we don't have to bind
+ ;; M-p and M-n to our special cause.
+ (let ((elts (reverse alist)))
+ (while elts
+ (setq semantic-mrub-read-history
+ (cons (car (car elts)) semantic-mrub-read-history))
+ (setq elts (cdr elts))))
+ (setq semantic-mrub-read-history (nreverse semantic-mrub-read-history))
+
+ ;; Do the read/prompt
+ (let ((prompt (if first (format "%s (%s): " prompt
+ (semantic-format-tag-name
+ (oref first tag) t)
+ )
+ (concat prompt ": ")))
+ )
+ (setq ans
+ (completing-read prompt alist nil nil nil
'semantic-mrub-read-history)))
+ ;; Calculate the return tag.
+ (if (string= ans "")
+ (setq ans first)
+ ;; Return the bookmark object.
+ (setq ans (assoc ans alist))
+ (if ans
+ (cdr ans)
+ ;; no match. Custom word. Look it up somwhere?
+ nil)
+ )))
+
+(defun semantic-mrub-switch-tags (tagmark)
+ "Switch tags to TAGMARK.
+Selects a new tag via promt through the mru tag ring.
+Jumps to the tag and highlights it briefly."
+ (interactive (list (semantic-mrub-completing-read "Switch to tag")))
+ (if (not (semantic-bookmark-p tagmark))
+ (signal 'wrong-type-argument tagmark))
+
+ (semantic-mrub-push semantic-mru-bookmark-ring
+ (point)
+ 'jump)
+ (semantic-mrub-visit tagmark)
+ )
+
+;;; Debugging
+;;
+(defun semantic-adebug-mrub ()
+ "Display a list of items in the MRU bookmarks list.
+Useful for debugging mrub problems."
+ (interactive)
+ (require 'eieio-datadebug)
+ (let* ((out semantic-mru-bookmark-ring))
+ (data-debug-new-buffer "*TAG RING ADEBUG*")
+ (data-debug-insert-object-slots out "]")
+ ))
+
+
+(provide 'semantic/mru-bookmark)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/mru-bookmark"
+;; End:
+
+;;; semantic/mru-bookmark.el ends here
Index: cedet/semantic/sb.el
===================================================================
RCS file: cedet/semantic/sb.el
diff -N cedet/semantic/sb.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/sb.el 28 Sep 2009 15:15:09 -0000 1.2
@@ -0,0 +1,420 @@
+;;; semantic/sb.el --- Semantic tag display for speedbar
+
+;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+;;; 2007, 2008 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Convert a tag table into speedbar buttons.
+
+;;; TODO:
+
+;; Use semanticdb to find which semanticdb-table is being used for each
+;; file/tag. Replace `semantic-sb-with-tag-buffer' to instead call
+;; children with the new `with-mode-local' instead.
+
+(require 'semantic)
+(require 'semantic/format)
+(require 'semantic/sort)
+(require 'semantic/util)
+(require 'speedbar)
+(declare-function semanticdb-file-stream "semantic/db")
+
+(defcustom semantic-sb-autoexpand-length 1
+ "*Length of a semantic bucket to autoexpand in place.
+This will replace the named bucket that would have usually occured here."
+ :group 'speedbar
+ :type 'integer)
+
+(defcustom semantic-sb-button-format-tag-function
'semantic-format-tag-abbreviate
+ "*Function called to create the text for a but from a token."
+ :group 'speedbar
+ :type semantic-format-tag-custom-list)
+
+(defcustom semantic-sb-info-format-tag-function 'semantic-format-tag-summarize
+ "*Function called to create the text for info display from a token."
+ :group 'speedbar
+ :type semantic-format-tag-custom-list)
+
+;;; Code:
+;;
+
+;;; Buffer setting for correct mode manipulation.
+(defun semantic-sb-tag-set-buffer (tag)
+ "Set the current buffer to something associated with TAG.
+use the `speedbar-line-file' to get this info if needed."
+ (if (semantic-tag-buffer tag)
+ (set-buffer (semantic-tag-buffer tag))
+ (let ((f (speedbar-line-file)))
+ (set-buffer (find-file-noselect f)))))
+
+(defmacro semantic-sb-with-tag-buffer (tag &rest forms)
+ "Set the current buffer to the origin of TAG and execute FORMS.
+Restore the old current buffer when completed."
+ `(save-excursion
+ (semantic-sb-tag-set-buffer ,tag)
+ ,@forms))
+(put 'semantic-sb-with-tag-buffer 'lisp-indent-function 1)
+
+;;; Button Generation
+;;
+;; Here are some button groups:
+;;
+;; +> Function ()
+;; @ return_type
+;; +( arg1
+;; +| arg2
+;; +) arg3
+;;
+;; +> Variable[1] =
+;; @ type
+;; = default value
+;;
+;; +> keywrd Type
+;; +> type part
+;;
+;; +> -> click to see additional information
+
+(define-overloadable-function semantic-sb-tag-children-to-expand (tag)
+ "For TAG, return a list of children that TAG expands to.
+If this returns a value, then a +> icon is created.
+If it returns nil, then a => icon is created.")
+
+(defun semantic-sb-tag-children-to-expand-default (tag)
+ "For TAG, the children for type, variable, and function classes."
+ (semantic-sb-with-tag-buffer tag
+ (semantic-tag-components tag)))
+
+(defun semantic-sb-one-button (tag depth &optional prefix)
+ "Insert TAG as a speedbar button at DEPTH.
+Optional PREFIX is used to specify special marker characters."
+ (let* ((class (semantic-tag-class tag))
+ (edata (semantic-sb-tag-children-to-expand tag))
+ (type (semantic-tag-type tag))
+ (abbrev (semantic-sb-with-tag-buffer tag
+ (funcall semantic-sb-button-format-tag-function tag)))
+ (start (point))
+ (end (progn
+ (insert (int-to-string depth) ":")
+ (point))))
+ (insert-char ? (1- depth) nil)
+ (put-text-property end (point) 'invisible nil)
+ ;; take care of edata = (nil) -- a yucky but hard to clean case
+ (if (and edata (listp edata) (and (<= (length edata) 1) (not (car edata))))
+ (setq edata nil))
+ (if (and (not edata)
+ (member class '(variable function))
+ type)
+ (setq edata t))
+ ;; types are a bit unique. Variable types can have special meaning.
+ (if edata
+ (speedbar-insert-button (if prefix (concat " +" prefix) " +>")
+ 'speedbar-button-face
+ 'speedbar-highlight-face
+ 'semantic-sb-show-extra
+ tag t)
+ (speedbar-insert-button (if prefix (concat " " prefix) " =>")
+ nil nil nil nil t))
+ (speedbar-insert-button abbrev
+ 'speedbar-tag-face
+ 'speedbar-highlight-face
+ 'semantic-sb-token-jump
+ tag t)
+ ;; This is very bizarre. When this was just after the insertion
+ ;; of the depth: text, the : would get erased, but only for the
+ ;; auto-expanded short- buckets. Move back for a later version
+ ;; version of Emacs 21 CVS
+ (put-text-property start end 'invisible t)
+ ))
+
+(defun semantic-sb-speedbar-data-line (depth button text &optional
+ text-fun text-data)
+ "Insert a semantic token data element.
+DEPTH is the current depth. BUTTON is the text for the button.
+TEXT is the actual info with TEXT-FUN to occur when it happens.
+Argument TEXT-DATA is the token data to pass to TEXT-FUN."
+ (let ((start (point))
+ (end (progn
+ (insert (int-to-string depth) ":")
+ (point))))
+ (put-text-property start end 'invisible t)
+ (insert-char ? depth nil)
+ (put-text-property end (point) 'invisible nil)
+ (speedbar-insert-button button nil nil nil nil t)
+ (speedbar-insert-button text
+ 'speedbar-tag-face
+ (if text-fun 'speedbar-highlight-face)
+ text-fun text-data t)
+ ))
+
+(defun semantic-sb-maybe-token-to-button (obj indent &optional
+ prefix modifiers)
+ "Convert OBJ, which was returned from the semantic parser, into a button.
+This OBJ might be a plain string (simple type or untyped variable)
+or a complete tag.
+Argument INDENT is the indentation used when making the button.
+Optional PREFIX is the character to use when marking the line.
+Optional MODIFIERS is additional text needed for variables."
+ (let ((myprefix (or prefix ">")))
+ (if (stringp obj)
+ (semantic-sb-speedbar-data-line indent myprefix obj)
+ (if (listp obj)
+ (progn
+ (if (and (stringp (car obj))
+ (= (length obj) 1))
+ (semantic-sb-speedbar-data-line indent myprefix
+ (concat
+ (car obj)
+ (or modifiers "")))
+ (semantic-sb-one-button obj indent prefix)))))))
+
+(defun semantic-sb-insert-details (tag indent)
+ "Insert details about TAG at level INDENT."
+ (let ((tt (semantic-tag-class tag))
+ (type (semantic-tag-type tag)))
+ (cond ((eq tt 'type)
+ (let ((parts (semantic-tag-type-members tag))
+ (newparts nil))
+ ;; Lets expect PARTS to be a list of either strings,
+ ;; or variable tokens.
+ (when (semantic-tag-p (car parts))
+ ;; Bucketize into groups
+ (semantic-sb-with-tag-buffer (car parts)
+ (setq newparts (semantic-bucketize parts)))
+ (when (> (length newparts) semantic-sb-autoexpand-length)
+ ;; More than one bucket, insert inline
+ (semantic-sb-insert-tag-table (1- indent) newparts)
+ (setq parts nil))
+ ;; Dump the strings in.
+ (while parts
+ (semantic-sb-maybe-token-to-button (car parts) indent)
+ (setq parts (cdr parts))))))
+ ((eq tt 'variable)
+ (if type
+ (semantic-sb-maybe-token-to-button type indent "@"))
+ (let ((default (semantic-tag-variable-default tag)))
+ (if default
+ (semantic-sb-maybe-token-to-button default indent "=")))
+ )
+ ((eq tt 'function)
+ (if type
+ (semantic-sb-speedbar-data-line
+ indent "@"
+ (if (stringp type) type
+ (semantic-tag-name type))))
+ ;; Arguments to the function
+ (let ((args (semantic-tag-function-arguments tag)))
+ (if (and args (car args))
+ (progn
+ (semantic-sb-maybe-token-to-button (car args) indent "(")
+ (setq args (cdr args))
+ (while (> (length args) 1)
+ (semantic-sb-maybe-token-to-button (car args)
+ indent
+ "|")
+ (setq args (cdr args)))
+ (if args
+ (semantic-sb-maybe-token-to-button
+ (car args) indent ")"))
+ ))))
+ (t
+ (let ((components
+ (save-excursion
+ (when (and (semantic-tag-overlay tag)
+ (semantic-tag-buffer tag))
+ (set-buffer (semantic-tag-buffer tag)))
+ (semantic-sb-tag-children-to-expand tag))))
+ ;; Well, it wasn't one of the many things we expect.
+ ;; Lets just insert them in with no decoration.
+ (while components
+ (semantic-sb-one-button (car components) indent)
+ (setq components (cdr components)))
+ ))
+ )
+ ))
+
+(defun semantic-sb-detail-parent ()
+ "Return the first parent token of the current line that includes a location."
+ (save-excursion
+ (beginning-of-line)
+ (let ((dep (if (looking-at "[0-9]+:")
+ (1- (string-to-number (match-string 0)))
+ 0)))
+ (re-search-backward (concat "^"
+ (int-to-string dep)
+ ":")
+ nil t))
+ (beginning-of-line)
+ (if (looking-at "[0-9]+: +[-+][>()@|] \\([^\n]+\\)$")
+ (let ((prop nil))
+ (goto-char (match-beginning 1))
+ (setq prop (get-text-property (point) 'speedbar-token))
+ (if (semantic-tag-with-position-p prop)
+ prop
+ (semantic-sb-detail-parent)))
+ nil)))
+
+(defun semantic-sb-show-extra (text token indent)
+ "Display additional information about the token as an expansion.
+TEXT TOKEN and INDENT are the details."
+ (cond ((string-match "+" text) ;we have to expand this file
+ (speedbar-change-expand-button-char ?-)
+ (speedbar-with-writable
+ (save-excursion
+ (end-of-line) (forward-char 1)
+ (save-restriction
+ (narrow-to-region (point) (point))
+ ;; Add in stuff specific to this type of token.
+ (semantic-sb-insert-details token (1+ indent))))))
+ ((string-match "-" text) ;we have to contract this node
+ (speedbar-change-expand-button-char ?+)
+ (speedbar-delete-subblock indent))
+ (t (error "Ooops... not sure what to do")))
+ (speedbar-center-buffer-smartly))
+
+(defun semantic-sb-token-jump (text token indent)
+ "Jump to the location specified in token.
+TEXT TOKEN and INDENT are the details."
+ (let ((file
+ (or
+ (cond ((fboundp 'speedbar-line-path)
+ (speedbar-line-directory indent))
+ ((fboundp 'speedbar-line-directory)
+ (speedbar-line-directory indent)))
+ ;; If speedbar cannot figure this out, extract the filename from
+ ;; the token. True for Analysis mode.
+ (semantic-tag-file-name token)))
+ (parent (semantic-sb-detail-parent)))
+ (let ((f (selected-frame)))
+ (dframe-select-attached-frame speedbar-frame)
+ (run-hooks 'speedbar-before-visiting-tag-hook)
+ (select-frame f))
+ ;; Sometimes FILE may be nil here. If you are debugging a problem
+ ;; when this happens, go back and figure out why FILE is nil and try
+ ;; and fix the source.
+ (speedbar-find-file-in-frame file)
+ (save-excursion (speedbar-stealthy-updates))
+ (semantic-go-to-tag token parent)
+ (switch-to-buffer (current-buffer))
+ ;; Reset the timer with a new timeout when cliking a file
+ ;; in case the user was navigating directories, we can cancel
+ ;; that other timer.
+ ;; (speedbar-set-timer dframe-update-speed)
+ ;;(recenter)
+ (speedbar-maybee-jump-to-attached-frame)
+ (run-hooks 'speedbar-visiting-tag-hook)))
+
+(defun semantic-sb-expand-group (text token indent)
+ "Expand a group which has semantic tokens.
+TEXT TOKEN and INDENT are the details."
+ (cond ((string-match "+" text) ;we have to expand this file
+ (speedbar-change-expand-button-char ?-)
+ (speedbar-with-writable
+ (save-excursion
+ (end-of-line) (forward-char 1)
+ (save-restriction
+ (narrow-to-region (point-min) (point))
+ (semantic-sb-buttons-plain (1+ indent) token)))))
+ ((string-match "-" text) ;we have to contract this node
+ (speedbar-change-expand-button-char ?+)
+ (speedbar-delete-subblock indent))
+ (t (error "Ooops... not sure what to do")))
+ (speedbar-center-buffer-smartly))
+
+(defun semantic-sb-buttons-plain (level tokens)
+ "Create buttons at LEVEL using TOKENS."
+ (let ((sordid (speedbar-create-tag-hierarchy tokens)))
+ (while sordid
+ (cond ((null (car-safe sordid)) nil)
+ ((consp (car-safe (cdr-safe (car-safe sordid))))
+ ;; A group!
+ (speedbar-make-tag-line 'curly ?+ 'semantic-sb-expand-group
+ (cdr (car sordid))
+ (car (car sordid))
+ nil nil 'speedbar-tag-face
+ level))
+ (t ;; Assume that this is a token.
+ (semantic-sb-one-button (car sordid) level)))
+ (setq sordid (cdr sordid)))))
+
+(defun semantic-sb-insert-tag-table (level table)
+ "At LEVEL, insert the tag table TABLE.
+Use arcane knowledge about the semantic tokens in the tagged elements
+to create much wiser decisions about how to sort and group these items."
+ (semantic-sb-buttons level table))
+
+(defun semantic-sb-buttons (level lst)
+ "Create buttons at LEVEL using LST sorting into type buckets."
+ (save-restriction
+ (narrow-to-region (point-min) (point))
+ (let (tmp)
+ (while lst
+ (setq tmp (car lst))
+ (if (cdr tmp)
+ (if (<= (length (cdr tmp)) semantic-sb-autoexpand-length)
+ (semantic-sb-buttons-plain (1+ level) (cdr tmp))
+ (speedbar-make-tag-line 'curly ?+ 'semantic-sb-expand-group
+ (cdr tmp)
+ (car (car lst))
+ nil nil 'speedbar-tag-face
+ (1+ level))))
+ (setq lst (cdr lst))))))
+
+(defun semantic-sb-fetch-tag-table (file)
+ "Load FILE into a buffer, and generate tags using the Semantic parser.
+Returns the tag list, or t for an error."
+ (let ((out nil))
+ (if (and (featurep 'semantic/db)
+ (semanticdb-minor-mode-p)
+ (not speedbar-power-click)
+ ;; If the database is loaded and running, try to get
+ ;; tokens from it.
+ (setq out (semanticdb-file-stream file)))
+ ;; Successful DB query.
+ nil
+ ;; No database, do it the old way.
+ (save-excursion
+ (set-buffer (find-file-noselect file))
+ (if (or (not (featurep 'semantic))
+ (not semantic--parse-table))
+ (setq out t)
+ (if speedbar-power-click (semantic-clear-toplevel-cache))
+ (setq out (semantic-fetch-tags)))))
+ (if (listp out)
+ (condition-case nil
+ (progn
+ ;; This brings externally defind methods into
+ ;; their classes, and creates meta classes for
+ ;; orphans.
+ (setq out (semantic-adopt-external-members out))
+ ;; Dump all the tokens into buckets.
+ (semantic-sb-with-tag-buffer (car out)
+ (semantic-bucketize out)))
+ (error t))
+ t)))
+
+;; Link ourselves into the tagging process.
+(add-to-list 'speedbar-dynamic-tags-function-list
+ '(semantic-sb-fetch-tag-table . semantic-sb-insert-tag-table))
+
+(provide 'semantic/sb)
+
+;;; semantic/sb.el ends here
Index: cedet/semantic/scope.el
===================================================================
RCS file: cedet/semantic/scope.el
diff -N cedet/semantic/scope.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/scope.el 28 Sep 2009 15:15:09 -0000 1.2
@@ -0,0 +1,816 @@
+;;; semantic/scope.el --- Analyzer Scope Calculations
+
+;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Calculate information about the current scope.
+;;
+;; Manages the current scope as a structure that can be cached on a
+;; per-file basis and recycled between different occurances of
+;; analysis on different parts of a file.
+;;
+;; Pattern for Scope Calculation
+;;
+;; Step 1: Calculate DataTypes in Scope:
+;;
+;; a) What is in scope via using statements or local namespaces
+;; b) Lineage of current context. Some names drawn from step 1.
+;;
+;; Step 2: Convert type names into lists of concrete tags
+;;
+;; a) Convert each datatype into the real datatype tag
+;; b) Convert namespaces into the list of contents of the namespace.
+;; c) Merge all existing scopes together into one search list.
+;;
+;; Step 3: Local variables
+;;
+;; a) Local variables are in the master search list.
+;;
+
+(require 'semantic/db)
+(require 'semantic/analyze/fcn)
+(require 'semantic/ctxt)
+
+(eval-when-compile (require 'semantic/find))
+
+(declare-function data-debug-show "eieio-datadebug")
+(declare-function semantic-analyze-find-tag "semantic/analyze")
+(declare-function semantic-analyze-princ-sequence "semantic/analyze")
+(declare-function semanticdb-typecache-merge-streams "semantic/db-typecache")
+(declare-function semanticdb-typecache-add-dependant "semantic/db-typecache")
+
+;;; Code:
+
+(defclass semantic-scope-cache (semanticdb-abstract-cache)
+ ((tag :initform nil
+ :documentation
+ "The tag this scope was calculated for.")
+ (scopetypes :initform nil
+ :documentation
+ "The list of types currently in scope.
+For C++, this would contain anonymous namespaces known, and
+anything labled by a `using' statement.")
+ (parents :initform nil
+ :documentation
+ "List of parents in scope w/in the body of this function.
+Presumably, the members of these parent classes are available for access
+based on private:, or public: style statements.")
+ (parentinheritance :initform nil
+ :documentation "Alist of parents by inheritance.
+Each entry is ( PARENT . PROTECTION ), where PARENT is a type, and
+PROTECTION is a symbol representing the level of inheritance, such as
'private, or 'protected.")
+ (scope :initform nil
+ :documentation
+ "Items in scope due to the scopetypes or parents.")
+ (fullscope :initform nil
+ :documentation
+ "All the other stuff on one master list you can search.")
+ (localargs :initform nil
+ :documentation
+ "The arguments to the function tag.")
+ (localvar :initform nil
+ :documentation
+ "The local variables.")
+ (typescope :initform nil
+ :documentation
+ "Slot to save intermediate scope while metatypes are
dereferenced.")
+ )
+ "Cache used for storage of the current scope by the Semantic Analyzer.
+Saves scoping information between runs of the analyzer.")
+
+;;; METHODS
+;;
+;; Methods for basic management of the structure in semanticdb.
+;;
+(defmethod semantic-reset ((obj semantic-scope-cache))
+ "Reset OBJ back to it's empty settings."
+ (oset obj tag nil)
+ (oset obj scopetypes nil)
+ (oset obj parents nil)
+ (oset obj parentinheritance nil)
+ (oset obj scope nil)
+ (oset obj fullscope nil)
+ (oset obj localargs nil)
+ (oset obj localvar nil)
+ (oset obj typescope nil)
+ )
+
+(defmethod semanticdb-synchronize ((cache semantic-scope-cache)
+ new-tags)
+ "Synchronize a CACHE with some NEW-TAGS."
+ (semantic-reset cache))
+
+
+(defmethod semanticdb-partial-synchronize ((cache semantic-scope-cache)
+ new-tags)
+ "Synchronize a CACHE with some changed NEW-TAGS."
+ ;; If there are any includes or datatypes changed, then clear.
+ (if (or (semantic-find-tags-by-class 'include new-tags)
+ (semantic-find-tags-by-class 'type new-tags)
+ (semantic-find-tags-by-class 'using new-tags))
+ (semantic-reset cache))
+ )
+
+(defun semantic-scope-reset-cache ()
+ "Get the current cached scope, and reset it."
+ (when semanticdb-current-table
+ (let ((co (semanticdb-cache-get semanticdb-current-table
+ semantic-scope-cache)))
+ (semantic-reset co))))
+
+(defmethod semantic-scope-set-typecache ((cache semantic-scope-cache)
+ types-in-scope)
+ "Set the :typescope property on CACHE to some types.
+TYPES-IN-SCOPE is a list of type tags whos members are
+currently in scope. For each type in TYPES-IN-SCOPE,
+add those members to the types list.
+If nil, then the typescope is reset."
+ (let ((newts nil)) ;; New Type Scope
+ (dolist (onetype types-in-scope)
+ (setq newts (append (semantic-tag-type-members onetype)
+ newts))
+ )
+ (oset cache typescope newts)))
+
+;;; TAG SCOPES
+;;
+;; These fcns should be used by search routines that return a single
+;; tag which, in turn, may have come from a deep scope. The scope
+;; will be attached to the tag. Thus, in future scope based calls, a
+;; tag can be passed in and a scope derived from it.
+
+(defun semantic-scope-tag-clone-with-scope (tag scopetags)
+ "Close TAG, and return it. Add SCOPETAGS as a tag-local scope.
+Stores the SCOPETAGS as a set of tag properties on the cloned tag."
+ (let ((clone (semantic-tag-clone tag))
+ )
+ (semantic--tag-put-property clone 'scope scopetags)
+ ))
+
+(defun semantic-scope-tag-get-scope (tag)
+ "Get from TAG the list of tags comprising the scope from TAG."
+ (semantic--tag-get-property tag 'scope))
+
+;;; SCOPE UTILITIES
+;;
+;; Functions that do the main scope calculations
+
+
+(define-overloadable-function semantic-analyze-scoped-types (position)
+ "Return a list of types currently in scope at POSITION.
+This is based on what tags exist at POSITION, and any associated
+types available.")
+
+(defun semantic-analyze-scoped-types-default (position)
+ "Return a list of types currently in scope at POSITION.
+Use `semantic-ctxt-scoped-types' to find types."
+ (require 'semantic/db-typecache)
+ (save-excursion
+ (goto-char position)
+ (let ((code-scoped-types nil))
+ ;; Lets ask if any types are currently scoped. Scoped
+ ;; classes and types provide their public methods and types
+ ;; in source code, but are unrelated hierarchically.
+ (let ((sp (semantic-ctxt-scoped-types)))
+ (while sp
+ ;; Get this thing as a tag
+ (let ((tmp (cond
+ ((stringp (car sp))
+ (semanticdb-typecache-find (car sp)))
+ ;(semantic-analyze-find-tag (car sp) 'type))
+ ((semantic-tag-p (car sp))
+ (if (semantic-analyze-tag-prototype-p (car sp))
+ (semanticdb-typecache-find (semantic-tag-name (car
sp)))
+ ;;(semantic-analyze-find-tag (semantic-tag-name (car
sp)) 'type)
+ (car sp)))
+ (t nil))))
+ (when tmp
+ (setq code-scoped-types
+ (cons tmp code-scoped-types))))
+ (setq sp (cdr sp))))
+ (setq code-scoped-types (nreverse code-scoped-types))
+
+ (when code-scoped-types
+ (semanticdb-typecache-merge-streams code-scoped-types nil))
+
+ )))
+
+;;------------------------------------------------------------
+(define-overloadable-function semantic-analyze-scope-nested-tags (position
scopedtypes)
+ "Return a list of types in order of nesting for the context of POSITION.
+If POSITION is in a method with a named parent, find that parent, and
+identify it's scope via overlay instead.
+Optional SCOPETYPES are additional scoped entities in which our parent might
+be found.")
+
+(defun semantic-analyze-scope-nested-tags-default (position scopetypes)
+ "Return a list of types in order of nesting for the context of POSITION.
+If POSITION is in a method with a named parent, find that parent, and
+identify it's scope via overlay instead.
+Optional SCOPETYPES are additional scoped entities in which our parent might
+be found.
+This only finds ONE immediate parent by name. All other parents returned
+are from nesting data types."
+ (require 'semantic/analyze)
+ (save-excursion
+ (if position (goto-char position))
+ (let* ((stack (reverse (semantic-find-tag-by-overlay (point))))
+ (tag (car stack))
+ (pparent (car (cdr stack)))
+ (returnlist nil)
+ )
+ ;; In case of arg lists or some-such, throw out non-types.
+ (while (and stack (not (semantic-tag-of-class-p pparent 'type)))
+ (setq stack (cdr stack)
+ pparent (car (cdr stack))))
+
+ ;; Step 1:
+ ;; Analyze the stack of tags we are nested in as parents.
+ ;;
+
+ ;; If we have a pparent tag, lets go there
+ ;; an analyze that stack of tags.
+ (when (and pparent (semantic-tag-with-position-p pparent))
+ (semantic-go-to-tag pparent)
+ (setq stack (semantic-find-tag-by-overlay (point)))
+ ;; Step one, find the merged version of stack in the typecache.
+ (let* ((stacknames (reverse (mapcar 'semantic-tag-name stack)))
+ (tc nil)
+ )
+ ;; @todo - can we use the typecache ability to
+ ;; put a scope into a tag to do this?
+ (while (and stacknames
+ (setq tc (semanticdb-typecache-find
+ (reverse stacknames))))
+ (setq returnlist (cons tc returnlist)
+ stacknames (cdr stacknames)))
+ (when (not returnlist)
+ ;; When there was nothing from the typecache, then just
+ ;; use what's right here.
+ (setq stack (reverse stack))
+ ;; Add things to STACK until we cease finding tags of class type.
+ (while (and stack (eq (semantic-tag-class (car stack)) 'type))
+ ;; Otherwise, just add this to the returnlist.
+ (setq returnlist (cons (car stack) returnlist))
+ (setq stack (cdr stack)))
+
+ (setq returnlist (nreverse returnlist))
+ ))
+ )
+
+ ;; Only do this level of analysis for functions.
+ (when (eq (semantic-tag-class tag) 'function)
+ ;; Step 2:
+ ;; If the function tag itself has a "parent" by name, then that
+ ;; parent will exist in the scope we just calculated, so look it
+ ;; up now.
+ ;;
+ (let ((p (semantic-tag-function-parent tag)))
+ (when p
+ ;; We have a parent, search for it.
+ (let* ((searchnameraw (cond ((stringp p) p)
+ ((semantic-tag-p p)
+ (semantic-tag-name p))
+ ((and (listp p) (stringp (car p)))
+ (car p))))
+ (searchname (semantic-analyze-split-name searchnameraw))
+ (snlist (if (consp searchname)
+ searchname
+ (list searchname)))
+ (fullsearchname nil)
+
+ (miniscope (semantic-scope-cache "mini"))
+ ptag)
+
+ ;; Find the next entry in the refereneced type for
+ ;; our function, and append to return list till our
+ ;; returnlist is empty.
+ (while snlist
+ (setq fullsearchname
+ (append (mapcar 'semantic-tag-name returnlist)
+ (list (car snlist)))) ;; Next one
+ (setq ptag
+ (semanticdb-typecache-find fullsearchname))
+
+ (when (or (not ptag)
+ (not (semantic-tag-of-class-p ptag 'type)))
+ (let ((rawscope
+ (apply 'append
+ (mapcar 'semantic-tag-type-members
+ (cons (car returnlist) scopetypes)
+ )))
+ )
+ (oset miniscope parents returnlist) ;; Not really accurate,
but close
+ (oset miniscope scope rawscope)
+ (oset miniscope fullscope rawscope)
+ (setq ptag
+ (semantic-analyze-find-tag searchnameraw
+ 'type
+ miniscope
+ ))
+ ))
+
+ (when ptag
+ (when (and (not (semantic-tag-p ptag))
+ (semantic-tag-p (car ptag)))
+ (setq ptag (car ptag)))
+ (setq returnlist (append returnlist (list ptag)))
+ )
+
+ (setq snlist (cdr snlist)))
+ (setq returnlist returnlist)
+ )))
+ )
+ returnlist
+ )))
+
+(define-overloadable-function semantic-analyze-scope-lineage-tags (parents
scopedtypes)
+ "Return the full lineage of tags from PARENTS.
+The return list is of the form ( TAG . PROTECTION ), where TAG is a tag,
+and PROTECTION is the level of protection offered by the relationship.
+Optional SCOPETYPES are additional scoped entities in which our parent might
+be found.")
+
+(defun semantic-analyze-scope-lineage-tags-default (parents scopetypes)
+ "Return the full lineage of tags from PARENTS.
+The return list is of the form ( TAG . PROTECTION ), where TAG is a tag,
+and PROTECTION is the level of protection offered by the relationship.
+Optional SCOPETYPES are additional scoped entities in which our parent might
+be found."
+ (let ((lineage nil)
+ (miniscope (semantic-scope-cache "mini"))
+ )
+ (oset miniscope parents parents)
+ (oset miniscope scope scopetypes)
+ (oset miniscope fullscope scopetypes)
+
+ (dolist (slp parents)
+ (semantic-analyze-scoped-inherited-tag-map
+ slp (lambda (newparent)
+ (let* ((pname (semantic-tag-name newparent))
+ (prot (semantic-tag-type-superclass-protection slp pname))
+ (effectiveprot (cond ((eq prot 'public)
+ ;; doesn't provide access to private
slots?
+ 'protected)
+ (t prot))))
+ (push (cons newparent effectiveprot) lineage)
+ ))
+ miniscope))
+
+ lineage))
+
+
+;;------------------------------------------------------------
+
+(define-overloadable-function semantic-analyze-scoped-tags (typelist
parentlist)
+ "Return accessable tags when TYPELIST and PARENTLIST is in scope.
+Tags returned are not in the global name space, but are instead
+scoped inside a class or namespace. Such items can be referenced
+without use of \"object.function()\" style syntax due to an
+implicit \"object\".")
+
+(defun semantic-analyze-scoped-tags-default (typelist halfscope)
+ "Return accessable tags when TYPELIST and HALFSCOPE is in scope.
+HALFSCOPE is the current scope partially initialized.
+Tags returned are not in the global name space, but are instead
+scoped inside a class or namespace. Such items can be referenced
+without use of \"object.function()\" style syntax due to an
+implicit \"object\"."
+ (let ((typelist2 nil)
+ (currentscope nil)
+ (parentlist (oref halfscope parents))
+ (miniscope halfscope)
+ )
+ ;; Loop over typelist, and find and merge all namespaces matching
+ ;; the names in typelist.
+ (while typelist
+ (let ((tt (semantic-tag-type (car typelist))))
+ (when (and (stringp tt) (string= tt "namespace"))
+ ;; By using the typecache, our namespaces are pre-merged.
+ (setq typelist2 (cons (car typelist) typelist2))
+ ))
+ (setq typelist (cdr typelist)))
+
+ ;; Loop over the types (which should be sorted by postion
+ ;; adding to the scopelist as we go, and using the scopelist
+ ;; for additional searching!
+ (while typelist2
+ (oset miniscope scope currentscope)
+ (oset miniscope fullscope currentscope)
+ (setq currentscope (append
+ (semantic-analyze-scoped-type-parts (car typelist2)
+ miniscope)
+ currentscope))
+ (setq typelist2 (cdr typelist2)))
+
+ ;; Collect all the types (class, etc) that are in our heratage.
+ ;; These are types that we can extract members from, not those
+ ;; delclared in using statements, or the like.
+ ;; Get the PARENTS including nesting scope for this location.
+ (while parentlist
+ (oset miniscope scope currentscope)
+ (oset miniscope fullscope currentscope)
+ (setq currentscope (append
+ (semantic-analyze-scoped-type-parts (car parentlist)
+ miniscope)
+ currentscope))
+ (setq parentlist (cdr parentlist)))
+
+ ;; Loop over all the items, and collect any type constants.
+ (let ((constants nil))
+ (dolist (T currentscope)
+ (setq constants (append constants
+ (semantic-analyze-type-constants T)))
+ )
+
+ (setq currentscope (append currentscope constants)))
+
+ currentscope))
+
+;;------------------------------------------------------------
+(define-overloadable-function semantic-analyze-scope-calculate-access (type
scope)
+ "Calculate the access class for TYPE as defined by the current SCOPE.
+Access is related to the :parents in SCOPE. If type is a member of SCOPE
+then access would be 'private. If TYPE is inherited by a member of SCOPE,
+the access would be 'protected. Otherwise, access is 'public")
+
+(defun semantic-analyze-scope-calculate-access-default (type scope)
+ "Calculate the access class for TYPE as defined by the current SCOPE."
+ (cond ((semantic-scope-cache-p scope)
+ (let ((parents (oref scope parents))
+ (parentsi (oref scope parentinheritance))
+ )
+ (catch 'moose
+ ;; Investigate the parent, and see how it relates to type.
+ ;; If these tags are basically the same, then we have full access.
+ (dolist (p parents)
+ (when (semantic-tag-similar-p type p)
+ (throw 'moose 'private))
+ )
+ ;; Look to see if type is in our list of inherited parents.
+ (dolist (pi parentsi)
+ ;; pi is a cons cell ( PARENT . protection)
+ (let ((pip (car pi))
+ (piprot (cdr pi)))
+ (when (semantic-tag-similar-p type pip)
+ (throw 'moose
+ ;; protection via inheritance means to pull out
different
+ ;; bits based on protection labels in an opposite way.
+ (cdr (assoc piprot
+ '((public . private)
+ (protected . protected)
+ (private . public))))
+ )))
+ )
+ ;; Not in our parentage. Is type a FRIEND?
+ (let ((friends (semantic-find-tags-by-class 'friend
(semantic-tag-type-members type))))
+ (dolist (F friends)
+ (dolist (pi parents)
+ (if (string= (semantic-tag-name F) (semantic-tag-name pi))
+ (throw 'moose 'private))
+ )))
+ ;; Found nothing, return public
+ 'public)
+ ))
+ (t 'public)))
+
+(defun semantic-completable-tags-from-type (type)
+ "Return a list of slots that are valid completions from the list of SLOTS.
+If a tag in SLOTS has a named parent, then that implies that the
+tag is not something you can complete from within TYPE."
+ (let ((allslots (semantic-tag-components type))
+ (leftover nil)
+ )
+ (dolist (S allslots)
+ (when (or (not (semantic-tag-of-class-p S 'function))
+ (not (semantic-tag-function-parent S)))
+ (setq leftover (cons S leftover)))
+ )
+ (nreverse leftover)))
+
+(defun semantic-analyze-scoped-type-parts (type &optional scope noinherit
protection)
+ "Return all parts of TYPE, a tag representing a TYPE declaration.
+SCOPE is the scope object.
+NOINHERIT turns off searching of inherited tags.
+PROTECTION specifies the type of access requested, such as 'public or
'private."
+ (if (not type)
+ nil
+ (let* ((access (semantic-analyze-scope-calculate-access type scope))
+ ;; SLOTS are the slots directly a part of TYPE.
+ (allslots (semantic-completable-tags-from-type type))
+ (slots (semantic-find-tags-by-scope-protection
+ access
+ type allslots))
+ (fname (semantic-tag-file-name type))
+ ;; EXTMETH are externally defined methods that are still
+ ;; a part of this class.
+
+ ;; @TODO - is this line needed?? Try w/out for a while
+ ;; @note - I think C++ says no. elisp might, but methods
+ ;; look like defuns, so it makes no difference.
+ (extmeth nil) ; (semantic-tag-external-member-children type t))
+
+ ;; INHERITED are tags found in classes that our TYPE tag
+ ;; inherits from. Do not do this if it was not requested.
+ (inherited (when (not noinherit)
+ (semantic-analyze-scoped-inherited-tags type scope
+ access)))
+ )
+ (when (not (semantic-tag-in-buffer-p type))
+ (let ((copyslots nil))
+ (dolist (TAG slots)
+ ;;(semantic--tag-put-property TAG :filename fname)
+ (if (semantic-tag-file-name TAG)
+ ;; If it has a filename, just go with it...
+ (setq copyslots (cons TAG copyslots))
+ ;; Otherwise, copy the tag w/ the guessed filename.
+ (setq copyslots (cons (semantic-tag-copy TAG nil fname)
+ copyslots)))
+ )
+ (setq slots (nreverse copyslots))
+ ))
+ ;; Flatten the database output.
+ (append slots extmeth inherited)
+ )))
+
+(defun semantic-analyze-scoped-inherited-tags (type scope access)
+ "Return all tags that TYPE inherits from.
+Argument SCOPE specify additional tags that are in scope
+whose tags can be searched when needed, OR it may be a scope object.
+ACCESS is the level of access we filter on child supplied tags.
+For langauges with protection on specific methods or slots,
+it should strip out those not accessable by methods of TYPE.
+An ACCESS of 'public means not in a method of a subclass of type.
+A value of 'private means we can access private parts of the originating
+type."
+ (let ((ret nil))
+ (semantic-analyze-scoped-inherited-tag-map
+ type (lambda (p)
+ (let* ((pname (semantic-tag-name p))
+ (protection (semantic-tag-type-superclass-protection
+ type pname))
+ )
+ (if (and (eq access 'public) (not (eq protection 'public)))
+ nil ;; Don't do it.
+
+ ;; We can get some parts of this type.
+ (setq ret (nconc ret
+ ;; Do not pull in inherited parts here. Those
+ ;; will come via the inherited-tag-map fcn
+ (semantic-analyze-scoped-type-parts
+ p scope t protection))
+ ))))
+ scope)
+ ret))
+
+(defun semantic-analyze-scoped-inherited-tag-map (type fcn scope)
+ "Map all parents of TYPE to FCN. Return tags of all the types.
+Argument SCOPE specify additional tags that are in scope
+whose tags can be searched when needed, OR it may be a scope object."
+ (require 'semantic/analyze)
+ (let* (;; PARENTS specifies only the superclasses and not
+ ;; interfaces. Inheriting from an interfaces implies
+ ;; you have a copy of all methods locally. I think.
+ (parents (semantic-tag-type-superclasses type))
+ ps pt
+ (tmpscope scope)
+ )
+ (save-excursion
+
+ ;; Create a SCOPE just for looking up the parent based on where
+ ;; the parent came from.
+ ;;
+ ;; @TODO - Should we cache these mini-scopes around in Emacs
+ ;; for recycling later? Should this become a helpful
+ ;; extra routine?
+ (when (and parents (semantic-tag-with-position-p type))
+ ;; If TYPE has a position, go there and get the scope.
+ (semantic-go-to-tag type)
+
+ ;; We need to make a mini scope, and only include the misc bits
+ ;; that will help in finding the parent. We don't really need
+ ;; to do any of the stuff related to variables and what-not.
+ (setq tmpscope (semantic-scope-cache "mini"))
+ (let* (;; Step 1:
+ (scopetypes (semantic-analyze-scoped-types (point)))
+ (parents (semantic-analyze-scope-nested-tags (point) scopetypes))
+ ;;(parentinherited (semantic-analyze-scope-lineage-tags parents
scopetypes))
+ (lscope nil)
+ )
+ (oset tmpscope scopetypes scopetypes)
+ (oset tmpscope parents parents)
+ ;;(oset tmpscope parentinheritance parentinherited)
+
+ (when (or scopetypes parents)
+ (setq lscope (semantic-analyze-scoped-tags scopetypes tmpscope))
+ (oset tmpscope scope lscope))
+ (oset tmpscope fullscope (append scopetypes lscope parents))
+ ))
+ ;; END creating tmpscope
+
+ ;; Look up each parent one at a time.
+ (dolist (p parents)
+ (setq ps (cond ((stringp p) p)
+ ((and (semantic-tag-p p) (semantic-tag-prototype-p p))
+ (semantic-tag-name p))
+ ((and (listp p) (stringp (car p)))
+ p))
+ pt (condition-case nil
+ (or (semantic-analyze-find-tag ps 'type tmpscope)
+ ;; A backup hack.
+ (semantic-analyze-find-tag ps 'type scope))
+ (error nil)))
+
+ (when pt
+ (funcall fcn pt)
+ ;; Note that we pass the original SCOPE in while recursing.
+ ;; so that the correct inheritance model is passed along.
+ (semantic-analyze-scoped-inherited-tag-map pt fcn scope)
+ )))
+ nil))
+
+;;; ANALYZER
+;;
+;; Create the scope structure for use in the Analyzer.
+;;
+;;;###autoload
+(defun semantic-calculate-scope (&optional point)
+ "Calculate the scope at POINT.
+If POINT is not provided, then use the current location of point.
+The class returned from the scope calculation is variable
+`semantic-scope-cache'."
+ (interactive)
+ (if (not (and (featurep 'semantic/db) semanticdb-current-database))
+ nil ;; Don't do anything...
+ (require 'semantic/db-typecache)
+ (if (not point) (setq point (point)))
+ (when (interactive-p)
+ (semantic-fetch-tags)
+ (semantic-scope-reset-cache)
+ )
+ (save-excursion
+ (goto-char point)
+ (let* ((TAG (semantic-current-tag))
+ (scopecache
+ (semanticdb-cache-get semanticdb-current-table
+ semantic-scope-cache))
+ )
+ (when (not (semantic-equivalent-tag-p TAG (oref scopecache tag)))
+ (semantic-reset scopecache))
+ (if (oref scopecache tag)
+ ;; Even though we can recycle most of the scope, we
+ ;; need to redo the local variables since those change
+ ;; as you move about the tag.
+ (condition-case nil
+ (oset scopecache localvar (semantic-get-all-local-variables))
+ (error nil))
+
+ (let* (;; Step 1:
+ (scopetypes (semantic-analyze-scoped-types point))
+ (parents (semantic-analyze-scope-nested-tags point scopetypes))
+ (parentinherited (semantic-analyze-scope-lineage-tags
+ parents scopetypes))
+ )
+ (oset scopecache tag TAG)
+ (oset scopecache scopetypes scopetypes)
+ (oset scopecache parents parents)
+ (oset scopecache parentinheritance parentinherited)
+
+ (let* (;; Step 2:
+ (scope (when (or scopetypes parents)
+ (semantic-analyze-scoped-tags scopetypes
scopecache))
+ )
+ ;; Step 3:
+ (localargs (semantic-get-local-arguments))
+ (localvar (condition-case nil
+ (semantic-get-all-local-variables)
+ (error nil)))
+ )
+
+ ;; Try looking for parents again.
+ (when (not parentinherited)
+ (setq parentinherited (semantic-analyze-scope-lineage-tags
+ parents (append scopetypes scope)))
+ (when parentinherited
+ (oset scopecache parentinheritance parentinherited)
+ ;; Try calculating the scope again with the new inherited
parent list.
+ (setq scope (when (or scopetypes parents)
+ (semantic-analyze-scoped-tags scopetypes
scopecache))
+ )))
+
+ ;; Fill out the scope.
+ (oset scopecache scope scope)
+ (oset scopecache fullscope (append scopetypes scope parents))
+ (oset scopecache localargs localargs)
+ (oset scopecache localvar localvar)
+ )))
+ ;; Make sure we become dependant on the typecache.
+ (semanticdb-typecache-add-dependant scopecache)
+ ;; Handy debug output.
+ (when (interactive-p)
+ (require 'eieio-datadebug)
+ (data-debug-show scopecache)
+ )
+ ;; Return ourselves
+ scopecache))))
+
+(defun semantic-scope-find (name &optional class scope-in)
+ "Find the tag with NAME, and optinal CLASS in the current SCOPE-IN.
+Searches various elements of the scope for NAME. Return ALL the
+hits in order, with the first tag being in the closest scope."
+ (let ((scope (or scope-in (semantic-calculate-scope)))
+ (ans nil))
+ ;; Is the passed in scope really a scope? if so, look through
+ ;; the options in that scope.
+ (if (semantic-scope-cache-p scope)
+ (let* ((la
+ ;; This should be first, but bugs in the
+ ;; C parser will turn function calls into
+ ;; assumed int return function prototypes. Yuck!
+ (semantic-find-tags-by-name name (oref scope localargs)))
+ (lv
+ (semantic-find-tags-by-name name (oref scope localvar)))
+ (fullscoperaw (oref scope fullscope))
+ (sc (semantic-find-tags-by-name name fullscoperaw))
+ (typescoperaw (oref scope typescope))
+ (tsc (semantic-find-tags-by-name name typescoperaw))
+ )
+ (setq ans
+ (if class
+ ;; Scan out things not of the right class.
+ (semantic-find-tags-by-class class (append la lv sc tsc))
+ (append la lv sc tsc))
+ )
+
+ (when (and (not ans) (or typescoperaw fullscoperaw))
+ (let ((namesplit (semantic-analyze-split-name name)))
+ (when (consp namesplit)
+ ;; It may be we need to hack our way through type typescope.
+ (while namesplit
+ (setq ans (append
+ (semantic-find-tags-by-name (car namesplit)
+ typescoperaw)
+ (semantic-find-tags-by-name (car namesplit)
+ fullscoperaw)
+ ))
+ (if (not ans)
+ (setq typescoperaw nil)
+ (when (cdr namesplit)
+ (setq typescoperaw (semantic-tag-type-members
+ (car ans)))))
+
+ (setq namesplit (cdr namesplit)))
+ ;; Once done, store the current typecache lookup
+ (oset scope typescope
+ (append typescoperaw (oref scope typescope)))
+ )))
+ ;; Return it.
+ ans)
+ ;; Not a real scope. Our scope calculation analyze parts of
+ ;; what it finds, and needs to pass lists through to do it's work.
+ ;; Tread that list as a singly entry.
+ (if class
+ (semantic-find-tags-by-class class scope)
+ scope)
+ )))
+
+;;; DUMP
+;;
+(defmethod semantic-analyze-show ((context semantic-scope-cache))
+ "Insert CONTEXT into the current buffer in a nice way."
+ (require 'semantic/analyze)
+ (semantic-analyze-princ-sequence (oref context scopetypes) "-> ScopeTypes: "
)
+ (semantic-analyze-princ-sequence (oref context parents) "-> Parents: " )
+ (semantic-analyze-princ-sequence (oref context scope) "-> Scope: " )
+ ;;(semantic-analyze-princ-sequence (oref context fullscope) "Fullscope: " )
+ (semantic-analyze-princ-sequence (oref context localargs) "-> Local Args: " )
+ (semantic-analyze-princ-sequence (oref context localvar) "-> Local Vars: " )
+ )
+
+(provide 'semantic/scope)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/scope"
+;; End:
+
+;;; semantic/scope.el ends here
Index: cedet/semantic/senator.el
===================================================================
RCS file: cedet/semantic/senator.el
diff -N cedet/semantic/senator.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/senator.el 28 Sep 2009 15:15:09 -0000 1.2
@@ -0,0 +1,888 @@
+;;; semantic/senator.el --- SEmantic NAvigaTOR
+
+;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+;; 2009 Free Software Foundation, Inc.
+
+;; Author: David Ponce <address@hidden>
+;; Maintainer: FSF
+;; Created: 10 Nov 2000
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; This file defines some user commands for navigating between
+;; Semantic tags. This is a subset of the version of senator.el in
+;; the upstream CEDET package; the rest is incorporated into other
+;; parts of Semantic or Emacs.
+
+;;; Code:
+
+(require 'ring)
+(require 'semantic)
+(require 'semantic/ctxt)
+(require 'semantic/decorate)
+(require 'semantic/format)
+
+(eval-when-compile (require 'semantic/find))
+
+;; (eval-when-compile (require 'hippie-exp))
+
+(declare-function semanticdb-fast-strip-find-results "semantic/db-find")
+(declare-function semanticdb-deep-find-tags-for-completion "semantic/db-find")
+(declare-function semantic-analyze-tag-references "semantic/analyze/refs")
+(declare-function semantic-analyze-refs-impl "semantic/analyze/refs")
+(declare-function semantic-analyze-find-tag "semantic/analyze")
+(declare-function semantic-analyze-tag-type "semantic/analyze/fcn")
+(declare-function semantic-tag-external-class "semantic/sort")
+(declare-function imenu--mouse-menu "imenu")
+
+;;; Customization
+(defgroup senator nil
+ "Semantic Navigator."
+ :group 'semantic)
+
+;;;###autoload
+(defcustom senator-step-at-tag-classes nil
+ "List of tag classes recognized by Senator's navigation commands.
+A tag class is a symbol, such as `variable', `function', or `type'.
+
+As a special exception, if the value is nil, Senator's navigation
+commands recognize all tag classes."
+ :group 'senator
+ :type '(repeat (symbol)))
+;;;###autoload
+(make-variable-buffer-local 'senator-step-at-tag-classes)
+
+;;;###autoload
+(defcustom senator-step-at-start-end-tag-classes nil
+ "List of tag classes at which Senator's navigation commands should stop.
+A tag class is a symbol, such as `variable', `function', or `type'.
+The navigation commands stop at the start and end of each tag
+class in this list, provided the tag class is recognized (see
+`senator-step-at-tag-classes').
+
+As a special exception, if the value is nil, the navigation
+commands stop at the beginning of every tag.
+
+If t, the navigation commands stop at the start and end of any
+tag, where possible."
+ :group 'senator
+ :type '(choice :tag "Identifiers"
+ (repeat :menu-tag "Symbols" (symbol))
+ (const :tag "All" t)))
+;;;###autoload
+(make-variable-buffer-local 'senator-step-at-start-end-tag-classes)
+
+(defcustom senator-highlight-found nil
+ "If non-nil, Senator commands momentarily highlight found tags."
+ :group 'senator
+ :type 'boolean)
+(make-variable-buffer-local 'senator-highlight-found)
+
+;;; Faces
+(defface senator-momentary-highlight-face
+ '((((class color) (background dark))
+ (:background "gray30"))
+ (((class color) (background light))
+ (:background "gray70")))
+ "Face used to momentarily highlight tags."
+ :group 'semantic-faces)
+
+;;; Common functions
+
+(defun senator-momentary-highlight-tag (tag)
+ "Momentarily highlight TAG.
+Does nothing if `senator-highlight-found' is nil."
+ (and senator-highlight-found
+ (semantic-momentary-highlight-tag
+ tag 'senator-momentary-highlight-face)))
+
+(defun senator-step-at-start-end-p (tag)
+ "Return non-nil if must step at start and end of TAG."
+ (and tag
+ (or (eq senator-step-at-start-end-tag-classes t)
+ (memq (semantic-tag-class tag)
+ senator-step-at-start-end-tag-classes))))
+
+(defun senator-skip-p (tag)
+ "Return non-nil if must skip TAG."
+ (and tag
+ senator-step-at-tag-classes
+ (not (memq (semantic-tag-class tag)
+ senator-step-at-tag-classes))))
+
+(defun senator-middle-of-tag-p (pos tag)
+ "Return non-nil if POS is between start and end of TAG."
+ (and (> pos (semantic-tag-start tag))
+ (< pos (semantic-tag-end tag))))
+
+(defun senator-step-at-parent (tag)
+ "Return TAG's outermost parent if must step at start/end of it.
+Return nil otherwise."
+ (if tag
+ (let (parent parents)
+ (setq parents (semantic-find-tag-by-overlay
+ (semantic-tag-start tag)))
+ (while (and parents (not parent))
+ (setq parent (car parents)
+ parents (cdr parents))
+ (if (or (eq tag parent)
+ (senator-skip-p parent)
+ (not (senator-step-at-start-end-p parent)))
+ (setq parent nil)))
+ parent)))
+
+(defun senator-previous-tag-or-parent (pos)
+ "Return the tag before POS or one of its parent where to step."
+ (let (ol tag)
+ (while (and pos (> pos (point-min)) (not tag))
+ (setq pos (semantic-overlay-previous-change pos))
+ (when pos
+ ;; Get overlays at position
+ (setq ol (semantic-overlays-at pos))
+ ;; find the overlay that belongs to semantic
+ ;; and STARTS or ENDS at the found position.
+ (while (and ol (not tag))
+ (setq tag (semantic-overlay-get (car ol) 'semantic))
+ (unless (and tag (semantic-tag-p tag)
+ (or (= (semantic-tag-start tag) pos)
+ (= (semantic-tag-end tag) pos)))
+ (setq tag nil
+ ol (cdr ol))))))
+ (or (senator-step-at-parent tag) tag)))
+
+;;; Search functions
+
+(defun senator-search-tag-name (tag)
+ "Search for TAG name in current buffer.
+Limit the search to TAG bounds.
+If found, set point to the end of the name, and return point. The
+beginning of the name is at (match-beginning 0).
+Return nil if not found, that is if TAG name doesn't come from the
+source."
+ (let ((name (semantic-tag-name tag)))
+ (setq name (if (string-match "\\`\\([^[]+\\)[[]" name)
+ (match-string 1 name)
+ name))
+ (goto-char (semantic-tag-start tag))
+ (when (re-search-forward (concat
+ ;; The tag name is expected to be
+ ;; between word delimiters, whitespaces,
+ ;; or punctuations.
+ "\\(\\<\\|\\s-+\\|\\s.\\)"
+ (regexp-quote name)
+ "\\(\\>\\|\\s-+\\|\\s.\\)")
+ (semantic-tag-end tag)
+ t)
+ (goto-char (match-beginning 0))
+ (search-forward name))))
+
+(defcustom senator-search-ignore-tag-classes
+ '(code block)
+ "List of ignored tag classes.
+Tags of those classes are excluded from search."
+ :group 'senator
+ :type '(repeat (symbol :tag "class")))
+
+(defun senator-search-default-tag-filter (tag)
+ "Default function that filters searched tags.
+Ignore tags of classes in `senator-search-ignore-tag-classes'"
+ (not (memq (semantic-tag-class tag)
+ senator-search-ignore-tag-classes)))
+
+(defvar senator-search-tag-filter-functions
+ '(senator-search-default-tag-filter)
+ "List of functions to be called to filter searched tags.
+Each function is passed a tag. If one of them returns nil, the tag is
+excluded from the search.")
+
+(defun senator-search (searcher text &optional bound noerror count)
+ "Use the SEARCHER function to search from point for TEXT in a tag name.
+SEARCHER is typically the function `search-forward', `search-backward',
+`word-search-forward', `word-search-backward', `re-search-forward', or
+`re-search-backward'. See one of the above function to see how the
+TEXT, BOUND, NOERROR, and COUNT arguments are interpreted."
+ (let* ((origin (point))
+ (count (or count 1))
+ (step (cond ((> count 0) 1)
+ ((< count 0) (setq count (- count)) -1)
+ (0)))
+ found next sstart send tag tstart tend)
+ (or (zerop step)
+ (while (and (not found)
+ (setq next (funcall searcher text bound t step)))
+ (setq sstart (match-beginning 0)
+ send (match-end 0))
+ (if (= sstart send)
+ (setq found t)
+ (and (setq tag (semantic-current-tag))
+ (run-hook-with-args-until-failure
+ 'senator-search-tag-filter-functions tag)
+ (setq tend (senator-search-tag-name tag))
+ (setq tstart (match-beginning 0)
+ found (and (>= sstart tstart)
+ (<= send tend)
+ (zerop (setq count (1- count))))))
+ (goto-char next))))
+ (cond ((null found)
+ (setq next origin
+ send origin))
+ ((= next sstart)
+ (setq next send
+ send sstart))
+ (t
+ (setq next sstart)))
+ (goto-char next)
+ ;; Setup the returned value and the `match-data' or maybe fail!
+ (funcall searcher text send noerror step)))
+
+;;; Navigation commands
+
+;;;###autoload
+(defun senator-next-tag ()
+ "Navigate to the next Semantic tag.
+Return the tag or nil if at end of buffer."
+ (interactive)
+ (let ((pos (point))
+ (tag (semantic-current-tag))
+ where)
+ (if (and tag
+ (not (senator-skip-p tag))
+ (senator-step-at-start-end-p tag)
+ (or (= pos (semantic-tag-start tag))
+ (senator-middle-of-tag-p pos tag)))
+ nil
+ (if (setq tag (senator-step-at-parent tag))
+ nil
+ (setq tag (semantic-find-tag-by-overlay-next pos))
+ (while (and tag (senator-skip-p tag))
+ (setq tag (semantic-find-tag-by-overlay-next
+ (semantic-tag-start tag))))))
+ (if (not tag)
+ (progn
+ (goto-char (point-max))
+ (message "End of buffer"))
+ (cond ((and (senator-step-at-start-end-p tag)
+ (or (= pos (semantic-tag-start tag))
+ (senator-middle-of-tag-p pos tag)))
+ (setq where "end")
+ (goto-char (semantic-tag-end tag)))
+ (t
+ (setq where "start")
+ (goto-char (semantic-tag-start tag))))
+ (senator-momentary-highlight-tag tag)
+ (message "%S: %s (%s)"
+ (semantic-tag-class tag)
+ (semantic-tag-name tag)
+ where))
+ tag))
+
+;;;###autoload
+(defun senator-previous-tag ()
+ "Navigate to the previous Semantic tag.
+Return the tag or nil if at beginning of buffer."
+ (interactive)
+ (let ((pos (point))
+ (tag (semantic-current-tag))
+ where)
+ (if (and tag
+ (not (senator-skip-p tag))
+ (senator-step-at-start-end-p tag)
+ (or (= pos (semantic-tag-end tag))
+ (senator-middle-of-tag-p pos tag)))
+ nil
+ (if (setq tag (senator-step-at-parent tag))
+ nil
+ (setq tag (senator-previous-tag-or-parent pos))
+ (while (and tag (senator-skip-p tag))
+ (setq tag (senator-previous-tag-or-parent
+ (semantic-tag-start tag))))))
+ (if (not tag)
+ (progn
+ (goto-char (point-min))
+ (message "Beginning of buffer"))
+ (cond ((or (not (senator-step-at-start-end-p tag))
+ (= pos (semantic-tag-end tag))
+ (senator-middle-of-tag-p pos tag))
+ (setq where "start")
+ (goto-char (semantic-tag-start tag)))
+ (t
+ (setq where "end")
+ (goto-char (semantic-tag-end tag))))
+ (senator-momentary-highlight-tag tag)
+ (message "%S: %s (%s)"
+ (semantic-tag-class tag)
+ (semantic-tag-name tag)
+ where))
+ tag))
+
+;;; Search commands
+
+(defun senator-search-forward (string &optional bound noerror count)
+ "Search in tag names forward from point for STRING.
+Set point to the end of the occurrence found, and return point.
+See also the function `search-forward' for details on the BOUND,
+NOERROR and COUNT arguments."
+ (interactive "sSemantic search: ")
+ (senator-search 'search-forward string bound noerror count))
+
+(defun senator-re-search-forward (regexp &optional bound noerror count)
+ "Search in tag names forward from point for regular expression REGEXP.
+Set point to the end of the occurrence found, and return point.
+See also the function `re-search-forward' for details on the BOUND,
+NOERROR and COUNT arguments."
+ (interactive "sSemantic regexp search: ")
+ (senator-search 're-search-forward regexp bound noerror count))
+
+(defun senator-word-search-forward (word &optional bound noerror count)
+ "Search in tag names forward from point for WORD.
+Set point to the end of the occurrence found, and return point.
+See also the function `word-search-forward' for details on the BOUND,
+NOERROR and COUNT arguments."
+ (interactive "sSemantic word search: ")
+ (senator-search 'word-search-forward word bound noerror count))
+
+(defun senator-search-backward (string &optional bound noerror count)
+ "Search in tag names backward from point for STRING.
+Set point to the beginning of the occurrence found, and return point.
+See also the function `search-backward' for details on the BOUND,
+NOERROR and COUNT arguments."
+ (interactive "sSemantic backward search: ")
+ (senator-search 'search-backward string bound noerror count))
+
+(defun senator-re-search-backward (regexp &optional bound noerror count)
+ "Search in tag names backward from point for regular expression REGEXP.
+Set point to the beginning of the occurrence found, and return point.
+See also the function `re-search-backward' for details on the BOUND,
+NOERROR and COUNT arguments."
+ (interactive "sSemantic backward regexp search: ")
+ (senator-search 're-search-backward regexp bound noerror count))
+
+(defun senator-word-search-backward (word &optional bound noerror count)
+ "Search in tag names backward from point for WORD.
+Set point to the beginning of the occurrence found, and return point.
+See also the function `word-search-backward' for details on the BOUND,
+NOERROR and COUNT arguments."
+ (interactive "sSemantic backward word search: ")
+ (senator-search 'word-search-backward word bound noerror count))
+
+;;; Other useful search commands (minor mode menu)
+
+(defvar senator-last-search-type nil
+ "Type of last non-incremental search command called.")
+
+(defun senator-nonincremental-repeat-search-forward ()
+ "Search forward for the previous search string or regexp."
+ (interactive)
+ (cond
+ ((and (eq senator-last-search-type 'string)
+ search-ring)
+ (senator-search-forward (car search-ring)))
+ ((and (eq senator-last-search-type 'regexp)
+ regexp-search-ring)
+ (senator-re-search-forward (car regexp-search-ring)))
+ (t
+ (error "No previous search"))))
+
+(defun senator-nonincremental-repeat-search-backward ()
+ "Search backward for the previous search string or regexp."
+ (interactive)
+ (cond
+ ((and (eq senator-last-search-type 'string)
+ search-ring)
+ (senator-search-backward (car search-ring)))
+ ((and (eq senator-last-search-type 'regexp)
+ regexp-search-ring)
+ (senator-re-search-backward (car regexp-search-ring)))
+ (t
+ (error "No previous search"))))
+
+(defun senator-nonincremental-search-forward (string)
+ "Search for STRING nonincrementally."
+ (interactive "sSemantic search for string: ")
+ (setq senator-last-search-type 'string)
+ (if (equal string "")
+ (senator-search-forward (car search-ring))
+ (isearch-update-ring string nil)
+ (senator-search-forward string)))
+
+(defun senator-nonincremental-search-backward (string)
+ "Search backward for STRING nonincrementally."
+ (interactive "sSemantic search for string: ")
+ (setq senator-last-search-type 'string)
+ (if (equal string "")
+ (senator-search-backward (car search-ring))
+ (isearch-update-ring string nil)
+ (senator-search-backward string)))
+
+(defun senator-nonincremental-re-search-forward (string)
+ "Search for the regular expression STRING nonincrementally."
+ (interactive "sSemantic search for regexp: ")
+ (setq senator-last-search-type 'regexp)
+ (if (equal string "")
+ (senator-re-search-forward (car regexp-search-ring))
+ (isearch-update-ring string t)
+ (senator-re-search-forward string)))
+
+(defun senator-nonincremental-re-search-backward (string)
+ "Search backward for the regular expression STRING nonincrementally."
+ (interactive "sSemantic search for regexp: ")
+ (setq senator-last-search-type 'regexp)
+ (if (equal string "")
+ (senator-re-search-backward (car regexp-search-ring))
+ (isearch-update-ring string t)
+ (senator-re-search-backward string)))
+
+(defvar senator--search-filter nil)
+
+(defun senator-search-set-tag-class-filter (&optional classes)
+ "In current buffer, limit search scope to tag CLASSES.
+CLASSES is a list of tag class symbols or nil. If nil only global
+filters in `senator-search-tag-filter-functions' remain active."
+ (interactive "sClasses: ")
+ (setq classes
+ (cond
+ ((null classes)
+ nil)
+ ((symbolp classes)
+ (list classes))
+ ((stringp classes)
+ (mapcar 'read (split-string classes)))
+ (t
+ (signal 'wrong-type-argument (list classes)))
+ ))
+ ;; Clear previous filter.
+ (remove-hook 'senator-search-tag-filter-functions
+ senator--search-filter t)
+ (kill-local-variable 'senator--search-filter)
+ (if classes
+ (let ((tag (make-symbol "tag"))
+ (names (mapconcat 'symbol-name classes "', `")))
+ (set (make-local-variable 'senator--search-filter)
+ `(lambda (,tag)
+ (memq (semantic-tag-class ,tag) ',classes)))
+ (add-hook 'senator-search-tag-filter-functions
+ senator--search-filter nil t)
+ (message "Limit search to `%s' tags" names))
+ (message "Default search filter restored")))
+
+;;; Folding
+;;
+;; Use new folding state. It might be wise to extend the idea
+;; of folding for hiding all but this, or show all children, etc.
+
+(defun senator-fold-tag (&optional tag)
+ "Fold the current TAG."
+ (interactive)
+ (semantic-set-tag-folded (or tag (semantic-current-tag)) t))
+
+(defun senator-unfold-tag (&optional tag)
+ "Fold the current TAG."
+ (interactive)
+ (semantic-set-tag-folded (or tag (semantic-current-tag)) nil))
+
+(defun senator-fold-tag-toggle (&optional tag)
+ "Fold the current TAG."
+ (interactive)
+ (let ((tag (or tag (semantic-current-tag))))
+ (if (semantic-tag-folded-p tag)
+ (senator-unfold-tag tag)
+ (senator-fold-tag tag))))
+
+;; @TODO - move this to some analyzer / refs tool
+(define-overloadable-function semantic-up-reference (tag)
+ "Return a tag that is referred to by TAG.
+A \"reference\" could be any interesting feature of TAG.
+In C++, a function may have a 'parent' which is non-local.
+If that parent which is only a reference in the function tag
+is found, we can jump to it.
+Some tags such as includes have other reference features.")
+
+;;;###autoload
+(defun senator-go-to-up-reference (&optional tag)
+ "Move up one reference from the current TAG.
+A \"reference\" could be any interesting feature of TAG.
+In C++, a function may have a 'parent' which is non-local.
+If that parent which is only a reference in the function tag
+is found, we can jump to it.
+Some tags such as includes have other reference features."
+ (interactive)
+ (let ((result (semantic-up-reference (or tag (semantic-current-tag)))))
+ (if (not result)
+ (error "No up reference found")
+ (push-mark)
+ (cond
+ ;; A tag
+ ((semantic-tag-p result)
+ (semantic-go-to-tag result)
+ (switch-to-buffer (current-buffer))
+ (semantic-momentary-highlight-tag result))
+ ;; Buffers
+ ((bufferp result)
+ (switch-to-buffer result)
+ (pulse-momentary-highlight-one-line (point)))
+ ;; Files
+ ((and (stringp result) (file-exists-p result))
+ (find-file result)
+ (pulse-momentary-highlight-one-line (point)))
+ (t
+ (error "Unknown result type from `semantic-up-reference'"))))))
+
+(defun semantic-up-reference-default (tag)
+ "Return a tag that is referredto by TAG.
+Makes C/C++ language like assumptions."
+ (cond ((semantic-tag-faux-p tag)
+ ;; Faux tags should have a real tag in some other location.
+ (require 'semantic/sort)
+ (let ((options (semantic-tag-external-class tag)))
+ ;; I should do something a little better than
+ ;; this. Oy!
+ (car options)
+ ))
+
+ ;; Include always point to another file.
+ ((eq (semantic-tag-class tag) 'include)
+ (let ((file (semantic-dependency-tag-file tag)))
+ (cond
+ ((or (not file) (not (file-exists-p file)))
+ (error "Could not location include %s"
+ (semantic-tag-name tag)))
+ ((get-file-buffer file)
+ (get-file-buffer file))
+ ((stringp file)
+ file)
+ )))
+
+ ;; Is there a parent of the function to jump to?
+ ((and (semantic-tag-of-class-p tag 'function)
+ (semantic-tag-function-parent tag))
+ (let* ((scope (semantic-calculate-scope (point))))
+ ;; @todo - it would be cool to ask the user which one if
+ ;; more than one.
+ (car (oref scope parents))
+ ))
+
+ ;; Is there a non-prototype version of the tag to jump to?
+ ((semantic-tag-get-attribute tag :prototype-flag)
+ (require 'semantic/analyze/refs)
+ (let* ((sar (semantic-analyze-tag-references tag)))
+ (car (semantic-analyze-refs-impl sar t)))
+ )
+
+ ;; If this is a datatype, and we have superclasses
+ ((and (semantic-tag-of-class-p tag 'type)
+ (semantic-tag-type-superclasses tag))
+ (require 'semantic/analyze)
+ (let ((scope (semantic-calculate-scope (point)))
+ (parents (semantic-tag-type-superclasses tag)))
+ (semantic-analyze-find-tag (car parents) 'type scope)))
+
+ ;; Get the data type, and try to find that.
+ ((semantic-tag-type tag)
+ (require 'semantic/analyze)
+ (let ((scope (semantic-calculate-scope (point))))
+ (semantic-analyze-tag-type tag scope))
+ )
+ (t nil)))
+
+(defvar senator-isearch-semantic-mode nil
+ "Non-nil if isearch does semantic search.
+This is a buffer local variable.")
+(make-variable-buffer-local 'senator-isearch-semantic-mode)
+
+(defun senator-beginning-of-defun (&optional arg)
+ "Move backward to the beginning of a defun.
+Use semantic tags to navigate.
+ARG is the number of tags to navigate (not yet implemented)."
+ (semantic-fetch-tags)
+ (let* ((senator-highlight-found nil)
+ ;; Step at beginning of next tag with class specified in
+ ;; `senator-step-at-tag-classes'.
+ (senator-step-at-start-end-tag-classes t)
+ (tag (senator-previous-tag)))
+ (when tag
+ (if (= (point) (semantic-tag-end tag))
+ (goto-char (semantic-tag-start tag)))
+ (beginning-of-line))))
+
+(defun senator-end-of-defun (&optional arg)
+ "Move forward to next end of defun.
+Use semantic tags to navigate.
+ARG is the number of tags to navigate (not yet implemented)."
+ (semantic-fetch-tags)
+ (let* ((senator-highlight-found nil)
+ ;; Step at end of next tag with class specified in
+ ;; `senator-step-at-tag-classes'.
+ (senator-step-at-start-end-tag-classes t)
+ (tag (senator-next-tag)))
+ (when tag
+ (if (= (point) (semantic-tag-start tag))
+ (goto-char (semantic-tag-end tag)))
+ (skip-chars-forward " \t")
+ (if (looking-at "\\s<\\|\n")
+ (forward-line 1)))))
+
+(defun senator-narrow-to-defun ()
+ "Make text outside current defun invisible.
+The defun visible is the one that contains point or follows point.
+Use semantic tags to navigate."
+ (interactive)
+ (semantic-fetch-tags)
+ (save-excursion
+ (widen)
+ (senator-end-of-defun)
+ (let ((end (point)))
+ (senator-beginning-of-defun)
+ (narrow-to-region (point) end))))
+
+(defun senator-mark-defun ()
+ "Put mark at end of this defun, point at beginning.
+The defun marked is the one that contains point or follows point.
+Use semantic tags to navigate."
+ (interactive)
+ (let ((origin (point))
+ (end (progn (senator-end-of-defun) (point)))
+ (start (progn (senator-beginning-of-defun) (point))))
+ (goto-char origin)
+ (push-mark (point))
+ (goto-char end) ;; end-of-defun
+ (push-mark (point) nil t)
+ (goto-char start) ;; beginning-of-defun
+ (re-search-backward "^\n" (- (point) 1) t)))
+
+;;; Tag Cut & Paste
+
+;; To copy a tag, means to put a tag definition into the tag
+;; ring. To kill a tag, put the tag into the tag ring AND put
+;; the body of the tag into the kill-ring.
+;;
+;; To retrieve a killed tag's text, use C-y (yank), but to retrieve
+;; the tag as a reference of some sort, use senator-yank-tag.
+
+(defvar senator-tag-ring (make-ring 20)
+ "Ring of tags for use with cut and paste.")
+
+;;;###autoload
+(defun senator-copy-tag ()
+ "Take the current tag, and place it in the tag ring."
+ (interactive)
+ (semantic-fetch-tags)
+ (let ((ft (semantic-obtain-foreign-tag)))
+ (when ft
+ (ring-insert senator-tag-ring ft)
+ (kill-ring-save (semantic-tag-start ft) (semantic-tag-end ft))
+ (when (interactive-p)
+ (message "Use C-y to yank text. Use `senator-yank-tag' for prototype
insert."))
+ )
+ ft))
+
+;;;###autoload
+(defun senator-kill-tag ()
+ "Take the current tag, place it in the tag ring, and kill it.
+Killing the tag removes the text for that tag, and places it into
+the kill ring. Retrieve that text with \\[yank]."
+ (interactive)
+ (let ((ct (senator-copy-tag))) ;; this handles the reparse for us.
+ (kill-region (semantic-tag-start ct)
+ (semantic-tag-end ct))
+ (when (interactive-p)
+ (message "Use C-y to yank text. Use `senator-yank-tag' for prototype
insert."))
+ ))
+
+;;;###autoload
+(defun senator-yank-tag ()
+ "Yank a tag from the tag ring.
+The form the tag takes is differnet depending on where it is being
+yanked to."
+ (interactive)
+ (or (ring-empty-p senator-tag-ring)
+ (let ((ft (ring-ref senator-tag-ring 0)))
+ (semantic-foreign-tag-check ft)
+ (semantic-insert-foreign-tag ft)
+ (when (interactive-p)
+ (message "Use C-y to recover the yank the text of %s."
+ (semantic-tag-name ft)))
+ )))
+
+;;;###autoload
+(defun senator-copy-tag-to-register (register &optional kill-flag)
+ "Copy the current tag into REGISTER.
+Optional argument KILL-FLAG will delete the text of the tag to the
+kill ring."
+ (interactive "cTag to register: \nP")
+ (semantic-fetch-tags)
+ (let ((ft (semantic-obtain-foreign-tag)))
+ (when ft
+ (set-register register ft)
+ (if kill-flag
+ (kill-region (semantic-tag-start ft)
+ (semantic-tag-end ft))))))
+
+;;;###autoload
+(defun senator-transpose-tags-up ()
+ "Transpose the current tag, and the preceeding tag."
+ (interactive)
+ (semantic-fetch-tags)
+ (let* ((current-tag (semantic-current-tag))
+ (prev-tag (save-excursion
+ (goto-char (semantic-tag-start current-tag))
+ (semantic-find-tag-by-overlay-prev)))
+ (ct-parent (semantic-find-tag-parent-by-overlay current-tag))
+ (pt-parent (semantic-find-tag-parent-by-overlay prev-tag)))
+ (if (not (eq ct-parent pt-parent))
+ (error "Cannot transpose tags"))
+ (let ((txt (buffer-substring (semantic-tag-start current-tag)
+ (semantic-tag-end current-tag)))
+ (line (count-lines (semantic-tag-start current-tag)
+ (point)))
+ (insert-point nil)
+ )
+ (delete-region (semantic-tag-start current-tag)
+ (semantic-tag-end current-tag))
+ (delete-blank-lines)
+ (goto-char (semantic-tag-start prev-tag))
+ (setq insert-point (point))
+ (insert txt)
+ (if (/= (current-column) 0)
+ (insert "\n"))
+ (insert "\n")
+ (goto-char insert-point)
+ (forward-line line)
+ )))
+
+;;;###autoload
+(defun senator-transpose-tags-down ()
+ "Transpose the current tag, and the following tag."
+ (interactive)
+ (semantic-fetch-tags)
+ (let* ((current-tag (semantic-current-tag))
+ (next-tag (save-excursion
+ (goto-char (semantic-tag-end current-tag))
+ (semantic-find-tag-by-overlay-next)))
+ (end-pt (point-marker))
+ )
+ (goto-char (semantic-tag-start next-tag))
+ (forward-char 1)
+ (senator-transpose-tags-up)
+ ;; I know that the above fcn deletes the next tag, so our pt marker
+ ;; will be stable.
+ (goto-char end-pt)))
+
+;;; Using semantic search in isearch mode
+
+(defun senator-lazy-highlight-update ()
+ "Force lazy highlight update."
+ (lazy-highlight-cleanup t)
+ (set 'isearch-lazy-highlight-last-string nil)
+ (setq isearch-adjusted t)
+ (isearch-update))
+
+;; Recent versions of GNU Emacs allow to override the isearch search
+;; function for special needs, and avoid to advice the built-in search
+;; function :-)
+(defun senator-isearch-search-fun ()
+ "Return the function to use for the search.
+Use a senator search function when semantic isearch mode is enabled."
+ (intern
+ (concat (if senator-isearch-semantic-mode
+ "senator-"
+ "")
+ (cond (isearch-word "word-")
+ (isearch-regexp "re-")
+ (t ""))
+ "search-"
+ (if isearch-forward
+ "forward"
+ "backward"))))
+
+(defun senator-isearch-toggle-semantic-mode ()
+ "Toggle semantic searching on or off in isearch mode."
+ (interactive)
+ (setq senator-isearch-semantic-mode
+ (not senator-isearch-semantic-mode))
+ (if isearch-mode
+ ;; force lazy highlight update
+ (senator-lazy-highlight-update)
+ (message "Isearch semantic mode %s"
+ (if senator-isearch-semantic-mode
+ "enabled"
+ "disabled"))))
+
+(defvar senator-old-isearch-search-fun nil
+ "Hold previous value of `isearch-search-fun-function'.")
+
+(defun senator-isearch-mode-hook ()
+ "Isearch mode hook to setup semantic searching."
+ (if (and isearch-mode senator-isearch-semantic-mode)
+ (progn
+ ;; When `senator-isearch-semantic-mode' is on save the
+ ;; previous `isearch-search-fun-function' and install the
+ ;; senator one.
+ (when (and (local-variable-p 'isearch-search-fun-function)
+ (not (local-variable-p 'senator-old-isearch-search-fun)))
+ (set (make-local-variable 'senator-old-isearch-search-fun)
+ isearch-search-fun-function))
+ (set (make-local-variable 'isearch-search-fun-function)
+ 'senator-isearch-search-fun))
+ ;; When `senator-isearch-semantic-mode' is off restore the
+ ;; previous `isearch-search-fun-function'.
+ (when (eq isearch-search-fun-function 'senator-isearch-search-fun)
+ (if (local-variable-p 'senator-old-isearch-search-fun)
+ (progn
+ (set (make-local-variable 'isearch-search-fun-function)
+ senator-old-isearch-search-fun)
+ (kill-local-variable 'senator-old-isearch-search-fun))
+ (kill-local-variable 'isearch-search-fun-function)))))
+
+;; (add-hook 'isearch-mode-hook 'senator-isearch-mode-hook)
+;; (add-hook 'isearch-mode-end-hook 'senator-isearch-mode-hook)
+
+;; ;; Keyboard shortcut to toggle semantic search in isearch mode.
+;; (define-key isearch-mode-map
+;; [(control ?,)]
+;; 'senator-isearch-toggle-semantic-mode)
+
+;; (defadvice insert-register (around senator activate)
+;; "Insert contents of register REGISTER as a tag.
+;; If senator is not active, use the original mechanism."
+;; (let ((val (get-register (ad-get-arg 0))))
+;; (if (and senator-minor-mode (interactive-p)
+;; (semantic-foreign-tag-p val))
+;; (semantic-insert-foreign-tag val)
+;; ad-do-it)))
+
+;; (defadvice jump-to-register (around senator activate)
+;; "Insert contents of register REGISTER as a tag.
+;; If senator is not active, use the original mechanism."
+;; (let ((val (get-register (ad-get-arg 0))))
+;; (if (and senator-minor-mode (interactive-p)
+;; (semantic-foreign-tag-p val))
+;; (progn
+;; (switch-to-buffer (semantic-tag-buffer val))
+;; (goto-char (semantic-tag-start val)))
+;; ad-do-it)))
+
+(provide 'semantic/senator)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/senator"
+;; End:
+
+;;; semantic/senator.el ends here
Index: cedet/semantic/sort.el
===================================================================
RCS file: cedet/semantic/sort.el
diff -N cedet/semantic/sort.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/sort.el 28 Sep 2009 15:15:09 -0000 1.2
@@ -0,0 +1,570 @@
+;;; sort.el --- Utilities for sorting and re-arranging tag tables.
+
+;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
+;;; 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Tag tables originate in the order they appear in a buffer, or source file.
+;; It is often useful to re-arrange them is some predictable way for browsing
+;; purposes. Re-organization may be alphabetical, or even a complete
+;; reorganization of parents and children.
+;;
+;; Originally written in semantic-util.el
+;;
+
+(require 'semantic)
+(eval-when-compile
+ (require 'semantic/find))
+
+(declare-function semanticdb-find-tags-external-children-of-type
+ "semantic/db-find")
+
+;;; Alphanumeric sorting
+;;
+;; Takes a list of tags, and sorts them in a case-insensitive way
+;; at a single level.
+
+;;; Code:
+(defun semantic-string-lessp-ci (s1 s2)
+ "Case insensitive version of `string-lessp'.
+Argument S1 and S2 are the strings to compare."
+ ;; Use downcase instead of upcase because an average name
+ ;; has more lower case characters.
+ (if (fboundp 'compare-strings)
+ (eq (compare-strings s1 0 nil s2 0 nil t) -1)
+ (string-lessp (downcase s1) (downcase s2))))
+
+(defun semantic-sort-tag-type (tag)
+ "Return a type string for TAG guaranteed to be a string."
+ (let ((ty (semantic-tag-type tag)))
+ (cond ((stringp ty)
+ ty)
+ ((listp ty)
+ (or (car ty) ""))
+ (t ""))))
+
+(defun semantic-tag-lessp-name-then-type (A B)
+ "Return t if tag A is < tag B.
+First sorts on name, then sorts on the name of the :type of
+each tag."
+ (let ((na (semantic-tag-name A))
+ (nb (semantic-tag-name B))
+ )
+ (if (string-lessp na nb)
+ t ; a sure thing.
+ (if (string= na nb)
+ ;; If equal, test the :type which might be different.
+ (let* ((ta (semantic-tag-type A))
+ (tb (semantic-tag-type B))
+ (tas (cond ((stringp ta)
+ ta)
+ ((semantic-tag-p ta)
+ (semantic-tag-name ta))
+ (t nil)))
+ (tbs (cond ((stringp tb)
+ tb)
+ ((semantic-tag-p tb)
+ (semantic-tag-name tb))
+ (t nil))))
+ (if (and (stringp tas) (stringp tbs))
+ (string< tas tbs)
+ ;; This is if A == B, and no types in A or B
+ nil))
+ ;; This nil is if A > B, but not =
+ nil))))
+
+(defun semantic-sort-tags-by-name-increasing (tags)
+ "Sort TAGS by name in increasing order with side effects.
+Return the sorted list."
+ (sort tags (lambda (a b)
+ (string-lessp (semantic-tag-name a)
+ (semantic-tag-name b)))))
+
+(defun semantic-sort-tags-by-name-decreasing (tags)
+ "Sort TAGS by name in decreasing order with side effects.
+Return the sorted list."
+ (sort tags (lambda (a b)
+ (string-lessp (semantic-tag-name b)
+ (semantic-tag-name a)))))
+
+(defun semantic-sort-tags-by-type-increasing (tags)
+ "Sort TAGS by type in increasing order with side effects.
+Return the sorted list."
+ (sort tags (lambda (a b)
+ (string-lessp (semantic-sort-tag-type a)
+ (semantic-sort-tag-type b)))))
+
+(defun semantic-sort-tags-by-type-decreasing (tags)
+ "Sort TAGS by type in decreasing order with side effects.
+Return the sorted list."
+ (sort tags (lambda (a b)
+ (string-lessp (semantic-sort-tag-type b)
+ (semantic-sort-tag-type a)))))
+
+(defun semantic-sort-tags-by-name-increasing-ci (tags)
+ "Sort TAGS by name in increasing order with side effects.
+Return the sorted list."
+ (sort tags (lambda (a b)
+ (semantic-string-lessp-ci (semantic-tag-name a)
+ (semantic-tag-name b)))))
+
+(defun semantic-sort-tags-by-name-decreasing-ci (tags)
+ "Sort TAGS by name in decreasing order with side effects.
+Return the sorted list."
+ (sort tags (lambda (a b)
+ (semantic-string-lessp-ci (semantic-tag-name b)
+ (semantic-tag-name a)))))
+
+(defun semantic-sort-tags-by-type-increasing-ci (tags)
+ "Sort TAGS by type in increasing order with side effects.
+Return the sorted list."
+ (sort tags (lambda (a b)
+ (semantic-string-lessp-ci (semantic-sort-tag-type a)
+ (semantic-sort-tag-type b)))))
+
+(defun semantic-sort-tags-by-type-decreasing-ci (tags)
+ "Sort TAGS by type in decreasing order with side effects.
+Return the sorted list."
+ (sort tags (lambda (a b)
+ (semantic-string-lessp-ci (semantic-sort-tag-type b)
+ (semantic-sort-tag-type a)))))
+
+(defun semantic-sort-tags-by-name-then-type-increasing (tags)
+ "Sort TAGS by name, then type in increasing order with side effects.
+Return the sorted list."
+ (sort tags (lambda (a b) (semantic-tag-lessp-name-then-type a b))))
+
+(defun semantic-sort-tags-by-name-then-type-decreasing (tags)
+ "Sort TAGS by name, then type in increasing order with side effects.
+Return the sorted list."
+ (sort tags (lambda (a b) (semantic-tag-lessp-name-then-type b a))))
+
+;;; Unique
+;;
+;; Scan a list of tags, removing duplicates.
+;; This must first sort the tags by name alphabetically ascending.
+;;
+;; Useful for completion lists, or other situations where the
+;; other data isn't as useful.
+
+(defun semantic-unique-tag-table-by-name (tags)
+ "Scan a list of TAGS, removing duplicate names.
+This must first sort the tags by name alphabetically ascending.
+For more complex uniqueness testing used by the semanticdb
+typecaching system, see `semanticdb-typecache-merge-streams'."
+ (let ((sorted (semantic-sort-tags-by-name-increasing
+ (copy-sequence tags)))
+ (uniq nil))
+ (while sorted
+ (if (or (not uniq)
+ (not (string= (semantic-tag-name (car sorted))
+ (semantic-tag-name (car uniq)))))
+ (setq uniq (cons (car sorted) uniq)))
+ (setq sorted (cdr sorted))
+ )
+ (nreverse uniq)))
+
+(defun semantic-unique-tag-table (tags)
+ "Scan a list of TAGS, removing duplicates.
+This must first sort the tags by position ascending.
+TAGS are removed only if they are equivalent, as can happen when
+multiple tag sources are scanned.
+For more complex uniqueness testing used by the semanticdb
+typecaching system, see `semanticdb-typecache-merge-streams'."
+ (let ((sorted (sort (copy-sequence tags)
+ (lambda (a b)
+ (cond ((not (semantic-tag-with-position-p a))
+ t)
+ ((not (semantic-tag-with-position-p b))
+ nil)
+ (t
+ (< (semantic-tag-start a)
+ (semantic-tag-start b)))))))
+ (uniq nil))
+ (while sorted
+ (if (or (not uniq)
+ (not (semantic-equivalent-tag-p (car sorted) (car uniq))))
+ (setq uniq (cons (car sorted) uniq)))
+ (setq sorted (cdr sorted))
+ )
+ (nreverse uniq)))
+
+
+;;; Tag Table Flattening
+;;
+;; In the 1.4 search API, there was a parameter "search-parts" which
+;; was used to find tags inside other tags. This was used
+;; infrequently, mostly for completion/jump routines. These types
+;; of commands would be better off with a flattened list, where all
+;; tags appear at the top level.
+
+;;;###autoload
+(defun semantic-flatten-tags-table (&optional table)
+ "Flatten the tags table TABLE.
+All tags in TABLE, and all components of top level tags
+in TABLE will appear at the top level of list.
+Tags promoted to the top of the list will still appear
+unmodified as components of their parent tags."
+ (let* ((table (semantic-something-to-tag-table table))
+ ;; Initialize the starting list with our table.
+ (lists (list table)))
+ (mapc (lambda (tag)
+ (let ((components (semantic-tag-components tag)))
+ (if (and components
+ ;; unpositined tags can be hazardous to
+ ;; completion. Do we need any type of tag
+ ;; here? - EL
+ (semantic-tag-with-position-p (car components)))
+ (setq lists (cons
+ (semantic-flatten-tags-table components)
+ lists)))))
+ table)
+ (apply 'append (nreverse lists))
+ ))
+
+
+;;; Buckets:
+;;
+;; A list of tags can be grouped into buckets based on the tag class.
+;; Bucketize means to take a list of tags at a given level in a tag
+;; table, and reorganize them into buckets based on class.
+;;
+(defvar semantic-bucketize-tag-class
+ ;; Must use lambda because `semantic-tag-class' is a macro.
+ (lambda (tok) (semantic-tag-class tok))
+ "Function used to get a symbol describing the class of a tag.
+This function must take one argument of a semantic tag.
+It should return a symbol found in `semantic-symbol->name-assoc-list'
+which `semantic-bucketize' uses to bin up tokens.
+To create new bins for an application augment
+`semantic-symbol->name-assoc-list', and
+`semantic-symbol->name-assoc-list-for-type-parts' in addition
+to setting this variable (locally in your function).")
+
+(defun semantic-bucketize (tags &optional parent filter)
+ "Sort TAGS into a group of buckets based on tag class.
+Unknown classes are placed in a Misc bucket.
+Type bucket names are defined by either `semantic-symbol->name-assoc-list'.
+If PARENT is specified, then TAGS belong to this PARENT in some way.
+This will use `semantic-symbol->name-assoc-list-for-type-parts' to
+generate bucket names.
+Optional argument FILTER is a filter function to be applied to each bucket.
+The filter function will take one argument, which is a list of tokens, and
+may re-organize the list with side-effects."
+ (let* ((name-list (if parent
+ semantic-symbol->name-assoc-list-for-type-parts
+ semantic-symbol->name-assoc-list))
+ (sn name-list)
+ (bins (make-vector (1+ (length sn)) nil))
+ ask tagtype
+ (nsn nil)
+ (num 1)
+ (out nil))
+ ;; Build up the bucket vector
+ (while sn
+ (setq nsn (cons (cons (car (car sn)) num) nsn)
+ sn (cdr sn)
+ num (1+ num)))
+ ;; Place into buckets
+ (while tags
+ (setq tagtype (funcall semantic-bucketize-tag-class (car tags))
+ ask (assq tagtype nsn)
+ num (or (cdr ask) 0))
+ (aset bins num (cons (car tags) (aref bins num)))
+ (setq tags (cdr tags)))
+ ;; Remove from buckets into a list.
+ (setq num 1)
+ (while (< num (length bins))
+ (when (aref bins num)
+ (setq out
+ (cons (cons
+ (cdr (nth (1- num) name-list))
+ ;; Filtering, First hacked by David Ponce address@hidden
+ (funcall (or filter 'nreverse) (aref bins num)))
+ out)))
+ (setq num (1+ num)))
+ (if (aref bins 0)
+ (setq out (cons (cons "Misc"
+ (funcall (or filter 'nreverse) (aref bins 0)))
+ out)))
+ (nreverse out)))
+
+;;; Adoption
+;;
+;; Some languages allow children of a type to be defined outside
+;; the syntactic scope of that class. These routines will find those
+;; external members, and bring them together in a cloned copy of the
+;; class tag.
+;;
+(defvar semantic-orphaned-member-metaparent-type "class"
+ "In `semantic-adopt-external-members', the type of 'type for metaparents.
+A metaparent is a made-up type semantic token used to hold the child list
+of orphaned members of a named type.")
+(make-variable-buffer-local 'semantic-orphaned-member-metaparent-type)
+
+(defvar semantic-mark-external-member-function nil
+ "Function called when an externally defined orphan is found.
+By default, the token is always marked with the `adopted' property.
+This function should be locally bound by a program that needs
+to add additional behaviors into the token list.
+This function is called with two arguments. The first is TOKEN which is
+a shallow copy of the token to be modified. The second is the PARENT
+which is adopting TOKEN. This function should return TOKEN (or a copy of it)
+which is then integrated into the revised token list.")
+
+(defun semantic-adopt-external-members (tags)
+ "Rebuild TAGS so that externally defined members are regrouped.
+Some languages such as C++ and CLOS permit the declaration of member
+functions outside the definition of the class. It is easier to study
+the structure of a program when such methods are grouped together
+more logically.
+
+This function uses `semantic-tag-external-member-p' to
+determine when a potential child is an externally defined member.
+
+Note: Applications which use this function must account for token
+types which do not have a position, but have children which *do*
+have positions.
+
+Applications should use `semantic-mark-external-member-function'
+to modify all tags which are found as externally defined to some
+type. For example, changing the token type for generating extra
+buckets with the bucket function."
+ (let ((parent-buckets nil)
+ (decent-list nil)
+ (out nil)
+ (tmp nil)
+ )
+ ;; Rebuild the output list, stripping out all parented
+ ;; external entries
+ (while tags
+ (cond
+ ((setq tmp (semantic-tag-external-member-parent (car tags)))
+ (let ((tagcopy (semantic-tag-clone (car tags)))
+ (a (assoc tmp parent-buckets)))
+ (semantic--tag-put-property-no-side-effect tagcopy 'adopted t)
+ (if a
+ ;; If this parent is already in the list, append.
+ (setcdr (nthcdr (1- (length a)) a) (list tagcopy))
+ ;; If not, prepend this new parent bucket into our list
+ (setq parent-buckets
+ (cons (cons tmp (list tagcopy)) parent-buckets)))
+ ))
+ ((eq (semantic-tag-class (car tags)) 'type)
+ ;; Types need to be rebuilt from scratch so we can add in new
+ ;; children to the child list. Only the top-level cons
+ ;; cells need to be duplicated so we can hack out the
+ ;; child list later.
+ (setq out (cons (semantic-tag-clone (car tags)) out))
+ (setq decent-list (cons (car out) decent-list))
+ )
+ (t
+ ;; Otherwise, append this tag to our new output list.
+ (setq out (cons (car tags) out)))
+ )
+ (setq tags (cdr tags)))
+ ;; Rescan out, by descending into all types and finding parents
+ ;; for all entries moved into the parent-buckets.
+ (while decent-list
+ (let* ((bucket (assoc (semantic-tag-name (car decent-list))
+ parent-buckets))
+ (bucketkids (cdr bucket)))
+ (when bucket
+ ;; Run our secondary marking function on the children
+ (if semantic-mark-external-member-function
+ (setq bucketkids
+ (mapcar (lambda (tok)
+ (funcall semantic-mark-external-member-function
+ tok (car decent-list)))
+ bucketkids)))
+ ;; We have some extra kids. Merge.
+ (semantic-tag-put-attribute
+ (car decent-list) :members
+ (append (semantic-tag-type-members (car decent-list))
+ bucketkids))
+ ;; Nuke the bucket label so it is not found again.
+ (setcar bucket nil))
+ (setq decent-list
+ (append (cdr decent-list)
+ ;; get embedded types to scan and make copies
+ ;; of them.
+ (mapcar
+ (lambda (tok) (semantic-tag-clone tok))
+ (semantic-find-tags-by-class 'type
+ (semantic-tag-type-members (car decent-list)))))
+ )))
+ ;; Scan over all remaining lost external methods, and tack them
+ ;; onto the end.
+ (while parent-buckets
+ (if (car (car parent-buckets))
+ (let* ((tmp (car parent-buckets))
+ (fauxtag (semantic-tag-new-type
+ (car tmp)
+ semantic-orphaned-member-metaparent-type
+ nil ;; Part list
+ nil ;; parents (unknown)
+ ))
+ (bucketkids (cdr tmp)))
+ (semantic-tag-set-faux fauxtag) ;; properties
+ (if semantic-mark-external-member-function
+ (setq bucketkids
+ (mapcar (lambda (tok)
+ (funcall semantic-mark-external-member-function
+ tok fauxtag))
+ bucketkids)))
+ (semantic-tag-put-attribute fauxtag :members bucketkids)
+ ;; We have a bunch of methods with no parent in this file.
+ ;; Create a meta-type to hold it.
+ (setq out (cons fauxtag out))
+ ))
+ (setq parent-buckets (cdr parent-buckets)))
+ ;; Return the new list.
+ (nreverse out)))
+
+
+;;; External children
+;;
+;; In order to adopt external children, we need a few overload methods
+;; to enable the feature.
+
+;;;###autoload
+(define-overloadable-function semantic-tag-external-member-parent (tag)
+ "Return a parent for TAG when TAG is an external member.
+TAG is an external member if it is defined at a toplevel and
+has some sort of label defining a parent. The parent return will
+be a string.
+
+The default behavior, if not overridden with
+`tag-member-parent' gets the 'parent extra
+specifier of TAG.
+
+If this function is overridden, use
+`semantic-tag-external-member-parent-default' to also
+include the default behavior, and merely extend your own."
+ )
+
+(defun semantic-tag-external-member-parent-default (tag)
+ "Return the name of TAGs parent only if TAG is not defined in it's parent."
+ ;; Use only the extra spec because a type has a parent which
+ ;; means something completely different.
+ (let ((tp (semantic-tag-get-attribute tag :parent)))
+ (when (stringp tp)
+ tp)))
+
+(define-overloadable-function semantic-tag-external-member-p (parent tag)
+ "Return non-nil if PARENT is the parent of TAG.
+TAG is an external member of PARENT when it is somehow tagged
+as having PARENT as it's parent.
+PARENT and TAG must both be semantic tags.
+
+The default behavior, if not overridden with
+`tag-external-member-p' is to match :parent attribute in
+the name of TAG.
+
+If this function is overridden, use
+`semantic-tag-external-member-children-p-default' to also
+include the default behavior, and merely extend your own."
+ )
+
+(defun semantic-tag-external-member-p-default (parent tag)
+ "Return non-nil if PARENT is the parent of TAG."
+ ;; Use only the extra spec because a type has a parent which
+ ;; means something completely different.
+ (let ((tp (semantic-tag-external-member-parent tag)))
+ (and (stringp tp)
+ (string= (semantic-tag-name parent) tp))))
+
+(define-overloadable-function semantic-tag-external-member-children (tag
&optional usedb)
+ "Return the list of children which are not *in* TAG.
+If optional argument USEDB is non-nil, then also search files in
+the Semantic Database. If USEDB is a list of databases, search those
+databases.
+
+Children in this case are functions or types which are members of
+TAG, such as the parts of a type, but which are not defined inside
+the class. C++ and CLOS both permit methods of a class to be defined
+outside the bounds of the class' definition.
+
+The default behavior, if not overridden with
+`tag-external-member-children' is to search using
+`semantic-tag-external-member-p' in all top level definitions
+with a parent of TAG.
+
+If this function is overridden, use
+`semantic-tag-external-member-children-default' to also
+include the default behavior, and merely extend your own."
+ )
+
+(defun semantic-tag-external-member-children-default (tag &optional usedb)
+ "Return list of external children for TAG.
+Optional argument USEDB specifies if the semantic database is used.
+See `semantic-tag-external-member-children' for details."
+ (if (and usedb
+ (require 'semantic/db-mode)
+ (semanticdb-minor-mode-p)
+ (require 'semantic/db-find))
+ (let ((m (semanticdb-find-tags-external-children-of-type
+ (semantic-tag-name tag))))
+ (if m (apply #'append (mapcar #'cdr m))))
+ (semantic--find-tags-by-function
+ `(lambda (tok)
+ ;; This bit of annoying backquote forces the contents of
+ ;; tag into the generated lambda.
+ (semantic-tag-external-member-p ',tag tok))
+ (current-buffer))
+ ))
+
+(define-overloadable-function semantic-tag-external-class (tag)
+ "Return a list of real tags that faux TAG might represent.
+
+In some languages, a method can be defined on an object which is
+not in the same file. In this case,
+`semantic-adopt-external-members' will create a faux-tag. If it
+is necessary to get the tag from which for faux TAG was most
+likely derived, then this function is needed."
+ (unless (semantic-tag-faux-p tag)
+ (signal 'wrong-type-argument (list tag 'semantic-tag-faux-p)))
+ (:override)
+ )
+
+(defun semantic-tag-external-class-default (tag)
+ "Return a list of real tags that faux TAG might represent.
+See `semantic-tag-external-class' for details."
+ (if (and (require 'semantic/db-mode)
+ (semanticdb-minor-mode-p))
+ (let* ((semanticdb-search-system-databases nil)
+ (m (semanticdb-find-tags-by-class
+ (semantic-tag-class tag)
+ (semanticdb-find-tags-by-name (semantic-tag-name tag)))))
+ (semanticdb-strip-find-results m 'name))
+ ;; Presumably, if the tag is faux, it is not local.
+ nil))
+
+(provide 'semantic/sort)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/sort"
+;; End:
+
+;;; semantic-sort.el ends here
Index: cedet/semantic/symref.el
===================================================================
RCS file: cedet/semantic/symref.el
diff -N cedet/semantic/symref.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/symref.el 28 Sep 2009 15:15:09 -0000 1.2
@@ -0,0 +1,501 @@
+;;; semantic/symref.el --- Symbol Reference API
+
+;;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Semantic Symbol Reference API.
+;;
+;; Semantic's native parsing tools do not handle symbol references.
+;; Tracking such information is a task that requires a huge amount of
+;; space and processing not apropriate for an Emacs Lisp program.
+;;
+;; Many desired tools used in refactoring, however, need to have
+;; such references available to them. This API aims to provide a
+;; range of functions that can be used to identify references. The
+;; API is backed by an OO system that is used to allow multiple
+;; external tools to provide the information.
+;;
+;; The default implementation uses a find/grep combination to do a
+;; search. This works ok in small projects. For larger projects, it
+;; is important to find an alternate tool to use as a back-end to
+;; symref.
+;;
+;; See the command: `semantic-symref' for an example app using this api.
+;;
+;; TO USE THIS TOOL
+;;
+;; The following functions can be used to find different kinds of
+;; references.
+;;
+;; `semantic-symref-find-references-by-name'
+;; `semantic-symref-find-file-references-by-name'
+;; `semantic-symref-find-text'
+;;
+;; All the search routines return a class of type
+;; `semantic-symref-result'. You can reference the various slots, but
+;; you will need the following methods to get extended information.
+;;
+;; `semantic-symref-result-get-files'
+;; `semantic-symref-result-get-tags'
+;;
+;; ADD A NEW EXTERNAL TOOL
+;;
+;; To support a new external tool, sublcass `semantic-symref-tool-baseclass'
+;; and implement the methods. The baseclass provides support for
+;; managing external processes that produce parsable output.
+;;
+;; Your tool should then create an instance of `semantic-symref-result'.
+
+(require 'semantic)
+
+(defvar ede-minor-mode)
+(declare-function data-debug-new-buffer "data-debug")
+(declare-function data-debug-insert-object-slots "eieio-datadebug")
+(declare-function ede-toplevel "ede/files")
+(declare-function ede-project-root-directory "ede/files")
+
+;;; Code:
+(defvar semantic-symref-tool 'detect
+ "*The active symbol reference tool name.
+The tool symbol can be 'detect, or a symbol that is the name of
+a tool that can be used for symbol referencing.")
+(make-variable-buffer-local 'semantic-symref-tool)
+
+;;; TOOL SETUP
+;;
+(defvar semantic-symref-tool-alist
+ '( ( (lambda (rootdir) (file-exists-p (expand-file-name "GPATH" rootdir))) .
+ global)
+ ( (lambda (rootdir) (file-exists-p (expand-file-name "ID" rootdir))) .
+ idutils)
+ ( (lambda (rootdir) (file-exists-p (expand-file-name "cscope.out"
rootdir))) .
+ cscope )
+ )
+ "Alist of tools usable by `semantic-symref'.
+Each entry is of the form:
+ ( PREDICATE . KEY )
+Where PREDICATE is a function that takes a directory name for the
+root of a project, and returns non-nil if the tool represented by KEY
+is supported.
+
+If no tools are supported, then 'grep is assumed.")
+
+(defun semantic-symref-detect-symref-tool ()
+ "Detect the symref tool to use for the current buffer."
+ (if (not (eq semantic-symref-tool 'detect))
+ semantic-symref-tool
+ ;; We are to perform a detection for the right tool to use.
+ (let* ((rootproj (when (and (featurep 'ede) ede-minor-mode)
+ (ede-toplevel)))
+ (rootdir (if rootproj
+ (ede-project-root-directory rootproj)
+ default-directory))
+ (tools semantic-symref-tool-alist))
+ (while (and tools (eq semantic-symref-tool 'detect))
+ (when (funcall (car (car tools)) rootdir)
+ (setq semantic-symref-tool (cdr (car tools))))
+ (setq tools (cdr tools)))
+
+ (when (eq semantic-symref-tool 'detect)
+ (setq semantic-symref-tool 'grep))
+
+ semantic-symref-tool)))
+
+(defun semantic-symref-instantiate (&rest args)
+ "Instantiate a new symref search object.
+ARGS are the initialization arguments to pass to the created class."
+ (let* ((srt (symbol-name (semantic-symref-detect-symref-tool)))
+ (class (intern-soft (concat "semantic-symref-tool-" srt)))
+ (inst nil)
+ )
+ (when (not (class-p class))
+ (error "Unknown symref tool %s" semantic-symref-tool))
+ (setq inst (apply 'make-instance class args))
+ inst))
+
+(defvar semantic-symref-last-result nil
+ "The last calculated symref result.")
+
+(defun semantic-symref-data-debug-last-result ()
+ "Run the last symref data result in Data Debug."
+ (interactive)
+ (require 'eieio-datadebug)
+ (if semantic-symref-last-result
+ (progn
+ (data-debug-new-buffer "*Symbol Reference ADEBUG*")
+ (data-debug-insert-object-slots semantic-symref-last-result "]"))
+ (message "Empty results.")))
+
+;;; EXTERNAL API
+;;
+
+;;;###autoload
+(defun semantic-symref-find-references-by-name (name &optional scope
tool-return)
+ "Find a list of references to NAME in the current project.
+Optional SCOPE specifies which file set to search. Defaults to 'project.
+Refers to `semantic-symref-tool', to determine the reference tool to use
+for the current buffer.
+Returns an object of class `semantic-symref-result'.
+TOOL-RETURN is an optional symbol, which will be assigned the tool used
+to perform the search. This was added for use by a test harness."
+ (interactive "sName: ")
+ (let* ((inst (semantic-symref-instantiate
+ :searchfor name
+ :searchtype 'symbol
+ :searchscope (or scope 'project)
+ :resulttype 'line))
+ (result (semantic-symref-get-result inst)))
+ (when tool-return
+ (set tool-return inst))
+ (prog1
+ (setq semantic-symref-last-result result)
+ (when (interactive-p)
+ (semantic-symref-data-debug-last-result))))
+ )
+
+;;;###autoload
+(defun semantic-symref-find-tags-by-name (name &optional scope)
+ "Find a list of references to NAME in the current project.
+Optional SCOPE specifies which file set to search. Defaults to 'project.
+Refers to `semantic-symref-tool', to determine the reference tool to use
+for the current buffer.
+Returns an object of class `semantic-symref-result'."
+ (interactive "sName: ")
+ (let* ((inst (semantic-symref-instantiate
+ :searchfor name
+ :searchtype 'tagname
+ :searchscope (or scope 'project)
+ :resulttype 'line))
+ (result (semantic-symref-get-result inst)))
+ (prog1
+ (setq semantic-symref-last-result result)
+ (when (interactive-p)
+ (semantic-symref-data-debug-last-result))))
+ )
+
+;;;###autoload
+(defun semantic-symref-find-tags-by-regexp (name &optional scope)
+ "Find a list of references to NAME in the current project.
+Optional SCOPE specifies which file set to search. Defaults to 'project.
+Refers to `semantic-symref-tool', to determine the reference tool to use
+for the current buffer.
+Returns an object of class `semantic-symref-result'."
+ (interactive "sName: ")
+ (let* ((inst (semantic-symref-instantiate
+ :searchfor name
+ :searchtype 'tagregexp
+ :searchscope (or scope 'project)
+ :resulttype 'line))
+ (result (semantic-symref-get-result inst)))
+ (prog1
+ (setq semantic-symref-last-result result)
+ (when (interactive-p)
+ (semantic-symref-data-debug-last-result))))
+ )
+
+;;;###autoload
+(defun semantic-symref-find-tags-by-completion (name &optional scope)
+ "Find a list of references to NAME in the current project.
+Optional SCOPE specifies which file set to search. Defaults to 'project.
+Refers to `semantic-symref-tool', to determine the reference tool to use
+for the current buffer.
+Returns an object of class `semantic-symref-result'."
+ (interactive "sName: ")
+ (let* ((inst (semantic-symref-instantiate
+ :searchfor name
+ :searchtype 'tagcompletions
+ :searchscope (or scope 'project)
+ :resulttype 'line))
+ (result (semantic-symref-get-result inst)))
+ (prog1
+ (setq semantic-symref-last-result result)
+ (when (interactive-p)
+ (semantic-symref-data-debug-last-result))))
+ )
+
+;;;###autoload
+(defun semantic-symref-find-file-references-by-name (name &optional scope)
+ "Find a list of references to NAME in the current project.
+Optional SCOPE specifies which file set to search. Defaults to 'project.
+Refers to `semantic-symref-tool', to determine the reference tool to use
+for the current buffer.
+Returns an object of class `semantic-symref-result'."
+ (interactive "sName: ")
+ (let* ((inst (semantic-symref-instantiate
+ :searchfor name
+ :searchtype 'regexp
+ :searchscope (or scope 'project)
+ :resulttype 'file))
+ (result (semantic-symref-get-result inst)))
+ (prog1
+ (setq semantic-symref-last-result result)
+ (when (interactive-p)
+ (semantic-symref-data-debug-last-result))))
+ )
+
+;;;###autoload
+(defun semantic-symref-find-text (text &optional scope)
+ "Find a list of occurances of TEXT in the current project.
+TEXT is a regexp formatted for use with egrep.
+Optional SCOPE specifies which file set to search. Defaults to 'project.
+Refers to `semantic-symref-tool', to determine the reference tool to use
+for the current buffer.
+Returns an object of class `semantic-symref-result'."
+ (interactive "sEgrep style Regexp: ")
+ (let* ((inst (semantic-symref-instantiate
+ :searchfor text
+ :searchtype 'regexp
+ :searchscope (or scope 'project)
+ :resulttype 'line))
+ (result (semantic-symref-get-result inst)))
+ (prog1
+ (setq semantic-symref-last-result result)
+ (when (interactive-p)
+ (semantic-symref-data-debug-last-result))))
+ )
+
+;;; RESULTS
+;;
+;; The results class and methods provide features for accessing hits.
+(defclass semantic-symref-result ()
+ ((created-by :initarg :created-by
+ :type semantic-symref-tool-baseclass
+ :documentation
+ "Back-pointer to the symref tool creating these results.")
+ (hit-files :initarg :hit-files
+ :type list
+ :documentation
+ "The list of files hit.")
+ (hit-text :initarg :hit-text
+ :type list
+ :documentation
+ "If the result doesn't provide full lines, then fill in hit-text.
+GNU Global does completion search this way.")
+ (hit-lines :initarg :hit-lines
+ :type list
+ :documentation
+ "The list of line hits.
+Each element is a cons cell of the form (LINE . FILENAME).")
+ (hit-tags :initarg :hit-tags
+ :type list
+ :documentation
+ "The list of tags with hits in them.
+Use the `semantic-symref-hit-tags' method to get this list.")
+ )
+ "The results from a symbol reference search.")
+
+(defmethod semantic-symref-result-get-files ((result semantic-symref-result))
+ "Get the list of files from the symref result RESULT."
+ (if (slot-boundp result :hit-files)
+ (oref result hit-files)
+ (let* ((lines (oref result :hit-lines))
+ (files (mapcar (lambda (a) (cdr a)) lines))
+ (ans nil))
+ (setq ans (list (car files))
+ files (cdr files))
+ (dolist (F files)
+ ;; This algorithm for uniqing the file list depends on the
+ ;; tool in question providing all the hits in the same file
+ ;; grouped together.
+ (when (not (string= F (car ans)))
+ (setq ans (cons F ans))))
+ (oset result hit-files (nreverse ans))
+ )
+ ))
+
+(defmethod semantic-symref-result-get-tags ((result semantic-symref-result)
+ &optional open-buffers)
+ "Get the list of tags from the symref result RESULT.
+Optional OPEN-BUFFERS indicates that the buffers that the hits are
+in should remain open after scanning.
+Note: This can be quite slow if most of the hits are not in buffers
+already."
+ (if (and (slot-boundp result :hit-tags) (oref result hit-tags))
+ (oref result hit-tags)
+ ;; Calculate the tags.
+ (let ((lines (oref result :hit-lines))
+ (txt (oref (oref result :created-by) :searchfor))
+ (searchtype (oref (oref result :created-by) :searchtype))
+ (ans nil)
+ (out nil)
+ (buffs-to-kill nil))
+ (save-excursion
+ (setq
+ ans
+ (mapcar
+ (lambda (hit)
+ (let* ((line (car hit))
+ (file (cdr hit))
+ (buff (get-file-buffer file))
+ (tag nil)
+ )
+ (cond
+ ;; We have a buffer already. Check it out.
+ (buff
+ (set-buffer buff))
+
+ ;; We have a table, but it needs a refresh.
+ ;; This means we should load in that buffer.
+ (t
+ (let ((kbuff
+ (if open-buffers
+ ;; Even if we keep the buffers open, don't
+ ;; let EDE ask lots of questions.
+ (let ((ede-auto-add-method 'never))
+ (find-file-noselect file t))
+ ;; When not keeping the buffers open, then
+ ;; don't setup all the fancy froo-froo features
+ ;; either.
+ (semantic-find-file-noselect file t))))
+ (set-buffer kbuff)
+ (setq buffs-to-kill (cons kbuff buffs-to-kill))
+ (semantic-fetch-tags)
+ ))
+ )
+
+ ;; Too much baggage in goto-line
+ ;; (goto-line line)
+ (goto-char (point-min))
+ (forward-line (1- line))
+
+ ;; Search forward for the matching text
+ (re-search-forward (regexp-quote txt)
+ (point-at-eol)
+ t)
+
+ (setq tag (semantic-current-tag))
+
+ ;; If we are searching for a tag, but bound the tag we are looking
+ ;; for, see if it resides in some other parent tag.
+ ;;
+ ;; If there is no parent tag, then we still need to hang the
originator
+ ;; in our list.
+ (when (and (eq searchtype 'symbol)
+ (string= (semantic-tag-name tag) txt))
+ (setq tag (or (semantic-current-tag-parent) tag)))
+
+ ;; Copy the tag, which adds a :filename property.
+ (when tag
+ (setq tag (semantic-tag-copy tag nil t))
+ ;; Ad this hit to the tag.
+ (semantic--tag-put-property tag :hit (list line)))
+ tag))
+ lines)))
+ ;; Kill off dead buffers, unless we were requested to leave them open.
+ (when (not open-buffers)
+ (mapc 'kill-buffer buffs-to-kill))
+ ;; Strip out duplicates.
+ (dolist (T ans)
+ (if (and T (not (semantic-equivalent-tag-p (car out) T)))
+ (setq out (cons T out))
+ (when T
+ ;; Else, add this line into the existing list of lines.
+ (let ((lines (append (semantic--tag-get-property (car out) :hit)
+ (semantic--tag-get-property T :hit))))
+ (semantic--tag-put-property (car out) :hit lines)))
+ ))
+ ;; Out is reversed... twice
+ (oset result :hit-tags (nreverse out)))))
+
+;;; SYMREF TOOLS
+;;
+;; The base symref tool provides something to hang new tools off of
+;; for finding symbol references.
+(defclass semantic-symref-tool-baseclass ()
+ ((searchfor :initarg :searchfor
+ :type string
+ :documentation "The thing to search for.")
+ (searchtype :initarg :searchtype
+ :type symbol
+ :documentation "The type of search to do.
+Values could be `symbol, `regexp, 'tagname, or 'completion.")
+ (searchscope :initarg :searchscope
+ :type symbol
+ :documentation
+ "The scope to search for.
+Can be 'project, 'target, or 'file.")
+ (resulttype :initarg :resulttype
+ :type symbol
+ :documentation
+ "The kind of search results desired.
+Can be 'line, 'file, or 'tag.
+The type of result can be converted from 'line to 'file, or 'line to 'tag,
+but not from 'file to 'line or 'tag.")
+ )
+ "Baseclass for all symbol references tools.
+A symbol reference tool supplies functionality to identify the locations of
+where different symbols are used.
+
+Subclasses should be named `semantic-symref-tool-NAME', where
+NAME is the name of the tool used in the configuration variable
+`semantic-symref-tool'"
+ :abstract t)
+
+(defmethod semantic-symref-get-result ((tool semantic-symref-tool-baseclass))
+ "Calculate the results of a search based on TOOL.
+The symref TOOL should already contain the search criteria."
+ (let ((answer (semantic-symref-perform-search tool))
+ )
+ (when answer
+ (let ((answersym (if (eq (oref tool :resulttype) 'file)
+ :hit-files
+ (if (stringp (car answer))
+ :hit-text
+ :hit-lines))))
+ (semantic-symref-result (oref tool searchfor)
+ answersym
+ answer
+ :created-by tool))
+ )
+ ))
+
+(defmethod semantic-symref-perform-search ((tool
semantic-symref-tool-baseclass))
+ "Base search for symref tools should throw an error."
+ (error "Symref tool objects must implement
`semantic-symref-perform-search'"))
+
+(defmethod semantic-symref-parse-tool-output ((tool
semantic-symref-tool-baseclass)
+ outputbuffer)
+ "Parse the entire OUTPUTBUFFER of a symref tool.
+Calls the method `semantic-symref-parse-tool-output-one-line' over and
+over until it returns nil."
+ (save-excursion
+ (set-buffer outputbuffer)
+ (goto-char (point-min))
+ (let ((result nil)
+ (hit nil))
+ (while (setq hit (semantic-symref-parse-tool-output-one-line tool))
+ (setq result (cons hit result)))
+ (nreverse result)))
+ )
+
+(defmethod semantic-symref-parse-tool-output-one-line ((tool
semantic-symref-tool-baseclass))
+ "Base tool output parser is not implemented."
+ (error "Symref tool objects must implement
`semantic-symref-parse-tool-output-one-line'"))
+
+(provide 'semantic/symref)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/symref"
+;; End:
+
+;;; semantic/symref.el ends here
Index: cedet/semantic/tag-file.el
===================================================================
RCS file: cedet/semantic/tag-file.el
diff -N cedet/semantic/tag-file.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/tag-file.el 28 Sep 2009 15:15:09 -0000 1.2
@@ -0,0 +1,220 @@
+;;; semantic/tag-file.el --- Routines that find files based on tags.
+
+;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
+;;; 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; A tag, by itself, can have representations in several files.
+;; These routines will find those files.
+
+(require 'semantic/tag)
+
+(defvar ede-minor-mode)
+(declare-function semanticdb-table-child-p "semantic/db")
+(declare-function semanticdb-get-buffer "semantic/db")
+(declare-function semantic-dependency-find-file-on-path "semantic/dep")
+(declare-function ede-toplevel "ede/files")
+
+;;; Code:
+
+;;; Location a TAG came from.
+;;
+;;;###autoload
+(define-overloadable-function semantic-go-to-tag (tag &optional parent)
+ "Go to the location of TAG.
+TAG may be a stripped element, in which case PARENT specifies a
+parent tag that has position information.
+PARENT can also be a `semanticdb-table' object."
+ (:override
+ (save-match-data
+ (cond ((semantic-tag-in-buffer-p tag)
+ ;; We have a linked tag, go to that buffer.
+ (set-buffer (semantic-tag-buffer tag)))
+ ((semantic-tag-file-name tag)
+ ;; If it didn't have a buffer, but does have a file
+ ;; name, then we need to get to that file so the tag
+ ;; location is made accurate.
+ (set-buffer (find-file-noselect (semantic-tag-file-name tag))))
+ ((and parent (semantic-tag-p parent) (semantic-tag-in-buffer-p
parent))
+ ;; The tag had nothing useful, but we have a parent with
+ ;; a buffer, then go there.
+ (set-buffer (semantic-tag-buffer parent)))
+ ((and parent (semantic-tag-p parent) (semantic-tag-file-name parent))
+ ;; Tag had nothing, and the parent only has a file-name, then
+ ;; find that file, and switch to that buffer.
+ (set-buffer (find-file-noselect (semantic-tag-file-name parent))))
+ ((and parent (featurep 'semantic/db)
+ (semanticdb-table-child-p parent))
+ (set-buffer (semanticdb-get-buffer parent)))
+ (t
+ ;; Well, just assume things are in the current buffer.
+ nil
+ )))
+ ;; We should be in the correct buffer now, try and figure out
+ ;; where the tag is.
+ (cond ((semantic-tag-with-position-p tag)
+ ;; If it's a number, go there
+ (goto-char (semantic-tag-start tag)))
+ ((semantic-tag-with-position-p parent)
+ ;; Otherwise, it's a trimmed vector, such as a parameter,
+ ;; or a structure part. If there is a parent, we can use it
+ ;; as a bounds for searching.
+ (goto-char (semantic-tag-start parent))
+ ;; Here we make an assumption that the text returned by
+ ;; the parser and concocted by us actually exists
+ ;; in the buffer.
+ (re-search-forward (semantic-tag-name tag)
+ (semantic-tag-end parent)
+ t))
+ ((semantic-tag-get-attribute tag :line)
+ ;; The tag has a line number in it. Go there.
+ (goto-char (point-min))
+ (forward-line (1- (semantic-tag-get-attribute tag :line))))
+ ((and (semantic-tag-p parent) (semantic-tag-get-attribute parent
:line))
+ ;; The tag has a line number in it. Go there.
+ (goto-char (point-min))
+ (forward-line (1- (semantic-tag-get-attribute parent :line)))
+ (re-search-forward (semantic-tag-name tag) nil t))
+ (t
+ ;; Take a guess that the tag has a unique name, and just
+ ;; search for it from the beginning of the buffer.
+ (goto-char (point-min))
+ (re-search-forward (semantic-tag-name tag) nil t)))
+ )
+ )
+
+(make-obsolete-overload 'semantic-find-nonterminal
+ 'semantic-go-to-tag)
+
+;;; Dependencies
+;;
+;; A tag which is of type 'include specifies a dependency.
+;; Dependencies usually represent a file of some sort.
+;; Find the file described by a dependency.
+
+;;;###autoload
+(define-overloadable-function semantic-dependency-tag-file (&optional tag)
+ "Find the filename represented from TAG.
+Depends on `semantic-dependency-include-path' for searching. Always searches
+`.' first, then searches additional paths."
+ (or tag (setq tag (car (semantic-find-tag-by-overlay nil))))
+ (unless (semantic-tag-of-class-p tag 'include)
+ (signal 'wrong-type-argument (list tag 'include)))
+ (save-excursion
+ (let ((result nil)
+ (default-directory default-directory)
+ (edefind nil)
+ (tag-fname nil))
+ (cond ((semantic-tag-in-buffer-p tag)
+ ;; If the tag has an overlay and buffer associated with it,
+ ;; switch to that buffer so that we get the right override metohds.
+ (set-buffer (semantic-tag-buffer tag)))
+ ((semantic-tag-file-name tag)
+ ;; If it didn't have a buffer, but does have a file
+ ;; name, then we need to get to that file so the tag
+ ;; location is made accurate.
+ ;;(set-buffer (find-file-noselect (semantic-tag-file-name tag)))
+ ;;
+ ;; 2/3/08
+ ;; The above causes unnecessary buffer loads all over the place.
Ick!
+ ;; All we really need is for 'default-directory' to be set
correctly.
+ (setq default-directory (file-name-directory
(semantic-tag-file-name tag)))
+ ))
+ ;; Setup the filename represented by this include
+ (setq tag-fname (semantic-tag-include-filename tag))
+
+ ;; First, see if this file exists in the current EDE project
+ (if (and (fboundp 'ede-expand-filename) ede-minor-mode
+ (setq edefind
+ (condition-case nil
+ (let ((proj (ede-toplevel)))
+ (when proj
+ (ede-expand-filename proj tag-fname)))
+ (error nil))))
+ (setq result edefind))
+ (if (not result)
+ (setq result
+ ;; I don't have a plan for refreshing tags with a dependency
+ ;; stuck on them somehow. I'm thinking that putting a cache
+ ;; onto the dependancy finding with a hash table might be best.
+ ;;(if (semantic--tag-get-property tag 'dependency-file)
+ ;; (semantic--tag-get-property tag 'dependency-file)
+ (:override
+ (save-excursion
+ (require 'semantic/dep)
+ (semantic-dependency-find-file-on-path
+ tag-fname (semantic-tag-include-system-p tag))))
+ ;; )
+ ))
+ (if (stringp result)
+ (progn
+ (semantic--tag-put-property tag 'dependency-file result)
+ result)
+ ;; @todo: Do something to make this get flushed w/
+ ;; when the path is changed.
+ ;; @undo: Just eliminate
+ ;; (semantic--tag-put-property tag 'dependency-file 'none)
+ nil)
+ )))
+
+(make-obsolete-overload 'semantic-find-dependency
+ 'semantic-dependency-tag-file)
+
+;;; PROTOTYPE FILE
+;;
+;; In C, a function in the .c file often has a representation in a
+;; corresponding .h file. This routine attempts to find the
+;; prototype file a given source file would be associated with.
+;; This can be used by prototype manager programs.
+(define-overloadable-function semantic-prototype-file (buffer)
+ "Return a file in which prototypes belonging to BUFFER should be placed.
+Default behavior (if not overridden) looks for a token specifying the
+prototype file, or the existence of an EDE variable indicating which
+file prototypes belong in."
+ (:override
+ ;; Perform some default behaviors
+ (if (and (fboundp 'ede-header-file) ede-minor-mode)
+ (save-excursion
+ (set-buffer buffer)
+ (ede-header-file))
+ ;; No EDE options for a quick answer. Search.
+ (save-excursion
+ (set-buffer buffer)
+ (if (re-search-forward "::Header:: \\([a-zA-Z0-9.]+\\)" nil t)
+ (match-string 1))))))
+
+(semantic-alias-obsolete 'semantic-find-nonterminal
+ 'semantic-go-to-tag)
+
+(semantic-alias-obsolete 'semantic-find-dependency
+ 'semantic-dependency-tag-file)
+
+
+(provide 'semantic/tag-file)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/tag-file"
+;; End:
+
+;;; semantic/tag-file.el ends here
Index: cedet/semantic/tag-ls.el
===================================================================
RCS file: cedet/semantic/tag-ls.el
diff -N cedet/semantic/tag-ls.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/tag-ls.el 28 Sep 2009 15:15:09 -0000 1.2
@@ -0,0 +1,256 @@
+;;; semantic/tag-ls.el --- Language Specific override functions for tags
+
+;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; There are some features of tags that are too langauge dependent to
+;; put in the core `semantic-tag' functionality. For instance, the
+;; protection of a tag (as specified by UML) could be almost anything.
+;; In Java, it is a type specifier. In C, there is a label. This
+;; informatin can be derived, and thus should not be stored in the tag
+;; itself. These are the functions that languages can use to derive
+;; the information.
+
+(require 'semantic)
+
+;;; Code:
+
+;;; UML features:
+;;
+;; UML can represent several types of features of a tag
+;; such as the `protection' of a symbol, or if it is abstract,
+;; leaf, etc. Learn about UML to catch onto the lingo.
+
+(define-overloadable-function semantic-tag-calculate-parent (tag)
+ "Attempt to calculate the parent of TAG.
+The default behavior (if not overriden with `tag-calculate-parent')
+is to search a buffer found with TAG, and if externally defined,
+search locally, then semanticdb for that tag (when enabled.)")
+
+(defun semantic-tag-calculate-parent-default (tag)
+ "Attempt to calculate the parent of TAG."
+ (when (semantic-tag-in-buffer-p tag)
+ (save-excursion
+ (set-buffer (semantic-tag-buffer tag))
+ (save-excursion
+ (goto-char (semantic-tag-start tag))
+ (semantic-current-tag-parent))
+ )))
+
+(define-overloadable-function semantic-tag-protection (tag &optional parent)
+ "Return protection information about TAG with optional PARENT.
+This function returns on of the following symbols:
+ nil - No special protection. Language dependent.
+ 'public - Anyone can access this TAG.
+ 'private - Only methods in the local scope can access TAG.
+ 'protected - Like private for outside scopes, like public for child
+ classes.
+Some languages may choose to provide additional return symbols specific
+to themselves. Use of this function should allow for this.
+
+The default behavior (if not overridden with `tag-protection'
+is to return a symbol based on type modifiers."
+ (and (not parent)
+ (semantic-tag-overlay tag)
+ (semantic-tag-in-buffer-p tag)
+ (setq parent (semantic-tag-calculate-parent tag)))
+ (:override))
+
+(make-obsolete-overload 'semantic-nonterminal-protection
+ 'semantic-tag-protection)
+
+(defun semantic-tag-protection-default (tag &optional parent)
+ "Return the protection of TAG as a child of PARENT default action.
+See `semantic-tag-protection'."
+ (let ((mods (semantic-tag-modifiers tag))
+ (prot nil))
+ (while (and (not prot) mods)
+ (if (stringp (car mods))
+ (let ((s (car mods)))
+ (setq prot
+ ;; A few silly defaults to get things started.
+ (cond ((or (string= s "public")
+ (string= s "extern")
+ (string= s "export"))
+ 'public)
+ ((string= s "private")
+ 'private)
+ ((string= s "protected")
+ 'protected)))))
+ (setq mods (cdr mods)))
+ prot))
+
+(defun semantic-tag-protected-p (tag protection &optional parent)
+ "Non-nil if TAG is is protected.
+PROTECTION is a symbol which can be returned by the method
+`semantic-tag-protection'.
+PARENT is the parent data type which contains TAG.
+
+For these PROTECTIONs, true is returned if TAG is:
address@hidden @asis
address@hidden nil
+ Always true
address@hidden private
+ True if nil.
address@hidden protected
+ True if private or nil.
address@hidden public
+ True if private, protected, or nil.
address@hidden table"
+ (if (null protection)
+ t
+ (let ((tagpro (semantic-tag-protection tag parent)))
+ (or (and (eq protection 'private)
+ (null tagpro))
+ (and (eq protection 'protected)
+ (or (null tagpro)
+ (eq tagpro 'private)))
+ (and (eq protection 'public)
+ (not (eq tagpro 'public)))))
+ ))
+
+(define-overloadable-function semantic-tag-abstract-p (tag &optional parent)
+ "Return non nil if TAG is abstract.
+Optional PARENT is the parent tag of TAG.
+In UML, abstract methods and classes have special meaning and behavior
+in how methods are overridden. In UML, abstract methods are italicized.
+
+The default behavior (if not overridden with `tag-abstract-p'
+is to return true if `abstract' is in the type modifiers.")
+
+(make-obsolete-overload 'semantic-nonterminal-abstract
+ 'semantic-tag-abstract-p)
+
+(defun semantic-tag-abstract-p-default (tag &optional parent)
+ "Return non-nil if TAG is abstract as a child of PARENT default action.
+See `semantic-tag-abstract-p'."
+ (let ((mods (semantic-tag-modifiers tag))
+ (abs nil))
+ (while (and (not abs) mods)
+ (if (stringp (car mods))
+ (setq abs (or (string= (car mods) "abstract")
+ (string= (car mods) "virtual"))))
+ (setq mods (cdr mods)))
+ abs))
+
+(define-overloadable-function semantic-tag-leaf-p (tag &optional parent)
+ "Return non nil if TAG is leaf.
+Optional PARENT is the parent tag of TAG.
+In UML, leaf methods and classes have special meaning and behavior.
+
+The default behavior (if not overridden with `tag-leaf-p'
+is to return true if `leaf' is in the type modifiers.")
+
+(make-obsolete-overload 'semantic-nonterminal-leaf
+ 'semantic-tag-leaf-p)
+
+(defun semantic-tag-leaf-p-default (tag &optional parent)
+ "Return non-nil if TAG is leaf as a child of PARENT default action.
+See `semantic-tag-leaf-p'."
+ (let ((mods (semantic-tag-modifiers tag))
+ (leaf nil))
+ (while (and (not leaf) mods)
+ (if (stringp (car mods))
+ ;; Use java FINAL as example default. There is none
+ ;; for C/C++
+ (setq leaf (string= (car mods) "final")))
+ (setq mods (cdr mods)))
+ leaf))
+
+(define-overloadable-function semantic-tag-static-p (tag &optional parent)
+ "Return non nil if TAG is static.
+Optional PARENT is the parent tag of TAG.
+In UML, static methods and attributes mean that they are allocated
+in the parent class, and are not instance specific.
+UML notation specifies that STATIC entries are underlined.")
+
+(defun semantic-tag-static-p-default (tag &optional parent)
+ "Return non-nil if TAG is static as a child of PARENT default action.
+See `semantic-tag-static-p'."
+ (let ((mods (semantic-tag-modifiers tag))
+ (static nil))
+ (while (and (not static) mods)
+ (if (stringp (car mods))
+ (setq static (string= (car mods) "static")))
+ (setq mods (cdr mods)))
+ static))
+
+;;;###autoload
+(define-overloadable-function semantic-tag-prototype-p (tag)
+ "Return non nil if TAG is a prototype.
+For some laguages, such as C, a prototype is a declaration of
+something without an implementation."
+ )
+
+(defun semantic-tag-prototype-p-default (tag)
+ "Non-nil if TAG is a prototype."
+ (let ((p (semantic-tag-get-attribute tag :prototype-flag)))
+ (cond
+ ;; Trust the parser author.
+ (p p)
+ ;; Empty types might be a prototype.
+ ;; @todo - make this better.
+ ((eq (semantic-tag-class tag) 'type)
+ (not (semantic-tag-type-members tag)))
+ ;; No other heuristics.
+ (t nil))
+ ))
+
+;;; FULL NAMES
+;;
+;; For programmer convenience, a full name is not specified in source
+;; code. Instead some abbreviation is made, and the local environment
+;; will contain the info needed to determine the full name.
+
+(define-overloadable-function semantic-tag-full-name (tag &optional
stream-or-buffer)
+ "Return the fully qualified name of TAG in the package hierarchy.
+STREAM-OR-BUFFER can be anything convertable by `semantic-something-to-stream',
+but must be a toplevel semantic tag stream that contains TAG.
+A Package Hierarchy is defined in UML by the way classes and methods
+are organized on disk. Some language use this concept such that a
+class can be accessed via it's fully qualified name, (such as Java.)
+Other languages qualify names within a Namespace (such as C++) which
+result in a different package like structure. Languages which do not
+override this function with `tag-full-name' will use
+`semantic-tag-name'. Override functions only need to handle
+STREAM-OR-BUFFER with a tag stream value, or nil."
+ (let ((stream (semantic-something-to-tag-table
+ (or stream-or-buffer tag))))
+ (:override-with-args (tag stream))))
+
+(make-obsolete-overload 'semantic-nonterminal-full-name
+ 'semantic-tag-full-name)
+
+(defun semantic-tag-full-name-default (tag stream)
+ "Default method for `semantic-tag-full-name'.
+Return the name of TAG found in the toplevel STREAM."
+ (semantic-tag-name tag))
+
+(provide 'semantic/tag-ls)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/tag-ls"
+;; End:
+
+;;; semantic/tag-ls.el ends here
Index: cedet/semantic/tag-write.el
===================================================================
RCS file: cedet/semantic/tag-write.el
diff -N cedet/semantic/tag-write.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/tag-write.el 28 Sep 2009 15:15:09 -0000 1.2
@@ -0,0 +1,179 @@
+;;; semantic/tag-write.el --- Write tags to a text stream
+
+;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Routine for writing out a list of tags to a text stream.
+;;
+;; These routines will be used by semanticdb to output a tag list into
+;; a text stream to be saved to a file. Ideally, you could use tag streams
+;; to share tags between processes as well.
+;;
+;; As a bonus, these routines will also validate the tag structure, and make
sure
+;; that they conform to good semantic tag hygene.
+;;
+
+(require 'semantic)
+
+;;; Code:
+(defun semantic-tag-write-one-tag (tag &optional indent)
+ "Write a single tag TAG to standard out.
+INDENT is the amount of indentation to use for this tag."
+ (when (not (semantic-tag-p tag))
+ (signal 'wrong-type-argument (list tag 'semantic-tag-p)))
+ (when (not indent) (setq indent 0))
+ ;(princ (make-string indent ? ))
+ (princ "(\"")
+ ;; Base parts
+ (let ((name (semantic-tag-name tag))
+ (class (semantic-tag-class tag)))
+ (princ name)
+ (princ "\" ")
+ (princ (symbol-name class))
+ )
+ (let ((attr (semantic-tag-attributes tag))
+ )
+ ;; Attributes
+ (cond ((not attr)
+ (princ " nil"))
+
+ ((= (length attr) 2) ;; One item
+ (princ " (")
+ (semantic-tag-write-one-attribute attr indent)
+ (princ ")")
+ )
+ (t
+ ;; More than one tag.
+ (princ "\n")
+ (princ (make-string (+ indent 3) ? ))
+ (princ "(")
+ (while attr
+ (semantic-tag-write-one-attribute attr (+ indent 4))
+ (setq attr (cdr (cdr attr)))
+ (when attr
+ (princ "\n")
+ (princ (make-string (+ indent 4) ? )))
+ )
+ (princ ")\n")
+ (princ (make-string (+ indent 3) ? ))
+ ))
+ ;; Properties - for now, always nil.
+ (let ((rs (semantic--tag-get-property tag 'reparse-symbol)))
+ (if (not rs)
+ (princ " nil")
+ ;; Else, put in the property list.
+ (princ " (reparse-symbol ")
+ (princ (symbol-name rs))
+ (princ ")"))
+ ))
+ ;; Overlay
+ (if (semantic-tag-with-position-p tag)
+ (let ((bounds (semantic-tag-bounds tag)))
+ (princ " ")
+ (prin1 (apply 'vector bounds))
+ )
+ (princ " nil"))
+ ;; End it.
+ (princ ")")
+ )
+
+(defun semantic-tag-write-tag-list (tlist &optional indent dontaddnewline)
+ "Write the tag list TLIST to the current stream.
+INDENT indicates the current indentation level.
+If optional DONTADDNEWLINE is non-nil, then don't add a newline."
+ (if (not indent)
+ (setq indent 0)
+ (unless dontaddnewline
+ ;; Assume cursor at end of current line. Add a CR, and make the list.
+ (princ "\n")
+ (princ (make-string indent ? ))))
+ (princ "( ")
+ (while tlist
+ (if (semantic-tag-p (car tlist))
+ (semantic-tag-write-one-tag (car tlist) (+ indent 2))
+ ;; If we don't have a tag in the tag list, use the below hack, and hope
+ ;; it doesn't contain anything bad. If we find something bad, go back
here
+ ;; and start extending what's expected here.
+ (princ (format "%S" (car tlist))))
+ (setq tlist (cdr tlist))
+ (when tlist
+ (princ "\n")
+ (princ (make-string (+ indent 2) ? )))
+ )
+ (princ ")")
+ (princ (make-string indent ? ))
+ )
+
+
+;; Writing out random stuff.
+(defun semantic-tag-write-one-attribute (attrs indent)
+ "Write out one attribute from the head of the list of attributes ATTRS.
+INDENT is the current amount of indentation."
+ (when (not attrs) (signal 'wrong-type-argument (list 'listp attrs)))
+ (when (not (symbolp (car attrs))) (error "Bad Attribute List in tag"))
+
+ (princ (symbol-name (car attrs)))
+ (princ " ")
+ (semantic-tag-write-one-value (car (cdr attrs)) indent)
+ )
+
+(defun semantic-tag-write-one-value (value indent)
+ "Write out a VALUE for something in a tag.
+INDENT is the current tag indentation.
+Items that are long lists of tags may need their own line."
+ (cond
+ ;; Another tag.
+ ((semantic-tag-p value)
+ (semantic-tag-write-one-tag value (+ indent 2)))
+ ;; A list of more tags
+ ((and (listp value) (semantic-tag-p (car value)))
+ (semantic-tag-write-tag-list value (+ indent 2))
+ )
+ ;; Some arbitrary data.
+ (t
+ (let ((str (format "%S" value)))
+ ;; Protect against odd data types in tags.
+ (if (= (aref str 0) ?#)
+ (progn
+ (princ "nil")
+ (message "Warning: Value %s not writable in tag." str))
+ (princ str)))))
+ )
+;;; EIEIO USAGE
+;;;###autoload
+(defun semantic-tag-write-list-slot-value (value)
+ "Write out the VALUE of a slot for EIEIO.
+The VALUE is a list of tags."
+ (if (not value)
+ (princ "nil")
+ (princ "\n '")
+ (semantic-tag-write-tag-list value 10 t)
+ ))
+
+(provide 'semantic/tag-write)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/tag-write"
+;; End:
+
+;;; semantic/tag-write.el ends here
Index: cedet/semantic/tag.el
===================================================================
RCS file: cedet/semantic/tag.el
diff -N cedet/semantic/tag.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/tag.el 28 Sep 2009 15:15:09 -0000 1.2
@@ -0,0 +1,1365 @@
+;;; semantic/tag.el --- tag creation and access
+
+;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
+;;; 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; I. The core production of semantic is the list of tags produced by the
+;; different parsers. This file provides 3 APIs related to tag access:
+;;
+;; 1) Primitive Tag Access
+;; There is a set of common features to all tags. These access
+;; functions can get these values.
+;; 2) Standard Tag Access
+;; A Standard Tag should be produced by most traditional languages
+;; with standard styles common to typed object oriented languages.
+;; These functions can access these data elements from a tag.
+;; 3) Generic Tag Access
+;; Access to tag structure in a more direct way.
+;; ** May not be forward compatible.
+;;
+;; II. There is also an API for tag creation. Use `semantic-tag' to create
+;; a new tag.
+;;
+;; III. Tag Comparison. Allows explicit or comparitive tests to see
+;; if two tags are the same.
+
+;;; Code:
+;;
+
+;; Keep this only so long as we have obsolete fcns.
+(require 'semantic/fw)
+(require 'semantic/lex)
+
+(declare-function semantic-analyze-split-name "semantic/analyze/fcn")
+(declare-function semantic-fetch-tags "semantic")
+(declare-function semantic-clear-toplevel-cache "semantic")
+
+(defconst semantic-tag-version "2.0pre7"
+ "Version string of semantic tags made with this code.")
+
+(defconst semantic-tag-incompatible-version "1.0"
+ "Version string of semantic tags which are not currently compatible.
+These old style tags may be loaded from a file with semantic db.
+In this case, we must flush the old tags and start over.")
+
+;;; Primitive Tag access system:
+;;
+;; Raw tags in semantic are lists of 5 elements:
+;;
+;; (NAME CLASS ATTRIBUTES PROPERTIES OVERLAY)
+;;
+;; Where:
+;;
+;; - NAME is a string that represents the tag name.
+;;
+;; - CLASS is a symbol that represent the class of the tag (for
+;; example, usual classes are `type', `function', `variable',
+;; `include', `package', `code').
+;;
+;; - ATTRIBUTES is a public list of attributes that describes
+;; language data represented by the tag (for example, a variable
+;; can have a `:constant-flag' attribute, a function an `:arguments'
+;; attribute, etc.).
+;;
+;; - PROPERTIES is a private list of properties used internally.
+;;
+;; - OVERLAY represent the location of data described by the tag.
+;;
+
+(defsubst semantic-tag-name (tag)
+ "Return the name of TAG.
+For functions, variables, classes, typedefs, etc., this is the identifier
+that is being defined. For tags without an obvious associated name, this
+may be the statement type, e.g., this may return @code{print} for python's
+print statement."
+ (car tag))
+
+(defsubst semantic-tag-class (tag)
+ "Return the class of TAG.
+That is, the symbol 'variable, 'function, 'type, or other.
+There is no limit to the symbols that may represent the class of a tag.
+Each parser generates tags with classes defined by it.
+
+For functional languages, typical tag classes are:
+
address@hidden @code
address@hidden type
+Data types, named map for a memory block.
address@hidden function
+A function or method, or named execution location.
address@hidden variable
+A variable, or named storage for data.
address@hidden include
+Statement that represents a file from which more tags can be found.
address@hidden package
+Statement that declairs this file's package name.
address@hidden code
+Code that has not name or binding to any other symbol, such as in a script.
address@hidden table
+"
+ (nth 1 tag))
+
+(defsubst semantic-tag-attributes (tag)
+ "Return the list of public attributes of TAG.
+That is a property list: (ATTRIBUTE-1 VALUE-1 ATTRIBUTE-2 VALUE-2...)."
+ (nth 2 tag))
+
+(defsubst semantic-tag-properties (tag)
+ "Return the list of private properties of TAG.
+That is a property list: (PROPERTY-1 VALUE-1 PROPERTY-2 VALUE-2...)."
+ (nth 3 tag))
+
+(defsubst semantic-tag-overlay (tag)
+ "Return the OVERLAY part of TAG.
+That is, an overlay or an unloaded buffer representation.
+This function can also return an array of the form [ START END ].
+This occurs for tags that are not currently linked into a buffer."
+ (nth 4 tag))
+
+(defsubst semantic--tag-overlay-cdr (tag)
+ "Return the cons cell whose car is the OVERLAY part of TAG.
+That function is for internal use only."
+ (nthcdr 4 tag))
+
+(defsubst semantic--tag-set-overlay (tag overlay)
+ "Set the overlay part of TAG with OVERLAY.
+That function is for internal use only."
+ (setcar (semantic--tag-overlay-cdr tag) overlay))
+
+(defsubst semantic-tag-start (tag)
+ "Return the start location of TAG."
+ (let ((o (semantic-tag-overlay tag)))
+ (if (semantic-overlay-p o)
+ (semantic-overlay-start o)
+ (aref o 0))))
+
+(defsubst semantic-tag-end (tag)
+ "Return the end location of TAG."
+ (let ((o (semantic-tag-overlay tag)))
+ (if (semantic-overlay-p o)
+ (semantic-overlay-end o)
+ (aref o 1))))
+
+(defsubst semantic-tag-bounds (tag)
+ "Return the location (START END) of data TAG describes."
+ (list (semantic-tag-start tag)
+ (semantic-tag-end tag)))
+
+(defun semantic-tag-set-bounds (tag start end)
+ "In TAG, set the START and END location of data it describes."
+ (let ((o (semantic-tag-overlay tag)))
+ (if (semantic-overlay-p o)
+ (semantic-overlay-move o start end)
+ (semantic--tag-set-overlay tag (vector start end)))))
+
+(defun semantic-tag-in-buffer-p (tag)
+ "Return the buffer TAG resides in IFF tag is already in a buffer.
+If a tag is not in a buffer, return nil."
+ (let ((o (semantic-tag-overlay tag)))
+ ;; TAG is currently linked to a buffer, return it.
+ (when (and (semantic-overlay-p o)
+ (semantic-overlay-live-p o))
+ (semantic-overlay-buffer o))))
+
+(defsubst semantic--tag-get-property (tag property)
+ "From TAG, extract the value of PROPERTY.
+Return the value found, or nil if PROPERTY is not one of the
+properties of TAG.
+That function is for internal use only."
+ (plist-get (semantic-tag-properties tag) property))
+
+(defun semantic-tag-buffer (tag)
+ "Return the buffer TAG resides in.
+If TAG has an originating file, read that file into a (maybe new)
+buffer, and return it.
+Return nil if there is no buffer for this tag."
+ (let ((buff (semantic-tag-in-buffer-p tag)))
+ (if buff
+ buff
+ ;; TAG has an originating file, read that file into a buffer, and
+ ;; return it.
+ (if (semantic--tag-get-property tag :filename)
+ (save-match-data
+ (find-file-noselect (semantic--tag-get-property tag :filename)))
+ ;; TAG is not in Emacs right now, no buffer is available.
+ ))))
+
+(defun semantic-tag-mode (&optional tag)
+ "Return the major mode active for TAG.
+TAG defaults to the tag at point in current buffer.
+If TAG has a :mode property return it.
+If point is inside TAG bounds, return the major mode active at point.
+Return the major mode active at beginning of TAG otherwise.
+See also the function `semantic-ctxt-current-mode'."
+ (or tag (setq tag (semantic-current-tag)))
+ (or (semantic--tag-get-property tag :mode)
+ (let ((buffer (semantic-tag-buffer tag))
+ (start (semantic-tag-start tag))
+ (end (semantic-tag-end tag)))
+ (save-excursion
+ (and buffer (set-buffer buffer))
+ ;; Unless point is inside TAG bounds, move it to the
+ ;; beginning of TAG.
+ (or (and (>= (point) start) (< (point) end))
+ (goto-char start))
+ (semantic-ctxt-current-mode)))))
+
+(defsubst semantic--tag-attributes-cdr (tag)
+ "Return the cons cell whose car is the ATTRIBUTES part of TAG.
+That function is for internal use only."
+ (nthcdr 2 tag))
+
+(defsubst semantic-tag-put-attribute (tag attribute value)
+ "Change value in TAG of ATTRIBUTE to VALUE.
+If ATTRIBUTE already exists, its value is set to VALUE, otherwise the
+new ATTRIBUTE VALUE pair is added.
+Return TAG.
+Use this function in a parser when not all attributes are known at the
+same time."
+ (let* ((plist-cdr (semantic--tag-attributes-cdr tag)))
+ (when (consp plist-cdr)
+ (setcar plist-cdr
+ (semantic-tag-make-plist
+ (plist-put (car plist-cdr) attribute value))))
+ tag))
+
+(defun semantic-tag-put-attribute-no-side-effect (tag attribute value)
+ "Change value in TAG of ATTRIBUTE to VALUE without side effects.
+All cons cells in the attribute list are replicated so that there
+are no side effects if TAG is in shared lists.
+If ATTRIBUTE already exists, its value is set to VALUE, otherwise the
+new ATTRIBUTE VALUE pair is added.
+Return TAG."
+ (let* ((plist-cdr (semantic--tag-attributes-cdr tag)))
+ (when (consp plist-cdr)
+ (setcar plist-cdr
+ (semantic-tag-make-plist
+ (plist-put (copy-sequence (car plist-cdr))
+ attribute value))))
+ tag))
+
+(defsubst semantic-tag-get-attribute (tag attribute)
+ "From TAG, return the value of ATTRIBUTE.
+ATTRIBUTE is a symbol whose specification value to get.
+Return the value found, or nil if ATTRIBUTE is not one of the
+attributes of TAG."
+ (plist-get (semantic-tag-attributes tag) attribute))
+
+;; These functions are for internal use only!
+(defsubst semantic--tag-properties-cdr (tag)
+ "Return the cons cell whose car is the PROPERTIES part of TAG.
+That function is for internal use only."
+ (nthcdr 3 tag))
+
+(defun semantic--tag-put-property (tag property value)
+ "Change value in TAG of PROPERTY to VALUE.
+If PROPERTY already exists, its value is set to VALUE, otherwise the
+new PROPERTY VALUE pair is added.
+Return TAG.
+That function is for internal use only."
+ (let* ((plist-cdr (semantic--tag-properties-cdr tag)))
+ (when (consp plist-cdr)
+ (setcar plist-cdr
+ (semantic-tag-make-plist
+ (plist-put (car plist-cdr) property value))))
+ tag))
+
+(defun semantic--tag-put-property-no-side-effect (tag property value)
+ "Change value in TAG of PROPERTY to VALUE without side effects.
+All cons cells in the property list are replicated so that there
+are no side effects if TAG is in shared lists.
+If PROPERTY already exists, its value is set to VALUE, otherwise the
+new PROPERTY VALUE pair is added.
+Return TAG.
+That function is for internal use only."
+ (let* ((plist-cdr (semantic--tag-properties-cdr tag)))
+ (when (consp plist-cdr)
+ (setcar plist-cdr
+ (semantic-tag-make-plist
+ (plist-put (copy-sequence (car plist-cdr))
+ property value))))
+ tag))
+
+(defun semantic-tag-file-name (tag)
+ "Return the name of the file from which TAG originated.
+Return nil if that information can't be obtained.
+If TAG is from a loaded buffer, then that buffer's filename is used.
+If TAG is unlinked, but has a :filename property, then that is used."
+ (let ((buffer (semantic-tag-in-buffer-p tag)))
+ (if buffer
+ (buffer-file-name buffer)
+ (semantic--tag-get-property tag :filename))))
+
+;;; Tag tests and comparisons.
+(defsubst semantic-tag-p (tag)
+ "Return non-nil if TAG is most likely a semantic tag."
+ (condition-case nil
+ (and (consp tag)
+ (stringp (car tag)) ; NAME
+ (symbolp (nth 1 tag)) (nth 1 tag) ; TAG-CLASS
+ (listp (nth 2 tag)) ; ATTRIBUTES
+ (listp (nth 3 tag)) ; PROPERTIES
+ )
+ ;; If an error occurs, then it most certainly is not a tag.
+ (error nil)))
+
+(defsubst semantic-tag-of-class-p (tag class)
+ "Return non-nil if class of TAG is CLASS."
+ (eq (semantic-tag-class tag) class))
+
+(defsubst semantic-tag-type-members (tag)
+ "Return the members of the type that TAG describes.
+That is the value of the `:members' attribute."
+ (semantic-tag-get-attribute tag :members))
+
+(defsubst semantic-tag-type (tag)
+ "Return the value of the `:type' attribute of TAG.
+For a function it would be the data type of the return value.
+For a variable, it is the storage type of that variable.
+For a data type, the type is the style of datatype, such as
+struct or union."
+ (semantic-tag-get-attribute tag :type))
+
+(defun semantic-tag-with-position-p (tag)
+ "Return non-nil if TAG has positional information."
+ (and (semantic-tag-p tag)
+ (let ((o (semantic-tag-overlay tag)))
+ (or (and (semantic-overlay-p o)
+ (semantic-overlay-live-p o))
+ (arrayp o)))))
+
+(defun semantic-equivalent-tag-p (tag1 tag2)
+ "Compare TAG1 and TAG2 and return non-nil if they are equivalent.
+Use `equal' on elements the name, class, and position.
+Use this function if tags are being copied and regrouped to test
+for if two tags represent the same thing, but may be constructed
+of different cons cells."
+ (and (equal (semantic-tag-name tag1) (semantic-tag-name tag2))
+ (semantic-tag-of-class-p tag1 (semantic-tag-class tag2))
+ (or (and (not (semantic-tag-overlay tag1))
+ (not (semantic-tag-overlay tag2)))
+ (and (semantic-tag-overlay tag1)
+ (semantic-tag-overlay tag2)
+ (equal (semantic-tag-bounds tag1)
+ (semantic-tag-bounds tag2))))))
+
+(defun semantic-tag-similar-p (tag1 tag2 &rest ignorable-attributes)
+ "Test to see if TAG1 and TAG2 are similar.
+Two tags are similar if their name, datatype, and various attributes
+are the same.
+
+Similar tags that have sub-tags such as arg lists or type members,
+are similar w/out checking the sub-list of tags.
+Optional argument IGNORABLE-ATTRIBUTES are attributes to ignore while
comparing similarity."
+ (let* ((A1 (and (equal (semantic-tag-name tag1) (semantic-tag-name tag2))
+ (semantic-tag-of-class-p tag1 (semantic-tag-class tag2))
+ (semantic-tag-of-type-p tag1 (semantic-tag-type tag2))))
+ (attr1 (semantic-tag-attributes tag1))
+ (A2 (= (length attr1) (length (semantic-tag-attributes tag2))))
+ (A3 t)
+ )
+ (when (and (not A2) ignorable-attributes)
+ (setq A2 t))
+ (while (and A2 attr1 A3)
+ (let ((a (car attr1))
+ (v (car (cdr attr1))))
+
+ (cond ((or (eq a :type) ;; already tested above.
+ (memq a ignorable-attributes)) ;; Ignore them...
+ nil)
+
+ ;; Don't test sublists of tags
+ ((and (listp v) (semantic-tag-p (car v)))
+ nil)
+
+ ;; The attributes are not the same?
+ ((not (equal v (semantic-tag-get-attribute tag2 a)))
+ (setq A3 nil))
+ (t
+ nil))
+ )
+ (setq attr1 (cdr (cdr attr1))))
+
+ (and A1 A2 A3)
+ ))
+
+(defun semantic-tag-similar-with-subtags-p (tag1 tag2 &rest
ignorable-attributes)
+ "Test to see if TAG1 and TAG2 are similar.
+Uses `semantic-tag-similar-p' but also recurses through sub-tags, such
+as argument lists and type members.
+Optional argument IGNORABLE-ATTRIBUTES is passed down to
+`semantic-tag-similar-p'."
+ (let ((C1 (semantic-tag-components tag1))
+ (C2 (semantic-tag-components tag2))
+ )
+ (if (or (/= (length C1) (length C2))
+ (not (semantic-tag-similar-p tag1 tag2 ignorable-attributes))
+ )
+ ;; Basic test fails.
+ nil
+ ;; Else, check component lists.
+ (catch 'component-dissimilar
+ (while C1
+
+ (if (not (semantic-tag-similar-with-subtags-p
+ (car C1) (car C2) ignorable-attributes))
+ (throw 'component-dissimilar nil))
+
+ (setq C1 (cdr C1))
+ (setq C2 (cdr C2))
+ )
+ ;; If we made it this far, we are ok.
+ t) )))
+
+
+(defun semantic-tag-of-type-p (tag type)
+ "Compare TAG's type against TYPE. Non nil if equivalent.
+TYPE can be a string, or a tag of class 'type.
+This can be complex since some tags might have a :type that is a tag,
+while other tags might just have a string. This function will also be
+return true of TAG's type is compared directly to the declaration of a
+data type."
+ (let* ((tagtype (semantic-tag-type tag))
+ (tagtypestring (cond ((stringp tagtype)
+ tagtype)
+ ((and (semantic-tag-p tagtype)
+ (semantic-tag-of-class-p tagtype 'type))
+ (semantic-tag-name tagtype))
+ (t "")))
+ (typestring (cond ((stringp type)
+ type)
+ ((and (semantic-tag-p type)
+ (semantic-tag-of-class-p type 'type))
+ (semantic-tag-name type))
+ (t "")))
+ )
+ (and
+ tagtypestring
+ (or
+ ;; Matching strings (input type is string)
+ (and (stringp type)
+ (string= tagtypestring type))
+ ;; Matching strings (tag type is string)
+ (and (stringp tagtype)
+ (string= tagtype typestring))
+ ;; Matching tokens, and the type of the type is the same.
+ (and (string= tagtypestring typestring)
+ (if (and (semantic-tag-type tagtype) (semantic-tag-type type))
+ (equal (semantic-tag-type tagtype) (semantic-tag-type type))
+ t))
+ ))
+ ))
+
+(defun semantic-tag-type-compound-p (tag)
+ "Return non-nil the type of TAG is compound.
+Compound implies a structure or similar data type.
+Returns the list of tag members if it is compound."
+ (let* ((tagtype (semantic-tag-type tag))
+ )
+ (when (and (semantic-tag-p tagtype)
+ (semantic-tag-of-class-p tagtype 'type))
+ ;; We have the potential of this being a nifty compound type.
+ (semantic-tag-type-members tagtype)
+ )))
+
+(defun semantic-tag-faux-p (tag)
+ "Return non-nil if TAG is a FAUX tag.
+FAUX tags are created to represent a construct that is
+not known to exist in the code.
+
+Example: When the class browser sees methods to a class, but
+cannot find the class, it will create a faux tag to represent the
+class to store those methods."
+ (semantic--tag-get-property tag :faux-flag))
+
+;;; Tag creation
+;;
+
+;; Is this function still necessary?
+(defun semantic-tag-make-plist (args)
+ "Create a property list with ARGS.
+Args is a property list of the form (KEY1 VALUE1 ... KEYN VALUEN).
+Where KEY is a symbol, and VALUE is the value for that symbol.
+The return value will be a new property list, with these KEY/VALUE
+pairs eliminated:
+
+ - KEY associated to nil VALUE.
+ - KEY associated to an empty string VALUE.
+ - KEY associated to a zero VALUE."
+ (let (plist key val)
+ (while args
+ (setq key (car args)
+ val (nth 1 args)
+ args (nthcdr 2 args))
+ (or (member val '("" nil))
+ (and (numberp val) (zerop val))
+ (setq plist (cons key (cons val plist)))))
+ ;; It is not useful to reverse the new plist.
+ plist))
+
+(defsubst semantic-tag (name class &rest attributes)
+ "Create a generic semantic tag.
+NAME is a string representing the name of this tag.
+CLASS is the symbol that represents the class of tag this is,
+such as 'variable, or 'function.
+ATTRIBUTES is a list of additional attributes belonging to this tag."
+ (list name class (semantic-tag-make-plist attributes) nil nil))
+
+(defsubst semantic-tag-new-variable (name type &optional default-value &rest
attributes)
+ "Create a semantic tag of class 'variable.
+NAME is the name of this variable.
+TYPE is a string or semantic tag representing the type of this variable.
+Optional DEFAULT-VALUE is a string representing the default value of this
variable.
+ATTRIBUTES is a list of additional attributes belonging to this tag."
+ (apply 'semantic-tag name 'variable
+ :type type
+ :default-value default-value
+ attributes))
+
+(defsubst semantic-tag-new-function (name type arg-list &rest attributes)
+ "Create a semantic tag of class 'function.
+NAME is the name of this function.
+TYPE is a string or semantic tag representing the type of this function.
+ARG-LIST is a list of strings or semantic tags representing the
+arguments of this function.
+ATTRIBUTES is a list of additional attributes belonging to this tag."
+ (apply 'semantic-tag name 'function
+ :type type
+ :arguments arg-list
+ attributes))
+
+(defsubst semantic-tag-new-type (name type members parents &rest attributes)
+ "Create a semantic tag of class 'type.
+NAME is the name of this type.
+TYPE is a string or semantic tag representing the type of this type.
+MEMBERS is a list of strings or semantic tags representing the
+elements that make up this type if it is a composite type.
+PARENTS is a cons cell. (EXPLICIT-PARENTS . INTERFACE-PARENTS)
+EXPLICIT-PARENTS can be a single string (Just one parent) or a
+list of parents (in a multiple inheritance situation). It can also
+be nil.
+INTERFACE-PARENTS is a list of strings representing the names of
+all INTERFACES, or abstract classes inherited from. It can also be
+nil.
+This slot can be interesting because the form:
+ ( nil \"string\")
+is a valid parent where there is no explicit parent, and only an
+interface.
+ATTRIBUTES is a list of additional attributes belonging to this tag."
+ (apply 'semantic-tag name 'type
+ :type type
+ :members members
+ :superclasses (car parents)
+ :interfaces (cdr parents)
+ attributes))
+
+(defsubst semantic-tag-new-include (name system-flag &rest attributes)
+ "Create a semantic tag of class 'include.
+NAME is the name of this include.
+SYSTEM-FLAG represents that we were able to identify this include as belonging
+to the system, as opposed to belonging to the local project.
+ATTRIBUTES is a list of additional attributes belonging to this tag."
+ (apply 'semantic-tag name 'include
+ :system-flag system-flag
+ attributes))
+
+(defsubst semantic-tag-new-package (name detail &rest attributes)
+ "Create a semantic tag of class 'package.
+NAME is the name of this package.
+DETAIL is extra information about this package, such as a location where
+it can be found.
+ATTRIBUTES is a list of additional attributes belonging to this tag."
+ (apply 'semantic-tag name 'package
+ :detail detail
+ attributes))
+
+(defsubst semantic-tag-new-code (name detail &rest attributes)
+ "Create a semantic tag of class 'code.
+NAME is a name for this code.
+DETAIL is extra information about the code.
+ATTRIBUTES is a list of additional attributes belonging to this tag."
+ (apply 'semantic-tag name 'code
+ :detail detail
+ attributes))
+
+(defsubst semantic-tag-set-faux (tag)
+ "Set TAG to be a new FAUX tag.
+FAUX tags represent constructs not found in the source code.
+You can identify a faux tag with `semantic-tag-faux-p'"
+ (semantic--tag-put-property tag :faux-flag t))
+
+(defsubst semantic-tag-set-name (tag name)
+ "Set TAG name to NAME."
+ (setcar tag name))
+
+;;; Copying and cloning tags.
+;;
+(defsubst semantic-tag-clone (tag &optional name)
+ "Clone TAG, creating a new TAG.
+If optional argument NAME is not nil it specifies a new name for the
+cloned tag."
+ ;; Right now, TAG is a list.
+ (list (or name (semantic-tag-name tag))
+ (semantic-tag-class tag)
+ (copy-sequence (semantic-tag-attributes tag))
+ (copy-sequence (semantic-tag-properties tag))
+ (semantic-tag-overlay tag)))
+
+(defun semantic-tag-copy (tag &optional name keep-file)
+ "Return a copy of TAG unlinked from the originating buffer.
+If optional argument NAME is non-nil it specifies a new name for the
+copied tag.
+If optional argument KEEP-FILE is non-nil, and TAG was linked to a
+buffer, the originating buffer file name is kept in the `:filename'
+property of the copied tag.
+If KEEP-FILE is a string, and the orginating buffer is NOT available,
+then KEEP-FILE is stored on the `:filename' property.
+This runs the tag hook `unlink-copy-hook`."
+ ;; Right now, TAG is a list.
+ (let ((copy (semantic-tag-clone tag name)))
+
+ ;; Keep the filename if needed.
+ (when keep-file
+ (semantic--tag-put-property
+ copy :filename (or (semantic-tag-file-name copy)
+ (and (stringp keep-file)
+ keep-file)
+ )))
+
+ (when (semantic-tag-with-position-p tag)
+ ;; Convert the overlay to a vector, effectively 'unlinking' the tag.
+ (semantic--tag-set-overlay
+ copy (vector (semantic-tag-start copy) (semantic-tag-end copy)))
+
+ ;; Force the children to be copied also.
+ ;;(let ((chil (semantic--tag-copy-list
+ ;; (semantic-tag-components-with-overlays tag)
+ ;; keep-file)))
+ ;;;; Put the list into TAG.
+ ;;)
+
+ ;; Call the unlink-copy hook. This should tell tools that
+ ;; this tag is not part of any buffer.
+ (when (semantic-overlay-p (semantic-tag-overlay tag))
+ (semantic--tag-run-hooks copy 'unlink-copy-hook))
+ )
+ copy))
+
+;;(defun semantic--tag-copy-list (tags &optional keep-file)
+;; "Make copies of TAGS and return the list of TAGS."
+;; (let ((out nil))
+;; (dolist (tag tags out)
+;; (setq out (cons (semantic-tag-copy tag nil keep-file)
+;; out))
+;; )))
+
+(defun semantic--tag-copy-properties (tag1 tag2)
+ "Copy private properties from TAG1 to TAG2.
+Return TAG2.
+This function is for internal use only."
+ (let ((plist (semantic-tag-properties tag1)))
+ (while plist
+ (semantic--tag-put-property tag2 (car plist) (nth 1 plist))
+ (setq plist (nthcdr 2 plist)))
+ tag2))
+
+;;; DEEP COPIES
+;;
+(defun semantic-tag-deep-copy-one-tag (tag &optional filter)
+ "Make a deep copy of TAG, applying FILTER to each child-tag.
+Properties and overlay info are not copied.
+FILTER takes TAG as an argument, and should returns a semantic-tag.
+It is safe for FILTER to modify the input tag and return it."
+ (when (not filter) (setq filter 'identity))
+ (when (not (semantic-tag-p tag))
+ (signal 'wrong-type-argument (list tag 'semantic-tag-p)))
+ (funcall filter (list (semantic-tag-name tag)
+ (semantic-tag-class tag)
+ (semantic--tag-deep-copy-attributes
+ (semantic-tag-attributes tag) filter)
+ nil
+ nil)))
+
+(defun semantic--tag-deep-copy-attributes (attrs &optional filter)
+ "Make a deep copy of ATTRS, applying FILTER to each child-tag.
+
+It is safe to modify ATTR, and return a permutaion of that list.
+
+FILTER takes TAG as an argument, and should returns a semantic-tag.
+It is safe for FILTER to modify the input tag and return it."
+ (when (car attrs)
+ (when (not (symbolp (car attrs))) (error "Bad Attribute List in tag"))
+ (cons (car attrs)
+ (cons (semantic--tag-deep-copy-value (nth 1 attrs) filter)
+ (semantic--tag-deep-copy-attributes (nthcdr 2 attrs)
filter)))))
+
+(defun semantic--tag-deep-copy-value (value &optional filter)
+ "Make a deep copy of VALUE, applying FILTER to each child-tag.
+
+It is safe to modify VALUE, and return a permutaion of that list.
+
+FILTER takes TAG as an argument, and should returns a semantic-tag.
+It is safe for FILTER to modify the input tag and return it."
+ (cond
+ ;; Another tag.
+ ((semantic-tag-p value)
+ (semantic-tag-deep-copy-one-tag value filter))
+
+ ;; A list of more tags
+ ((and (listp value) (semantic-tag-p (car value)))
+ (semantic--tag-deep-copy-tag-list value filter))
+
+ ;; Some arbitrary data.
+ (t value)))
+
+(defun semantic--tag-deep-copy-tag-list (tags &optional filter)
+ "Make a deep copy of TAGS, applying FILTER to each child-tag.
+
+It is safe to modify the TAGS list, and return a permutaion of that list.
+
+FILTER takes TAG as an argument, and should returns a semantic-tag.
+It is safe for FILTER to modify the input tag and return it."
+ (when (car tags)
+ (if (semantic-tag-p (car tags))
+ (cons (semantic-tag-deep-copy-one-tag (car tags) filter)
+ (semantic--tag-deep-copy-tag-list (cdr tags) filter))
+ (cons (car tags) (semantic--tag-deep-copy-tag-list (cdr tags) filter)))))
+
+
+;;; Standard Tag Access
+;;
+
+;;; Common
+;;
+(defsubst semantic-tag-modifiers (tag)
+ "Return the value of the `:typemodifiers' attribute of TAG."
+ (semantic-tag-get-attribute tag :typemodifiers))
+
+(defun semantic-tag-docstring (tag &optional buffer)
+ "Return the documentation of TAG.
+That is the value defined by the `:documentation' attribute.
+Optional argument BUFFER indicates where to get the text from.
+If not provided, then only the POSITION can be provided.
+
+If you want to get documentation for languages that do not store
+the documentation string in the tag itself, use
+`semantic-documentation-for-tag' instead."
+ (let ((p (semantic-tag-get-attribute tag :documentation)))
+ (cond
+ ((stringp p) p) ;; it is the doc string.
+
+ ((semantic-lex-token-with-text-p p)
+ (semantic-lex-token-text p))
+
+ ((and (semantic-lex-token-without-text-p p)
+ buffer)
+ (with-current-buffer buffer
+ (semantic-lex-token-text (car (semantic-lex p (1+ p))))))
+
+ (t nil))))
+
+;;; Generic attributes for tags of any class.
+;;
+(defsubst semantic-tag-named-parent (tag)
+ "Return the parent of TAG.
+That is the value of the `:parent' attribute.
+If a definition can occur outside an actual parent structure, but
+refers to that parent by name, then the :parent attribute should be used."
+ (semantic-tag-get-attribute tag :parent))
+
+;;; Tags of class `type'
+
+(defun semantic-tag-type-superclasses (tag)
+ "Return the list of superclass names of the type that TAG describes."
+ (let ((supers (semantic-tag-get-attribute tag :superclasses)))
+ (cond ((stringp supers)
+ ;; If we have a string, make it a list.
+ (list supers))
+ ((semantic-tag-p supers)
+ ;; If we have one tag, return just the name.
+ (list (semantic-tag-name supers)))
+ ((and (consp supers) (semantic-tag-p (car supers)))
+ ;; If we have a tag list, then return the names.
+ (mapcar (lambda (s) (semantic-tag-name s))
+ supers))
+ ((consp supers)
+ ;; A list of something, return it.
+ supers))))
+
+(defun semantic--tag-find-parent-by-name (name supers)
+ "Find the superclass NAME in the list of SUPERS.
+If a simple search doesn't do it, try splitting up the names
+in SUPERS."
+ (let ((stag nil))
+ (setq stag (semantic-find-first-tag-by-name name supers))
+
+ (when (not stag)
+ (require 'semantic/analyze/fcn)
+ (dolist (S supers)
+ (let* ((sname (semantic-tag-name S))
+ (splitparts (semantic-analyze-split-name sname))
+ (parts (if (stringp splitparts)
+ (list splitparts)
+ (nreverse splitparts))))
+ (when (string= name (car parts))
+ (setq stag S))
+ )))
+
+ stag))
+
+(defun semantic-tag-type-superclass-protection (tag parentstring)
+ "Return the inheritance protection in TAG from PARENTSTRING.
+PARENTSTRING is the name of the parent being inherited.
+The return protection is a symbol, 'public, 'protection, and 'private."
+ (let ((supers (semantic-tag-get-attribute tag :superclasses)))
+ (cond ((stringp supers)
+ 'public)
+ ((semantic-tag-p supers)
+ (let ((prot (semantic-tag-get-attribute supers :protection)))
+ (or (cdr (assoc prot '(("public" . public)
+ ("protected" . protected)
+ ("private" . private))))
+ 'public)))
+ ((and (consp supers) (stringp (car supers)))
+ 'public)
+ ((and (consp supers) (semantic-tag-p (car supers)))
+ (let* ((stag (semantic--tag-find-parent-by-name parentstring supers))
+ (prot (when stag
+ (semantic-tag-get-attribute stag :protection))))
+ (or (cdr (assoc prot '(("public" . public)
+ ("protected" . protected)
+ ("private" . private))))
+ (when (equal prot "unspecified")
+ (if (semantic-tag-of-type-p tag "class")
+ 'private
+ 'public))
+ 'public))))
+ ))
+
+(defsubst semantic-tag-type-interfaces (tag)
+ "Return the list of interfaces of the type that TAG describes."
+ ;; @todo - make this as robust as the above.
+ (semantic-tag-get-attribute tag :interfaces))
+
+;;; Tags of class `function'
+;;
+(defsubst semantic-tag-function-arguments (tag)
+ "Return the arguments of the function that TAG describes.
+That is the value of the `:arguments' attribute."
+ (semantic-tag-get-attribute tag :arguments))
+
+(defsubst semantic-tag-function-throws (tag)
+ "Return the exceptions the function that TAG describes can throw.
+That is the value of the `:throws' attribute."
+ (semantic-tag-get-attribute tag :throws))
+
+(defsubst semantic-tag-function-parent (tag)
+ "Return the parent of the function that TAG describes.
+That is the value of the `:parent' attribute.
+A function has a parent if it is a method of a class, and if the
+function does not appear in body of it's parent class."
+ (semantic-tag-named-parent tag))
+
+(defsubst semantic-tag-function-destructor-p (tag)
+ "Return non-nil if TAG describes a destructor function.
+That is the value of the `:destructor-flag' attribute."
+ (semantic-tag-get-attribute tag :destructor-flag))
+
+(defsubst semantic-tag-function-constructor-p (tag)
+ "Return non-nil if TAG describes a constructor function.
+That is the value of the `:constructor-flag' attribute."
+ (semantic-tag-get-attribute tag :constructor-flag))
+
+;;; Tags of class `variable'
+;;
+(defsubst semantic-tag-variable-default (tag)
+ "Return the default value of the variable that TAG describes.
+That is the value of the attribute `:default-value'."
+ (semantic-tag-get-attribute tag :default-value))
+
+(defsubst semantic-tag-variable-constant-p (tag)
+ "Return non-nil if the variable that TAG describes is a constant.
+That is the value of the attribute `:constant-flag'."
+ (semantic-tag-get-attribute tag :constant-flag))
+
+;;; Tags of class `include'
+;;
+(defsubst semantic-tag-include-system-p (tag)
+ "Return non-nil if the include that TAG describes is a system include.
+That is the value of the attribute `:system-flag'."
+ (semantic-tag-get-attribute tag :system-flag))
+
+(define-overloadable-function semantic-tag-include-filename (tag)
+ "Return a filename representation of TAG.
+The default action is to return the `semantic-tag-name'.
+Some languages do not use full filenames in their include statements.
+Override this method to translate the code represenation
+into a filename. (A relative filename if necessary.)
+
+See `semantic-dependency-tag-file' to expand an include
+tag to a full file name.")
+
+(defun semantic-tag-include-filename-default (tag)
+ "Return a filename representation of TAG.
+Returns `semantic-tag-name'."
+ (semantic-tag-name tag))
+
+;;; Tags of class `code'
+;;
+(defsubst semantic-tag-code-detail (tag)
+ "Return detail information from code that TAG describes.
+That is the value of the attribute `:detail'."
+ (semantic-tag-get-attribute tag :detail))
+
+;;; Tags of class `alias'
+;;
+(defsubst semantic-tag-new-alias (name meta-tag-class value &rest attributes)
+ "Create a semantic tag of class alias.
+NAME is a name for this alias.
+META-TAG-CLASS is the class of the tag this tag is an alias.
+VALUE is the aliased definition.
+ATTRIBUTES is a list of additional attributes belonging to this tag."
+ (apply 'semantic-tag name 'alias
+ :aliasclass meta-tag-class
+ :definition value
+ attributes))
+
+(defsubst semantic-tag-alias-class (tag)
+ "Return the class of tag TAG is an alias."
+ (semantic-tag-get-attribute tag :aliasclass))
+
+(define-overloadable-function semantic-tag-alias-definition (tag)
+ "Return the definition TAG is an alias.
+The returned value is a tag of the class that
+`semantic-tag-alias-class' returns for TAG.
+The default is to return the value of the :definition attribute.
+Return nil if TAG is not of class 'alias."
+ (when (semantic-tag-of-class-p tag 'alias)
+ (:override
+ (semantic-tag-get-attribute tag :definition))))
+
+;;; Language Specific Tag access via overload
+;;
+;;;###autoload
+(define-overloadable-function semantic-tag-components (tag)
+ "Return a list of components for TAG.
+A Component is a part of TAG which itself may be a TAG.
+Examples include the elements of a structure in a
+tag of class `type, or the list of arguments to a
+tag of class 'function."
+ )
+
+(defun semantic-tag-components-default (tag)
+ "Return a list of components for TAG.
+Perform the described task in `semantic-tag-components'."
+ (cond ((semantic-tag-of-class-p tag 'type)
+ (semantic-tag-type-members tag))
+ ((semantic-tag-of-class-p tag 'function)
+ (semantic-tag-function-arguments tag))
+ (t nil)))
+
+(define-overloadable-function semantic-tag-components-with-overlays (tag)
+ "Return the list of top level components belonging to TAG.
+Children are any sub-tags which contain overlays.
+
+Default behavior is to get `semantic-tag-components' in addition
+to the components of an anonymous types (if applicable.)
+
+Note for language authors:
+ If a mode defines a language tag that has tags in it with overlays
+you should still return them with this function.
+Ignoring this step will prevent several features from working correctly."
+ )
+
+(defun semantic-tag-components-with-overlays-default (tag)
+ "Return the list of top level components belonging to TAG.
+Children are any sub-tags which contain overlays.
+The default action collects regular components of TAG, in addition
+to any components beloning to an anonymous type."
+ (let ((explicit-children (semantic-tag-components tag))
+ (type (semantic-tag-type tag))
+ (anon-type-children nil)
+ (all-children nil))
+ ;; Identify if this tag has an anonymous structure as
+ ;; its type. This implies it may have children with overlays.
+ (when (and type (semantic-tag-p type))
+ (setq anon-type-children (semantic-tag-components type))
+ ;; Add anonymous children
+ (while anon-type-children
+ (when (semantic-tag-with-position-p (car anon-type-children))
+ (setq all-children (cons (car anon-type-children) all-children)))
+ (setq anon-type-children (cdr anon-type-children))))
+ ;; Add explicit children
+ (while explicit-children
+ (when (semantic-tag-with-position-p (car explicit-children))
+ (setq all-children (cons (car explicit-children) all-children)))
+ (setq explicit-children (cdr explicit-children)))
+ ;; Return
+ (nreverse all-children)))
+
+(defun semantic-tag-children-compatibility (tag &optional positiononly)
+ "Return children of TAG.
+If POSITIONONLY is nil, use `semantic-tag-components'.
+If POSITIONONLY is non-nil, use `semantic-tag-components-with-overlays'.
+DO NOT use this fcn in new code. Use one of the above instead."
+ (if positiononly
+ (semantic-tag-components-with-overlays tag)
+ (semantic-tag-components tag)))
+
+;;; Tag Region
+;;
+;; A Tag represents a region in a buffer. You can narrow to that tag.
+;;
+(defun semantic-narrow-to-tag (&optional tag)
+ "Narrow to the region specified by the bounds of TAG.
+See `semantic-tag-bounds'."
+ (interactive)
+ (if (not tag) (setq tag (semantic-current-tag)))
+ (narrow-to-region (semantic-tag-start tag)
+ (semantic-tag-end tag)))
+
+(defmacro semantic-with-buffer-narrowed-to-current-tag (&rest body)
+ "Execute BODY with the buffer narrowed to the current tag."
+ `(save-restriction
+ (semantic-narrow-to-tag (semantic-current-tag))
+ ,@body))
+(put 'semantic-with-buffer-narrowed-to-current-tag 'lisp-indent-function 0)
+(add-hook 'edebug-setup-hook
+ (lambda ()
+ (def-edebug-spec semantic-with-buffer-narrowed-to-current-tag
+ (def-body))))
+
+(defmacro semantic-with-buffer-narrowed-to-tag (tag &rest body)
+ "Narrow to TAG, and execute BODY."
+ `(save-restriction
+ (semantic-narrow-to-tag ,tag)
+ ,@body))
+(put 'semantic-with-buffer-narrowed-to-tag 'lisp-indent-function 1)
+(add-hook 'edebug-setup-hook
+ (lambda ()
+ (def-edebug-spec semantic-with-buffer-narrowed-to-tag
+ (def-body))))
+
+;;; Tag Hooks
+;;
+;; Semantic may want to provide special hooks when specific operations
+;; are about to happen on a given tag. These routines allow for hook
+;; maintenance on a tag.
+
+;; Internal global variable used to manage tag hooks. For example,
+;; some implementation of `remove-hook' checks that the hook variable
+;; is `default-boundp'.
+(defvar semantic--tag-hook-value)
+
+(defun semantic-tag-add-hook (tag hook function &optional append)
+ "Onto TAG, add to the value of HOOK the function FUNCTION.
+FUNCTION is added (if necessary) at the beginning of the hook list
+unless the optional argument APPEND is non-nil, in which case
+FUNCTION is added at the end.
+HOOK should be a symbol, and FUNCTION may be any valid function.
+See also the function `add-hook'."
+ (let ((semantic--tag-hook-value (semantic--tag-get-property tag hook)))
+ (add-hook 'semantic--tag-hook-value function append)
+ (semantic--tag-put-property tag hook semantic--tag-hook-value)
+ semantic--tag-hook-value))
+
+(defun semantic-tag-remove-hook (tag hook function)
+ "Onto TAG, remove from the value of HOOK the function FUNCTION.
+HOOK should be a symbol, and FUNCTION may be any valid function. If
+FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in
+the list of hooks to run in HOOK, then nothing is done.
+See also the function `remove-hook'."
+ (let ((semantic--tag-hook-value (semantic--tag-get-property tag hook)))
+ (remove-hook 'semantic--tag-hook-value function)
+ (semantic--tag-put-property tag hook semantic--tag-hook-value)
+ semantic--tag-hook-value))
+
+(defun semantic--tag-run-hooks (tag hook &rest args)
+ "Run for TAG all expressions saved on the property HOOK.
+Each hook expression must take at least one argument, the TAG.
+For any given situation, additional ARGS may be passed."
+ (let ((semantic--tag-hook-value (semantic--tag-get-property tag hook))
+ (arglist (cons tag args)))
+ (condition-case err
+ ;; If a hook bombs, ignore it! Usually this is tied into
+ ;; some sort of critical system.
+ (apply 'run-hook-with-args 'semantic--tag-hook-value arglist)
+ (error (message "Error: %S" err)))))
+
+;;; Tags and Overlays
+;;
+;; Overlays are used so that we can quickly identify tags from
+;; buffer positions and regions using built in Emacs commands.
+;;
+(defsubst semantic--tag-unlink-list-from-buffer (tags)
+ "Convert TAGS from using an overlay to using an overlay proxy.
+This function is for internal use only."
+ (mapcar 'semantic--tag-unlink-from-buffer tags))
+
+(defun semantic--tag-unlink-from-buffer (tag)
+ "Convert TAG from using an overlay to using an overlay proxy.
+This function is for internal use only."
+ (when (semantic-tag-p tag)
+ (let ((o (semantic-tag-overlay tag)))
+ (when (semantic-overlay-p o)
+ (semantic--tag-set-overlay
+ tag (vector (semantic-overlay-start o)
+ (semantic-overlay-end o)))
+ (semantic-overlay-delete o))
+ ;; Look for a link hook on TAG.
+ (semantic--tag-run-hooks tag 'unlink-hook)
+ ;; Fix the sub-tags which contain overlays.
+ (semantic--tag-unlink-list-from-buffer
+ (semantic-tag-components-with-overlays tag)))))
+
+(defsubst semantic--tag-link-list-to-buffer (tags)
+ "Convert TAGS from using an overlay proxy to using an overlay.
+This function is for internal use only."
+ (mapcar 'semantic--tag-link-to-buffer tags))
+
+(defun semantic--tag-link-to-buffer (tag)
+ "Convert TAG from using an overlay proxy to using an overlay.
+This function is for internal use only."
+ (when (semantic-tag-p tag)
+ (let ((o (semantic-tag-overlay tag)))
+ (when (and (vectorp o) (= (length o) 2))
+ (setq o (semantic-make-overlay (aref o 0) (aref o 1)
+ (current-buffer)))
+ (semantic--tag-set-overlay tag o)
+ (semantic-overlay-put o 'semantic tag)
+ ;; Clear the :filename property
+ (semantic--tag-put-property tag :filename nil))
+ ;; Look for a link hook on TAG.
+ (semantic--tag-run-hooks tag 'link-hook)
+ ;; Fix the sub-tags which contain overlays.
+ (semantic--tag-link-list-to-buffer
+ (semantic-tag-components-with-overlays tag)))))
+
+(defun semantic--tag-unlink-cache-from-buffer ()
+ "Convert all tags in the current cache to use overlay proxys.
+This function is for internal use only."
+ (require 'semantic)
+ (semantic--tag-unlink-list-from-buffer
+ ;; @todo- use fetch-tags-fast?
+ (semantic-fetch-tags)))
+
+(defvar semantic--buffer-cache)
+
+(defun semantic--tag-link-cache-to-buffer ()
+ "Convert all tags in the current cache to use overlays.
+This function is for internal use only."
+ (require 'semantic)
+ (condition-case nil
+ ;; In this unique case, we cannot call the usual toplevel fn.
+ ;; because we don't want a reparse, we want the old overlays.
+ (semantic--tag-link-list-to-buffer
+ semantic--buffer-cache)
+ ;; Recover when there is an error restoring the cache.
+ (error (message "Error recovering tag list")
+ (semantic-clear-toplevel-cache)
+ nil)))
+
+;;; Tag Cooking
+;;
+;; Raw tags from a parser follow a different positional format than
+;; those used in the buffer cache. Raw tags need to be cooked into
+;; semantic cache friendly tags for use by the masses.
+;;
+(defsubst semantic--tag-expanded-p (tag)
+ "Return non-nil if TAG is expanded.
+This function is for internal use only.
+See also the function `semantic--expand-tag'."
+ ;; In fact a cooked tag is actually a list of cooked tags
+ ;; because a raw tag can be expanded in several cooked ones!
+ (when (consp tag)
+ (while (and (semantic-tag-p (car tag))
+ (vectorp (semantic-tag-overlay (car tag))))
+ (setq tag (cdr tag)))
+ (null tag)))
+
+(defvar semantic-tag-expand-function nil
+ "Function used to expand a tag.
+It is passed each tag production, and must return a list of tags
+derived from it, or nil if it does not need to be expanded.
+
+Languages with compound definitions should use this function to expand
+from one compound symbol into several. For example, in C or Java the
+following definition is easily parsed into one tag:
+
+ int a, b;
+
+This function should take this compound tag and turn it into two tags,
+one for A, and the other for B.")
+(make-variable-buffer-local 'semantic-tag-expand-function)
+
+(defun semantic--tag-expand (tag)
+ "Convert TAG from a raw state to a cooked state, and expand it.
+Returns a list of cooked tags.
+
+ The parser returns raw tags with positional data START END at the
+end of the tag data structure (a list for now). We convert it from
+that to a cooked state that uses an overlay proxy, that is, a vector
+\[START END].
+
+ The raw tag is changed with side effects and maybe expanded in
+several derived tags when the variable `semantic-tag-expand-function'
+is set.
+
+This function is for internal use only."
+ (if (semantic--tag-expanded-p tag)
+ ;; Just return TAG if it is already expanded (by a grammar
+ ;; semantic action), or if it isn't recognized as a valid
+ ;; semantic tag.
+ tag
+
+ ;; Try to cook the tag. This code will be removed when tag will
+ ;; be directly created with the right format.
+ (condition-case nil
+ (let ((ocdr (semantic--tag-overlay-cdr tag)))
+ ;; OCDR contains the sub-list of TAG whose car is the
+ ;; OVERLAY part of TAG. That is, a list (OVERLAY START END).
+ ;; Convert it into an overlay proxy ([START END]).
+ (semantic--tag-set-overlay
+ tag (vector (nth 1 ocdr) (nth 2 ocdr)))
+ ;; Remove START END positions at end of tag.
+ (setcdr ocdr nil)
+ ;; At this point (length TAG) must be 5!
+ ;;(unless (= (length tag) 5)
+ ;; (error "Tag expansion failed"))
+ )
+ (error
+ (message "A Rule must return a single tag-line list!")
+ (debug tag)
+ nil))
+ ;; Expand based on local configuration
+ (if semantic-tag-expand-function
+ (or (funcall semantic-tag-expand-function tag)
+ (list tag))
+ (list tag))))
+
+;; Foreign tags
+;;
+(defmacro semantic-foreign-tag-invalid (tag)
+ "Signal that TAG is an invalid foreign tag."
+ `(signal 'wrong-type-argument '(semantic-foreign-tag-p ,tag)))
+
+(defsubst semantic-foreign-tag-p (tag)
+ "Return non-nil if TAG is a foreign tag.
+That is, a tag unlinked from the originating buffer, which carries the
+originating buffer file name, and major mode."
+ (and (semantic-tag-p tag)
+ (semantic--tag-get-property tag :foreign-flag)))
+
+(defsubst semantic-foreign-tag-check (tag)
+ "Check that TAG is a valid foreign tag.
+Signal an error if not."
+ (or (semantic-foreign-tag-p tag)
+ (semantic-foreign-tag-invalid tag)))
+
+(defun semantic-foreign-tag (&optional tag)
+ "Return a copy of TAG as a foreign tag, or nil if it can't be done.
+TAG defaults to the tag at point in current buffer.
+See also `semantic-foreign-tag-p'."
+ (or tag (setq tag (semantic-current-tag)))
+ (when (semantic-tag-p tag)
+ (let ((ftag (semantic-tag-copy tag nil t))
+ ;; Do extra work for the doc strings, since this is a
+ ;; common use case.
+ (doc (condition-case nil
+ (semantic-documentation-for-tag tag)
+ (error nil))))
+ ;; A foreign tag must carry its originating buffer file name!
+ (when (semantic--tag-get-property ftag :filename)
+ (semantic--tag-put-property ftag :mode (semantic-tag-mode tag))
+ (semantic--tag-put-property ftag :documentation doc)
+ (semantic--tag-put-property ftag :foreign-flag t)
+ ftag))))
+
+;; High level obtain/insert foreign tag overloads
+(define-overloadable-function semantic-obtain-foreign-tag (&optional tag)
+ "Obtain a foreign tag from TAG.
+TAG defaults to the tag at point in current buffer.
+Return the obtained foreign tag or nil if failed."
+ (semantic-foreign-tag tag))
+
+(defun semantic-insert-foreign-tag-default (foreign-tag)
+ "Insert FOREIGN-TAG into the current buffer.
+The default behavior assumes the current buffer is a language file,
+and attempts to insert a prototype/function call."
+ ;; Long term goal: Have a mechanism for a tempo-like template insert
+ ;; for the given tag.
+ (insert (semantic-format-tag-prototype foreign-tag)))
+
+(define-overloadable-function semantic-insert-foreign-tag (foreign-tag)
+ "Insert FOREIGN-TAG into the current buffer.
+Signal an error if FOREIGN-TAG is not a valid foreign tag.
+This function is overridable with the symbol `insert-foreign-tag'."
+ (semantic-foreign-tag-check foreign-tag)
+ (:override)
+ (message (semantic-format-tag-summarize foreign-tag)))
+
+;;; Support log modes here
+(define-mode-local-override semantic-insert-foreign-tag
+ log-edit-mode (foreign-tag)
+ "Insert foreign tags into log-edit mode."
+ (insert (concat "(" (semantic-format-tag-name foreign-tag) "): ")))
+
+(define-mode-local-override semantic-insert-foreign-tag
+ change-log-mode (foreign-tag)
+ "Insert foreign tags into log-edit mode."
+ (insert (concat "(" (semantic-format-tag-name foreign-tag) "): ")))
+
+;;; Compatibility
+;;
+(defconst semantic-token-version
+ semantic-tag-version)
+(defconst semantic-token-incompatible-version
+ semantic-tag-incompatible-version)
+
+(defsubst semantic-token-type-parent (tag)
+ "Return the parent of the type that TAG describes.
+The return value is a list. A value of nil means no parents.
+The `car' of the list is either the parent class, or a list
+of parent classes. The `cdr' of the list is the list of
+interfaces, or abstract classes which are parents of TAG."
+ (cons (semantic-tag-get-attribute tag :superclasses)
+ (semantic-tag-type-interfaces tag)))
+(make-obsolete 'semantic-token-type-parent
+ "\
+use `semantic-tag-type-superclass' \
+and `semantic-tag-type-interfaces' instead")
+
+(semantic-alias-obsolete 'semantic-tag-make-assoc-list
+ 'semantic-tag-make-plist)
+
+(semantic-varalias-obsolete 'semantic-expand-nonterminal
+ 'semantic-tag-expand-function)
+
+(provide 'semantic/tag)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/tag"
+;; End:
+
+;;; semantic/tag.el ends here
Index: cedet/semantic/texi.el
===================================================================
RCS file: cedet/semantic/texi.el
diff -N cedet/semantic/texi.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/texi.el 28 Sep 2009 15:15:09 -0000 1.2
@@ -0,0 +1,682 @@
+;;; semantic/texi.el --- Semantic details for Texinfo files
+
+;;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Parse Texinfo buffers using regular expressions. The core parser
+;; engine is the function `semantic-texi-parse-headings'. The
+;; parser plug-in is the function `semantic-texi-parse-region' that
+;; overrides `semantic-parse-region'.
+
+(require 'semantic)
+(require 'semantic/format)
+(require 'texinfo)
+
+(eval-when-compile
+ (require 'semantic/db)
+ (require 'semantic/db-find)
+ (require 'semantic/ctxt)
+ (require 'semantic/find)
+ (require 'semantic/doc))
+
+(defvar ede-minor-mode)
+(declare-function lookup-words "ispell")
+(declare-function ede-current-project "ede")
+
+(defvar semantic-texi-super-regex
+
"address@hidden(top\\|chapter\\|\\(sub\\)*section\\|unnumbered\\(\\(sub\\)*sec\\)?\\|\
+\\(chap\\|\\(sub\\)+\\|major\\)?heading\\|appendix\\(\\(sub\\)*sec\\)?\\|\
+centerchap\\|def\\(var\\|un\\|fn\\|opt\\)x?\\)"
+ "Regular expression used to find special sections in a Texinfo file.")
+
+(defvar semantic-texi-name-field-list
+ '( ("defvar" . 1)
+ ("defvarx" . 1)
+ ("defun" . 1)
+ ("defunx" . 1)
+ ("defopt" . 1)
+ ("deffn" . 2)
+ ("deffnx" . 2)
+ )
+ "List of definition commands, and the field position.
+The field position is the field number (based at 1) where the
+name of this section is.")
+
+;;; Code:
+(defun semantic-texi-parse-region (&rest ignore)
+ "Parse the current texinfo buffer for semantic tags.
+IGNORE any arguments, always parse the whole buffer.
+Each tag returned is of the form:
+ (\"NAME\" section (:members CHILDREN))
+or
+ (\"NAME\" def)
+
+It is an override of 'parse-region and must be installed by the
+function `semantic-install-function-overrides'."
+ (mapcar 'semantic-texi-expand-tag
+ (semantic-texi-parse-headings)))
+
+(defun semantic-texi-parse-changes ()
+ "Parse changes in the current texinfo buffer."
+ ;; NOTE: For now, just schedule a full reparse.
+ ;; To be implemented later.
+ (semantic-parse-tree-set-needs-rebuild))
+
+(defun semantic-texi-expand-tag (tag)
+ "Expand the texinfo tag TAG."
+ (let ((chil (semantic-tag-components tag)))
+ (if chil
+ (semantic-tag-put-attribute
+ tag :members (mapcar 'semantic-texi-expand-tag chil)))
+ (car (semantic--tag-expand tag))))
+
+(defun semantic-texi-parse-headings ()
+ "Parse the current texinfo buffer for all semantic tags now."
+ (let ((pass1 nil))
+ ;; First search and snarf.
+ (save-excursion
+ (goto-char (point-min))
+ (let ((semantic--progress-reporter
+ (make-progress-reporter
+ (format "Parsing %s..."
+ (file-name-nondirectory buffer-file-name))
+ (point-min) (point-max))))
+ (while (re-search-forward semantic-texi-super-regex nil t)
+ (setq pass1 (cons (match-beginning 0) pass1))
+ (progress-reporter-update semantic--progress-reporter (point)))
+ (progress-reporter-done semantic--progress-reporter)))
+ (setq pass1 (nreverse pass1))
+ ;; Now, make some tags while creating a set of children.
+ (car (semantic-texi-recursive-combobulate-list pass1 0))
+ ))
+
+(defsubst semantic-texi-new-section-tag (name members start end)
+ "Create a semantic tag of class section.
+NAME is the name of this section.
+MEMBERS is a list of semantic tags representing the elements that make
+up this section.
+START and END define the location of data described by the tag."
+ (append (semantic-tag name 'section :members members)
+ (list start end)))
+
+(defsubst semantic-texi-new-def-tag (name start end)
+ "Create a semantic tag of class def.
+NAME is the name of this definition.
+START and END define the location of data described by the tag."
+ (append (semantic-tag name 'def)
+ (list start end)))
+
+(defun semantic-texi-set-endpoint (metataglist pnt)
+ "Set the end point of the first section tag in METATAGLIST to PNT.
+METATAGLIST is a list of tags in the intermediate tag format used by the
+texinfo parser. PNT is the new point to set."
+ (let ((metatag nil))
+ (while (and metataglist
+ (not (eq (semantic-tag-class (car metataglist)) 'section)))
+ (setq metataglist (cdr metataglist)))
+ (setq metatag (car metataglist))
+ (when metatag
+ (setcar (nthcdr (1- (length metatag)) metatag) pnt)
+ metatag)))
+
+(defun semantic-texi-recursive-combobulate-list (sectionlist level)
+ "Rearrange SECTIONLIST to be a hierarchical tag list starting at LEVEL.
+Return the rearranged new list, with all remaining tags from
+SECTIONLIST starting at ELT 2. Sections not are not dealt with as soon as a
+tag with greater section value than LEVEL is found."
+ (let ((newl nil)
+ (oldl sectionlist)
+ tag
+ )
+ (save-excursion
+ (catch 'level-jump
+ (while oldl
+ (goto-char (car oldl))
+ (if (looking-at "@\\(\\w+\\)")
+ (let* ((word (match-string 1))
+ (levelmatch (assoc word texinfo-section-list))
+ text begin tmp
+ )
+ ;; Set begin to the right location
+ (setq begin (point))
+ ;; Get out of here if there if we made it that far.
+ (if (and levelmatch (<= (car (cdr levelmatch)) level))
+ (progn
+ (when newl
+ (semantic-texi-set-endpoint newl begin))
+ (throw 'level-jump t)))
+ ;; Recombobulate
+ (if levelmatch
+ (let ((end (match-end 1)))
+ ;; Levels sometimes have a @node just in front.
+ ;; That node statement should be included in the space
+ ;; for this entry.
+ (save-excursion
+ (skip-chars-backward "\n \t")
+ (beginning-of-line)
+ (when (looking-at "@node\\>")
+ (setq begin (point))))
+ ;; When there is a match, the descriptive text
+ ;; consists of the rest of the line.
+ (goto-char end)
+ (skip-chars-forward " \t")
+ (setq text (buffer-substring-no-properties
+ (point)
+ (progn (end-of-line) (point))))
+ ;; Next, recurse into the body to find the end.
+ (setq tmp (semantic-texi-recursive-combobulate-list
+ (cdr oldl) (car (cdr levelmatch))))
+ ;; Build a tag
+ (setq tag (semantic-texi-new-section-tag
+ text (car tmp) begin (point)))
+ ;; Before appending the newtag, update the previous tag
+ ;; if it is a section tag.
+ (when newl
+ (semantic-texi-set-endpoint newl begin))
+ ;; Append new tag to our master list.
+ (setq newl (cons tag newl))
+ ;; continue
+ (setq oldl (cdr tmp))
+ )
+ ;; No match means we have a def*, so get the name from
+ ;; it based on the type of thingy we found.
+ (setq levelmatch (assoc word semantic-texi-name-field-list)
+ tmp (or (cdr levelmatch) 1))
+ (forward-sexp tmp)
+ (skip-chars-forward " \t")
+ (setq text (buffer-substring-no-properties
+ (point)
+ (progn (forward-sexp 1) (point))))
+ ;; Seek the end of this definition
+ (goto-char begin)
+ (semantic-texi-forward-deffn)
+ (setq tag (semantic-texi-new-def-tag text begin (point))
+ newl (cons tag newl))
+ ;; continue
+ (setq oldl (cdr oldl)))
+ )
+ (error "Problem finding section in semantic/texi parser"))
+ ;; (setq oldl (cdr oldl))
+ )
+ ;; When oldl runs out, force a new endpoint as point-max
+ (when (not oldl)
+ (semantic-texi-set-endpoint newl (point-max)))
+ ))
+ (cons (nreverse newl) oldl)))
+
+(defun semantic-texi-forward-deffn ()
+ "Move forward over one deffn type definition.
+The cursor should be on the @ sign."
+ (when (looking-at "@\\(\\w+\\)")
+ (let* ((type (match-string 1))
+ (seek (concat "address@hidden" (regexp-quote type))))
+ (re-search-forward seek nil t))))
+
+(define-mode-local-override semantic-tag-components
+ texinfo-mode (tag)
+ "Return components belonging to TAG."
+ (semantic-tag-get-attribute tag :members))
+
+
+;;; Overrides: Context Parsing
+;;
+;; How to treat texi as a language?
+;;
+(defvar semantic-texi-environment-regexp
+ (if (string-match texinfo-environment-regexp "@menu")
+ ;; Make sure our Emacs has menus in it.
+ texinfo-environment-regexp
+ ;; If no menus, then merge in the menu concept.
+ (when (string-match "cartouche" texinfo-environment-regexp)
+ (concat (substring texinfo-environment-regexp
+ 0 (match-beginning 0))
+ "menu\\|"
+ (substring texinfo-environment-regexp
+ (match-beginning 0)))))
+ "Regular expression for matching texinfo enviroments.
+uses `texinfo-environment-regexp', but makes sure that it
+can handle the @menu environment.")
+
+(define-mode-local-override semantic-up-context texinfo-mode ()
+ "Handle texinfo constructs which do not use parenthetical nesting."
+ (let ((done nil))
+ (save-excursion
+ (let ((parenthetical (semantic-up-context-default))
+ )
+ (when (not parenthetical)
+ ;; We are in parenthises. Are they the types of parens
+ ;; belonging to a texinfo construct?
+ (forward-word -1)
+ (when (looking-at "@\\w+{")
+ (setq done (point))))))
+ ;; If we are not in a parenthetical node, then find a block instead.
+ ;; Use the texinfo support to find block start/end constructs.
+ (save-excursion
+ (while (and (not done)
+ (re-search-backward semantic-texi-environment-regexp nil t))
+ ;; For any hit, if we find an @end foo, then jump to the
+ ;; matching @foo. If it is not an end, then we win!
+ (if (not (looking-at "@end\\s-+\\(\\w+\\)"))
+ (setq done (point))
+ ;; Skip over this block
+ (let ((env (match-string 1)))
+ (re-search-backward (concat "@" env))))
+ ))
+ ;; All over, post what we find.
+ (if done
+ ;; We found something, so use it.
+ (progn (goto-char done)
+ nil)
+ t)))
+
+(define-mode-local-override semantic-beginning-of-context texinfo-mode
(&optional point)
+ "Move to the beginning of the context surrounding POINT."
+ (if (semantic-up-context point)
+ ;; If we can't go up, we can't do this either.
+ t
+ ;; We moved, so now we need to skip into whatever this thing is.
+ (forward-word 1) ;; skip the command
+ (if (looking-at "\\s-*{")
+ ;; In a short command. Go in.
+ (down-list 1)
+ ;; An environment. Go to the next line.
+ (end-of-line)
+ (forward-char 1))
+ nil))
+
+(define-mode-local-override semantic-ctxt-current-class-list
+ texinfo-mode (&optional point)
+ "Determine the class of tags that can be used at POINT.
+For texinfo, there two possibilities returned.
+1) 'function - for a call to a texinfo function
+2) 'word - indicates an english word.
+It would be nice to know function arguments too, but not today."
+ (let ((sym (semantic-ctxt-current-symbol)))
+ (if (and sym (= (aref (car sym) 0) ?@))
+ '(function)
+ '(word))))
+
+
+;;; Overrides : Formatting
+;;
+;; Various override to better format texi tags.
+;;
+
+(define-mode-local-override semantic-format-tag-abbreviate
+ texinfo-mode (tag &optional parent color)
+ "Texinfo tags abbreviation."
+ (let ((class (semantic-tag-class tag))
+ (name (semantic-format-tag-name tag parent color))
+ )
+ (cond ((eq class 'function)
+ (concat name "{ }"))
+ (t (semantic-format-tag-abbreviate-default tag parent color)))
+ ))
+
+(define-mode-local-override semantic-format-tag-prototype
+ texinfo-mode (tag &optional parent color)
+ "Texinfo tags abbreviation."
+ (semantic-format-tag-abbreviate tag parent color))
+
+
+;;; Texi Unique Features
+;;
+(defun semantic-tag-texi-section-text-bounds (tag)
+ "Get the bounds to the text of TAG.
+The text bounds is the text belonging to this node excluding
+the text of any child nodes, but including any defuns."
+ (let ((memb (semantic-tag-components tag)))
+ ;; Members.. if one is a section, check it out.
+ (while (and memb (not (semantic-tag-of-class-p (car memb) 'section)))
+ (setq memb (cdr memb)))
+ ;; No members? ... then a simple problem!
+ (if (not memb)
+ (semantic-tag-bounds tag)
+ ;; Our end is their beginning...
+ (list (semantic-tag-start tag) (semantic-tag-start (car memb))))))
+
+(defun semantic-texi-current-environment (&optional point)
+ "Return as a string the type of the current environment.
+Optional argument POINT is where to look for the environment."
+ (save-excursion
+ (when point (goto-char (point)))
+ (while (and (or (not (looking-at semantic-texi-environment-regexp))
+ (looking-at "@end"))
+ (not (semantic-up-context)))
+ )
+ (when (looking-at semantic-texi-environment-regexp)
+ (match-string 1))))
+
+
+;;; Analyzer
+;;
+(eval-when-compile
+ (require 'semantic/analyze))
+
+(define-mode-local-override semantic-analyze-current-context
+ texinfo-mode (point)
+ "Analysis context makes no sense for texinfo. Return nil."
+ (let* ((prefixandbounds (semantic-ctxt-current-symbol-and-bounds (point)))
+ (prefix (car prefixandbounds))
+ (bounds (nth 2 prefixandbounds))
+ (prefixclass (semantic-ctxt-current-class-list))
+ )
+ (when prefix
+ (require 'semantic/analyze)
+ (semantic-analyze-context
+ "Context-for-texinfo"
+ :buffer (current-buffer)
+ :scope nil
+ :bounds bounds
+ :prefix prefix
+ :prefixtypes nil
+ :prefixclass prefixclass)
+ )
+ ))
+
+(defvar semantic-texi-command-completion-list
+ (append (mapcar (lambda (a) (car a)) texinfo-section-list)
+ (condition-case nil
+ texinfo-environments
+ (error
+ ;; XEmacs doesn't use the above. Split up its regexp
+ (split-string texinfo-environment-regexp
"\\\\|\\|address@hidden(\\|\\\\)")
+ ))
+ ;; Is there a better list somewhere? Here are few
+ ;; of the top of my head.
+ "anchor" "asis"
+ "bullet"
+ "code" "copyright"
+ "defun" "deffn" "defoption" "defvar" "dfn"
+ "emph" "end"
+ "ifinfo" "iftex" "inforef" "item" "itemx"
+ "kdb"
+ "node"
+ "ref"
+ "set" "setfilename" "settitle"
+ "value" "var"
+ "xref"
+ )
+ "List of commands that we might bother completing.")
+
+(define-mode-local-override semantic-analyze-possible-completions
+ texinfo-mode (context)
+ "List smart completions at point.
+Since texinfo is not a programming language the default version is not
+useful. Insted, look at the current symbol. If it is a command
+do primitive texinfo built ins. If not, use ispell to lookup words
+that start with that symbol."
+ (let ((prefix (car (oref context :prefix)))
+ )
+ (cond ((member 'function (oref context :prefixclass))
+ ;; Do completion for texinfo commands
+ (let* ((cmd (substring prefix 1))
+ (lst (all-completions
+ cmd semantic-texi-command-completion-list)))
+ (mapcar (lambda (f) (semantic-tag (concat "@" f) 'function))
+ lst))
+ )
+ ((member 'word (oref context :prefixclass))
+ ;; Do completion for words via ispell.
+ (require 'ispell)
+ (let ((word-list (lookup-words prefix)))
+ (mapcar (lambda (f) (semantic-tag f 'word)) word-list))
+ )
+ (t nil))
+ ))
+
+
+;;; Parser Setup
+;;
+(defun semantic-default-texi-setup ()
+ "Set up a buffer for parsing of Texinfo files."
+ ;; This will use our parser.
+ (semantic-install-function-overrides
+ '((parse-region . semantic-texi-parse-region)
+ (parse-changes . semantic-texi-parse-changes)))
+ (setq semantic-parser-name "TEXI"
+ ;; Setup a dummy parser table to enable parsing!
+ semantic--parse-table t
+ imenu-create-index-function 'semantic-create-imenu-index
+ semantic-command-separation-character "@"
+ semantic-type-relation-separator-character '(":")
+ semantic-symbol->name-assoc-list '((section . "Section")
+ (def . "Definition")
+ )
+ semantic-imenu-expandable-tag-classes '(section)
+ semantic-imenu-bucketize-file nil
+ semantic-imenu-bucketize-type-members nil
+ senator-step-at-start-end-tag-classes '(section)
+ semantic-stickyfunc-sticky-classes '(section)
+ )
+ ;; (local-set-key [(f9)] 'semantic-texi-update-doc-from-texi)
+ )
+
+(add-hook 'texinfo-mode-hook 'semantic-default-texi-setup)
+
+
+;;; Special features of Texinfo tag streams
+;;
+;; This section provides specialized access into texinfo files.
+;; Because texinfo files often directly refer to functions and programs
+;; it is useful to access the texinfo file from the C code for document
+;; maintainance.
+(defun semantic-texi-associated-files (&optional buffer)
+ "Find texinfo files associated with BUFFER."
+ (save-excursion
+ (if buffer (set-buffer buffer))
+ (cond ((and (fboundp 'ede-documentation-files)
+ ede-minor-mode (ede-current-project))
+ ;; When EDE is active, ask it.
+ (ede-documentation-files)
+ )
+ ((and (featurep 'semantic/db) (semanticdb-minor-mode-p))
+ ;; See what texinfo files we have loaded in the database
+ (let ((tabs (semanticdb-get-database-tables
+ semanticdb-current-database))
+ (r nil))
+ (while tabs
+ (if (eq (oref (car tabs) major-mode) 'texinfo-mode)
+ (setq r (cons (oref (car tabs) file) r)))
+ (setq tabs (cdr tabs)))
+ r))
+ (t
+ (directory-files default-directory nil "\\.texi$"))
+ )))
+
+;; Turns out this might not be useful.
+;; Delete later if that is true.
+(defun semantic-texi-find-documentation (name &optional type)
+ "Find the function or variable NAME of TYPE in the texinfo source.
+NAME is a string representing some functional symbol.
+TYPE is a string, such as \"variable\" or \"Command\" used to find
+the correct definition in case NAME qualifies as several things.
+When this function exists, POINT is at the definition.
+If the doc was not found, an error is thrown.
+Note: TYPE not yet implemented."
+ (let ((f (semantic-texi-associated-files))
+ stream match)
+ (while (and f (not match))
+ (unless stream
+ (with-current-buffer (find-file-noselect (car f))
+ (setq stream (semantic-fetch-tags))))
+ (setq match (semantic-find-first-tag-by-name name stream))
+ (when match
+ (set-buffer (semantic-tag-buffer match))
+ (goto-char (semantic-tag-start match)))
+ (setq f (cdr f)))))
+
+;; (defun semantic-texi-update-doc-from-texi (&optional tag)
+;; "Update the documentation in the texinfo deffn class tag TAG.
+;; The current buffer must be a texinfo file containing TAG.
+;; If TAG is nil, determine a tag based on the current position."
+;; (interactive)
+;; (unless (or (featurep 'semantic/db)
+;; (require 'semantic/db-mode)
+;; (semanticdb-minor-mode-p))
+;; (error "Texinfo updating only works when `semanticdb' is being used"))
+;; (semantic-fetch-tags)
+;; (unless tag
+;; (beginning-of-line)
+;; (setq tag (semantic-current-tag)))
+;; (unless (semantic-tag-of-class-p tag 'def)
+;; (error "Only deffns (or defun or defvar) can be updated"))
+;; (let* ((name (semantic-tag-name tag))
+;; (tags (semanticdb-strip-find-results
+;; (semanticdb-with-match-any-mode
+;; (semanticdb-brute-deep-find-tags-by-name name))
+;; 'name))
+;; (docstring nil)
+;; (docstringproto nil)
+;; (docstringvar nil)
+;; (doctag nil)
+;; (doctagproto nil)
+;; (doctagvar nil)
+;; )
+;; (save-excursion
+;; (while (and tags (not docstring))
+;; (let ((sourcetag (car tags)))
+;; ;; There could be more than one! Come up with a better
+;; ;; solution someday.
+;; (when (semantic-tag-buffer sourcetag)
+;; (set-buffer (semantic-tag-buffer sourcetag))
+;; (unless (eq major-mode 'texinfo-mode)
+;; (cond ((semantic-tag-get-attribute sourcetag :prototype-flag)
+;; ;; If we found a match with doc that is a prototype, then
store
+;; ;; that, but don't exit till we find the real deal.
+;; (setq docstringproto (semantic-documentation-for-tag
sourcetag)
+;; doctagproto sourcetag))
+;; ((eq (semantic-tag-class sourcetag) 'variable)
+;; (setq docstringvar (semantic-documentation-for-tag sourcetag)
+;; doctagvar sourcetag))
+;; ((semantic-tag-get-attribute sourcetag
:override-function-flag)
+;; nil)
+;; (t
+;; (setq docstring (semantic-documentation-for-tag sourcetag))))
+;; (setq doctag (if docstring sourcetag nil))))
+;; (setq tags (cdr tags)))))
+;; ;; If we found a prototype of the function that has some doc, but not
the
+;; ;; actual function, lets make due with that.
+;; (if (not docstring)
+;; (cond ((stringp docstringvar)
+;; (setq docstring docstringvar
+;; doctag doctagvar))
+;; ((stringp docstringproto)
+;; (setq docstring docstringproto
+;; doctag doctagproto))))
+;; ;; Test for doc string
+;; (unless docstring
+;; (error "Could not find documentation for %s" (semantic-tag-name tag)))
+;; ;; If we have a string, do the replacement.
+;; (delete-region (semantic-tag-start tag)
+;; (semantic-tag-end tag))
+;; ;; Use useful functions from the docaument library.
+;; (require 'document)
+;; (document-insert-texinfo doctag (semantic-tag-buffer doctag))
+;; ))
+
+;; (defun semantic-texi-update-doc-from-source (&optional tag)
+;; "Update the documentation for the source TAG.
+;; The current buffer must be a non-texinfo source file containing TAG.
+;; If TAG is nil, determine the tag based on the current position.
+;; The current buffer must include TAG."
+;; (interactive)
+;; (when (eq major-mode 'texinfo-mode)
+;; (error "Not a source file"))
+;; (semantic-fetch-tags)
+;; (unless tag
+;; (setq tag (semantic-current-tag)))
+;; (unless (semantic-documentation-for-tag tag)
+;; (error "Cannot find interesting documentation to use for %s"
+;; (semantic-tag-name tag)))
+;; (let* ((name (semantic-tag-name tag))
+;; (texi (semantic-texi-associated-files))
+;; (doctag nil)
+;; (docbuff nil))
+;; (while (and texi (not doctag))
+;; (set-buffer (find-file-noselect (car texi)))
+;; (setq doctag (car (semantic-deep-find-tags-by-name
+;; name (semantic-fetch-tags)))
+;; docbuff (if doctag (current-buffer) nil))
+;; (setq texi (cdr texi)))
+;; (unless doctag
+;; (error "Tag %s is not yet documented. Use the `document' command"
+;; name))
+;; ;; Ok, we should have everything we need. Do the deed.
+;; (if (get-buffer-window docbuff)
+;; (set-buffer docbuff)
+;; (switch-to-buffer docbuff))
+;; (goto-char (semantic-tag-start doctag))
+;; (delete-region (semantic-tag-start doctag)
+;; (semantic-tag-end doctag))
+;; ;; Use useful functions from the document library.
+;; (require 'document)
+;; (document-insert-texinfo tag (semantic-tag-buffer tag))
+;; ))
+
+;; (defun semantic-texi-update-doc (&optional tag)
+;; "Update the documentation for TAG.
+;; If the current buffer is a texinfo file, then find the source doc, and
+;; update it. If the current buffer is a source file, then get the
+;; documentation for this item, find the existing doc in the associated
+;; manual, and update that."
+;; (interactive)
+;; (cond ;;((eq major-mode 'texinfo-mode)
+;; ;; (semantic-texi-update-doc-from-texi tag))
+;; (t
+;; (semantic-texi-update-doc-from-source tag))))
+
+(defun semantic-texi-goto-source (&optional tag)
+ "Jump to the source for the definition in the texinfo file TAG.
+If TAG is nil, it is derived from the deffn under POINT."
+ (interactive)
+ (unless (or (featurep 'semantic/db) (semanticdb-minor-mode-p))
+ (error "Texinfo updating only works when `semanticdb' is being used"))
+ (semantic-fetch-tags)
+ (unless tag
+ (beginning-of-line)
+ (setq tag (semantic-current-tag)))
+ (unless (semantic-tag-of-class-p tag 'def)
+ (error "Only deffns (or defun or defvar) can be updated"))
+ (let* ((name (semantic-tag-name tag))
+ (tags (semanticdb-fast-strip-find-results
+ (semanticdb-with-match-any-mode
+ (semanticdb-brute-deep-find-tags-by-name name nil 'name))
+ ))
+
+ (done nil)
+ )
+ (save-excursion
+ (while (and tags (not done))
+ (set-buffer (semantic-tag-buffer (car tags)))
+ (unless (eq major-mode 'texinfo-mode)
+ (switch-to-buffer (semantic-tag-buffer (car tags)))
+ (goto-char (semantic-tag-start (car tags)))
+ (setq done t))
+ (setq tags (cdr tags)))
+ (if (not done)
+ (error "Could not find tag for %s" (semantic-tag-name tag)))
+ )))
+
+(provide 'semantic/texi)
+
+;;; semantic/texi.el ends here
Index: cedet/semantic/util-modes.el
===================================================================
RCS file: cedet/semantic/util-modes.el
diff -N cedet/semantic/util-modes.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/util-modes.el 28 Sep 2009 15:15:10 -0000 1.2
@@ -0,0 +1,1237 @@
+;;; semantic/util-modes.el --- Semantic minor modes
+
+;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009
+;;; Free Software Foundation, Inc.
+
+;; Authors: Eric M. Ludlam <address@hidden>
+;; David Ponce <address@hidden>
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Semantic utility minor modes.
+;;
+
+;;; Code:
+(require 'semantic)
+
+;;; Group for all semantic enhancing modes
+(defgroup semantic-modes nil
+ "Minor modes associated with the Semantic architecture."
+ :group 'semantic)
+
+;;;;
+;;;; Semantic minor modes stuff
+;;;;
+(defcustom semantic-update-mode-line t
+ "If non-nil, show enabled minor modes in the mode line.
+Only minor modes that are not turned on globally are shown in the mode
+line."
+ :group 'semantic
+ :type 'boolean
+ :require 'semantic/util-modes
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (set-default sym val)
+ ;; Update status of all Semantic enabled buffers
+ (semantic-map-buffers
+ #'semantic-mode-line-update)))
+
+(defcustom semantic-mode-line-prefix
+ (propertize "S" 'face 'bold)
+ "Prefix added to minor mode indicators in the mode line."
+ :group 'semantic
+ :type 'string
+ :require 'semantic/util-modes
+ :initialize 'custom-initialize-default)
+
+(defvar semantic-minor-modes-status nil
+ "String showing Semantic minor modes which are locally enabled.
+It is displayed in the mode line.")
+(make-variable-buffer-local 'semantic-minor-modes-status)
+
+(defvar semantic-minor-mode-alist nil
+ "Alist saying how to show Semantic minor modes in the mode line.
+Like variable `minor-mode-alist'.")
+
+(defun semantic-mode-line-update ()
+ "Update display of Semantic minor modes in the mode line.
+Only minor modes that are locally enabled are shown in the mode line."
+ (setq semantic-minor-modes-status nil)
+ (if semantic-update-mode-line
+ (let ((ml semantic-minor-mode-alist)
+ mm ms see)
+ (while ml
+ (setq mm (car ml)
+ ms (cadr mm)
+ mm (car mm)
+ ml (cdr ml))
+ (when (and (symbol-value mm)
+ ;; Only show local minor mode status
+ (not (memq mm semantic-init-hook)))
+ (and ms
+ (symbolp ms)
+ (setq ms (symbol-value ms)))
+ (and (stringp ms)
+ (not (member ms see)) ;; Don't duplicate same status
+ (setq see (cons ms see)
+ ms (if (string-match "^[ ]*\\(.+\\)" ms)
+ (match-string 1 ms)))
+ (setq semantic-minor-modes-status
+ (if semantic-minor-modes-status
+ (concat semantic-minor-modes-status "/" ms)
+ ms)))))
+ (if semantic-minor-modes-status
+ (setq semantic-minor-modes-status
+ (concat
+ " "
+ (if (string-match "^[ ]*\\(.+\\)"
+ semantic-mode-line-prefix)
+ (match-string 1 semantic-mode-line-prefix)
+ "S")
+ "/"
+ semantic-minor-modes-status))))))
+
+(defun semantic-desktop-ignore-this-minor-mode (buffer)
+ "Installed as a minor-mode initializer for Desktop mode.
+BUFFER is the buffer to not initialize a Semantic minor mode in."
+ nil)
+
+(defun semantic-add-minor-mode (toggle name &optional keymap)
+ "Register a new Semantic minor mode.
+TOGGLE is a symbol which is the name of a buffer-local variable that
+is toggled on or off to say whether the minor mode is active or not.
+It is also an interactive function to toggle the mode.
+
+NAME specifies what will appear in the mode line when the minor mode
+is active. NAME should be either a string starting with a space, or a
+symbol whose value is such a string.
+
+Optional KEYMAP is the keymap for the minor mode that will be added to
+`minor-mode-map-alist'."
+ ;; Add a dymmy semantic minor mode to display the status
+ (or (assq 'semantic-minor-modes-status minor-mode-alist)
+ (setq minor-mode-alist (cons (list 'semantic-minor-modes-status
+ 'semantic-minor-modes-status)
+ minor-mode-alist)))
+ (if (fboundp 'add-minor-mode)
+ ;; Emacs 21 & XEmacs
+ (add-minor-mode toggle "" keymap)
+ ;; Emacs 20
+ (or (assq toggle minor-mode-alist)
+ (setq minor-mode-alist (cons (list toggle "") minor-mode-alist)))
+ (or (not keymap)
+ (assq toggle minor-mode-map-alist)
+ (setq minor-mode-map-alist (cons (cons toggle keymap)
+ minor-mode-map-alist))))
+ ;; Record how to display this minor mode in the mode line
+ (let ((mm (assq toggle semantic-minor-mode-alist)))
+ (if mm
+ (setcdr mm (list name))
+ (setq semantic-minor-mode-alist (cons (list toggle name)
+ semantic-minor-mode-alist))))
+
+ ;; Semantic minor modes don't work w/ Desktop restore.
+ ;; This line will disable this minor mode from being restored
+ ;; by Desktop.
+ (when (boundp 'desktop-minor-mode-handlers)
+ (add-to-list 'desktop-minor-mode-handlers
+ (cons toggle 'semantic-desktop-ignore-this-minor-mode)))
+ )
+
+(defun semantic-toggle-minor-mode-globally (mode &optional arg)
+ "Toggle minor mode MODE in every Semantic enabled buffer.
+Return non-nil if MODE is turned on in every Semantic enabled buffer.
+If ARG is positive, enable, if it is negative, disable. If ARG is
+nil, then toggle. Otherwise do nothing. MODE must be a valid minor
+mode defined in `minor-mode-alist' and must be too an interactive
+function used to toggle the mode."
+ (or (and (fboundp mode) (assq mode minor-mode-alist))
+ (error "Semantic minor mode %s not found" mode))
+ (if (not arg)
+ (if (memq mode semantic-init-hook)
+ (setq arg -1)
+ (setq arg 1)))
+ ;; Add or remove the MODE toggle function from
+ ;; `semantic-init-hook'. Then turn MODE on or off in every
+ ;; Semantic enabled buffer.
+ (cond
+ ;; Turn off if ARG < 0
+ ((< arg 0)
+ (remove-hook 'semantic-init-hook mode)
+ (semantic-map-buffers #'(lambda () (funcall mode -1)))
+ nil)
+ ;; Turn on if ARG > 0
+ ((> arg 0)
+ (add-hook 'semantic-init-hook mode)
+ (semantic-map-buffers #'(lambda () (funcall mode 1)))
+ t)
+ ;; Otherwise just check MODE state
+ (t
+ (memq mode semantic-init-hook))
+ ))
+
+;;;;
+;;;; Minor mode to highlight areas that a user edits.
+;;;;
+
+;;;###autoload
+(defun global-semantic-highlight-edits-mode (&optional arg)
+ "Toggle global use of option `semantic-highlight-edits-mode'.
+If ARG is positive, enable, if it is negative, disable.
+If ARG is nil, then toggle."
+ (interactive "P")
+ (setq global-semantic-highlight-edits-mode
+ (semantic-toggle-minor-mode-globally
+ 'semantic-highlight-edits-mode arg)))
+
+;;;###autoload
+(defcustom global-semantic-highlight-edits-mode nil
+ "If non-nil enable global use of variable `semantic-highlight-edits-mode'.
+When this mode is enabled, changes made to a buffer are highlighted
+until the buffer is reparsed."
+ :group 'semantic
+ :group 'semantic-modes
+ :type 'boolean
+ :require 'semantic/util-modes
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (global-semantic-highlight-edits-mode (if val 1 -1))))
+
+(defcustom semantic-highlight-edits-mode-hook nil
+ "Hook run at the end of function `semantic-highlight-edits-mode'."
+ :group 'semantic
+ :type 'hook)
+
+(defface semantic-highlight-edits-face
+ '((((class color) (background dark))
+ ;; Put this back to something closer to black later.
+ (:background "gray20"))
+ (((class color) (background light))
+ (:background "gray90")))
+ "Face used to show dirty tokens in `semantic-highlight-edits-mode'."
+ :group 'semantic-faces)
+
+(defun semantic-highlight-edits-new-change-hook-fcn (overlay)
+ "Function set into `semantic-edits-new-change-hook'.
+Argument OVERLAY is the overlay created to mark the change.
+This function will set the face property on this overlay."
+ (semantic-overlay-put overlay 'face 'semantic-highlight-edits-face))
+
+(defvar semantic-highlight-edits-mode-map
+ (let ((km (make-sparse-keymap)))
+ km)
+ "Keymap for highlight-edits minor mode.")
+
+(defvar semantic-highlight-edits-mode nil
+ "Non-nil if highlight-edits minor mode is enabled.
+Use the command `semantic-highlight-edits-mode' to change this variable.")
+(make-variable-buffer-local 'semantic-highlight-edits-mode)
+
+(defun semantic-highlight-edits-mode-setup ()
+ "Setup option `semantic-highlight-edits-mode'.
+The minor mode can be turned on only if semantic feature is available
+and the current buffer was set up for parsing. When minor mode is
+enabled parse the current buffer if needed. Return non-nil if the
+minor mode is enabled."
+ (if semantic-highlight-edits-mode
+ (if (not (and (featurep 'semantic) (semantic-active-p)))
+ (progn
+ ;; Disable minor mode if semantic stuff not available
+ (setq semantic-highlight-edits-mode nil)
+ (error "Buffer %s was not set up for parsing"
+ (buffer-name)))
+ (semantic-make-local-hook 'semantic-edits-new-change-hooks)
+ (add-hook 'semantic-edits-new-change-hooks
+ 'semantic-highlight-edits-new-change-hook-fcn nil t)
+ )
+ ;; Remove hooks
+ (remove-hook 'semantic-edits-new-change-hooks
+ 'semantic-highlight-edits-new-change-hook-fcn t)
+ )
+ semantic-highlight-edits-mode)
+
+;;;###autoload
+(defun semantic-highlight-edits-mode (&optional arg)
+ "Minor mode for highlighting changes made in a buffer.
+Changes are tracked by semantic so that the incremental parser can work
+properly.
+This mode will highlight those changes as they are made, and clear them
+when the incremental parser accounts for those edits.
+With prefix argument ARG, turn on if positive, otherwise off. The
+minor mode can be turned on only if semantic feature is available and
+the current buffer was set up for parsing. Return non-nil if the
+minor mode is enabled."
+ (interactive
+ (list (or current-prefix-arg
+ (if semantic-highlight-edits-mode 0 1))))
+ (setq semantic-highlight-edits-mode
+ (if arg
+ (>
+ (prefix-numeric-value arg)
+ 0)
+ (not semantic-highlight-edits-mode)))
+ (semantic-highlight-edits-mode-setup)
+ (run-hooks 'semantic-highlight-edits-mode-hook)
+ (if (interactive-p)
+ (message "highlight-edits minor mode %sabled"
+ (if semantic-highlight-edits-mode "en" "dis")))
+ (semantic-mode-line-update)
+ semantic-highlight-edits-mode)
+
+(semantic-add-minor-mode 'semantic-highlight-edits-mode
+ "e"
+ semantic-highlight-edits-mode-map)
+
+
+;;;;
+;;;; Minor mode to show unmatched-syntax elements
+;;;;
+
+;;;###autoload
+(defun global-semantic-show-unmatched-syntax-mode (&optional arg)
+ "Toggle global use of option `semantic-show-unmatched-syntax-mode'.
+If ARG is positive, enable, if it is negative, disable.
+If ARG is nil, then toggle."
+ (interactive "P")
+ (setq global-semantic-show-unmatched-syntax-mode
+ (semantic-toggle-minor-mode-globally
+ 'semantic-show-unmatched-syntax-mode arg)))
+
+;;;###autoload
+(defcustom global-semantic-show-unmatched-syntax-mode nil
+ "If non-nil, enable global use of `semantic-show-unmatched-syntax-mode'.
+When this mode is enabled, syntax in the current buffer which the
+semantic parser cannot match is highlighted with a red underline."
+ :group 'semantic
+ :group 'semantic-modes
+ :type 'boolean
+ :require 'semantic/util-modes
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (global-semantic-show-unmatched-syntax-mode (if val 1 -1))))
+
+(defcustom semantic-show-unmatched-syntax-mode-hook nil
+ "Hook run at the end of function `semantic-show-unmatched-syntax-mode'."
+ :group 'semantic
+ :type 'hook)
+
+(defface semantic-unmatched-syntax-face
+ '((((class color) (background dark))
+ (:underline "red"))
+ (((class color) (background light))
+ (:underline "red")))
+ "Face used to show unmatched syntax in.
+The face is used in `semantic-show-unmatched-syntax-mode'."
+ :group 'semantic-faces)
+
+(defsubst semantic-unmatched-syntax-overlay-p (overlay)
+ "Return non-nil if OVERLAY is an unmatched syntax one."
+ (eq (semantic-overlay-get overlay 'semantic) 'unmatched))
+
+(defun semantic-showing-unmatched-syntax-p ()
+ "Return non-nil if an unmatched syntax overlay was found in buffer."
+ (let ((ol (semantic-overlays-in (point-min) (point-max)))
+ found)
+ (while (and ol (not found))
+ (setq found (semantic-unmatched-syntax-overlay-p (car ol))
+ ol (cdr ol)))
+ found))
+
+(defun semantic-show-unmatched-lex-tokens-fetch ()
+ "Fetch a list of unmatched lexical tokens from the current buffer.
+Uses the overlays which have accurate bounds, and rebuilds what was
+originally passed in."
+ (let ((ol (semantic-overlays-in (point-min) (point-max)))
+ (ustc nil))
+ (while ol
+ (if (semantic-unmatched-syntax-overlay-p (car ol))
+ (setq ustc (cons (cons 'thing
+ (cons (semantic-overlay-start (car ol))
+ (semantic-overlay-end (car ol))))
+ ustc)))
+ (setq ol (cdr ol)))
+ (nreverse ustc))
+ )
+
+(defun semantic-clean-unmatched-syntax-in-region (beg end)
+ "Remove all unmatched syntax overlays between BEG and END."
+ (let ((ol (semantic-overlays-in beg end)))
+ (while ol
+ (if (semantic-unmatched-syntax-overlay-p (car ol))
+ (semantic-overlay-delete (car ol)))
+ (setq ol (cdr ol)))))
+
+(defsubst semantic-clean-unmatched-syntax-in-buffer ()
+ "Remove all unmatched syntax overlays found in current buffer."
+ (semantic-clean-unmatched-syntax-in-region
+ (point-min) (point-max)))
+
+(defsubst semantic-clean-token-of-unmatched-syntax (token)
+ "Clean the area covered by TOKEN of unmatched syntax markers."
+ (semantic-clean-unmatched-syntax-in-region
+ (semantic-tag-start token) (semantic-tag-end token)))
+
+(defun semantic-show-unmatched-syntax (syntax)
+ "Function set into `semantic-unmatched-syntax-hook'.
+This will highlight elements in SYNTAX as unmatched syntax."
+ ;; This is called when `semantic-show-unmatched-syntax-mode' is
+ ;; enabled. Highlight the unmatched syntax, and then add a semantic
+ ;; property to that overlay so we can add it to the official list of
+ ;; semantic supported overlays. This gets it cleaned up for errors,
+ ;; buffer cleaning, and the like.
+ (semantic-clean-unmatched-syntax-in-buffer) ;Clear previous highlighting
+ (if syntax
+ (let (o)
+ (while syntax
+ (setq o (semantic-make-overlay (semantic-lex-token-start (car
syntax))
+ (semantic-lex-token-end (car
syntax))))
+ (semantic-overlay-put o 'semantic 'unmatched)
+ (semantic-overlay-put o 'face 'semantic-unmatched-syntax-face)
+ (setq syntax (cdr syntax))))
+ ))
+
+(defun semantic-next-unmatched-syntax (point &optional bound)
+ "Find the next overlay for unmatched syntax after POINT.
+Do not search past BOUND if non-nil."
+ (save-excursion
+ (goto-char point)
+ (let ((os point) (ol nil))
+ (while (and os (< os (or bound (point-max))) (not ol))
+ (setq os (semantic-overlay-next-change os))
+ (when os
+ ;; Get overlays at position
+ (setq ol (semantic-overlays-at os))
+ ;; find the overlay that belongs to semantic
+ ;; and starts at the found position.
+ (while (and ol (listp ol))
+ (and (semantic-unmatched-syntax-overlay-p (car ol))
+ (setq ol (car ol)))
+ (if (listp ol)
+ (setq ol (cdr ol))))))
+ ol)))
+
+(defvar semantic-show-unmatched-syntax-mode-map
+ (let ((km (make-sparse-keymap)))
+ (define-key km "\C-c,`" 'semantic-show-unmatched-syntax-next)
+ km)
+ "Keymap for command `semantic-show-unmatched-syntax-mode'.")
+
+(defvar semantic-show-unmatched-syntax-mode nil
+ "Non-nil if show-unmatched-syntax minor mode is enabled.
+Use the command `semantic-show-unmatched-syntax-mode' to change this
+variable.")
+(make-variable-buffer-local 'semantic-show-unmatched-syntax-mode)
+
+(defun semantic-show-unmatched-syntax-mode-setup ()
+ "Setup the `semantic-show-unmatched-syntax' minor mode.
+The minor mode can be turned on only if semantic feature is available
+and the current buffer was set up for parsing. When minor mode is
+enabled parse the current buffer if needed. Return non-nil if the
+minor mode is enabled."
+ (if semantic-show-unmatched-syntax-mode
+ (if (not (and (featurep 'semantic) (semantic-active-p)))
+ (progn
+ ;; Disable minor mode if semantic stuff not available
+ (setq semantic-show-unmatched-syntax-mode nil)
+ (error "Buffer %s was not set up for parsing"
+ (buffer-name)))
+ ;; Add hooks
+ (semantic-make-local-hook 'semantic-unmatched-syntax-hook)
+ (add-hook 'semantic-unmatched-syntax-hook
+ 'semantic-show-unmatched-syntax nil t)
+ (semantic-make-local-hook 'semantic-pre-clean-token-hooks)
+ (add-hook 'semantic-pre-clean-token-hooks
+ 'semantic-clean-token-of-unmatched-syntax nil t)
+ ;; Show unmatched syntax elements
+ (if (not (semantic--umatched-syntax-needs-refresh-p))
+ (semantic-show-unmatched-syntax
+ (semantic-unmatched-syntax-tokens))))
+ ;; Remove hooks
+ (remove-hook 'semantic-unmatched-syntax-hook
+ 'semantic-show-unmatched-syntax t)
+ (remove-hook 'semantic-pre-clean-token-hooks
+ 'semantic-clean-token-of-unmatched-syntax t)
+ ;; Cleanup unmatched-syntax highlighting
+ (semantic-clean-unmatched-syntax-in-buffer))
+ semantic-show-unmatched-syntax-mode)
+
+;;;###autoload
+(defun semantic-show-unmatched-syntax-mode (&optional arg)
+ "Minor mode to highlight unmatched lexical syntax tokens.
+When a parser executes, some elements in the buffer may not match any
+parser rules. These text characters are considered unmatched syntax.
+Often time, the display of unmatched syntax can expose coding
+problems before the compiler is run.
+
+With prefix argument ARG, turn on if positive, otherwise off. The
+minor mode can be turned on only if semantic feature is available and
+the current buffer was set up for parsing. Return non-nil if the
+minor mode is enabled.
+
+\\{semantic-show-unmatched-syntax-mode-map}"
+ (interactive
+ (list (or current-prefix-arg
+ (if semantic-show-unmatched-syntax-mode 0 1))))
+ (setq semantic-show-unmatched-syntax-mode
+ (if arg
+ (>
+ (prefix-numeric-value arg)
+ 0)
+ (not semantic-show-unmatched-syntax-mode)))
+ (semantic-show-unmatched-syntax-mode-setup)
+ (run-hooks 'semantic-show-unmatched-syntax-mode-hook)
+ (if (interactive-p)
+ (message "show-unmatched-syntax minor mode %sabled"
+ (if semantic-show-unmatched-syntax-mode "en" "dis")))
+ (semantic-mode-line-update)
+ semantic-show-unmatched-syntax-mode)
+
+(semantic-add-minor-mode 'semantic-show-unmatched-syntax-mode
+ "u"
+ semantic-show-unmatched-syntax-mode-map)
+
+(defun semantic-show-unmatched-syntax-next ()
+ "Move forward to the next occurrence of unmatched syntax."
+ (interactive)
+ (let ((o (semantic-next-unmatched-syntax (point))))
+ (if o
+ (goto-char (semantic-overlay-start o)))))
+
+
+;;;;
+;;;; Minor mode to display the parser state in the modeline.
+;;;;
+
+;;;###autoload
+(defcustom global-semantic-show-parser-state-mode nil
+ "If non-nil enable global use of `semantic-show-parser-state-mode'.
+When enabled, the current parse state of the current buffer is displayed
+in the mode line. See `semantic-show-parser-state-marker' for details
+on what is displayed."
+ :group 'semantic
+ :type 'boolean
+ :require 'semantic/util-modes
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (global-semantic-show-parser-state-mode (if val 1 -1))))
+
+;;;###autoload
+(defun global-semantic-show-parser-state-mode (&optional arg)
+ "Toggle global use of option `semantic-show-parser-state-mode'.
+If ARG is positive, enable, if it is negative, disable.
+If ARG is nil, then toggle."
+ (interactive "P")
+ (setq global-semantic-show-parser-state-mode
+ (semantic-toggle-minor-mode-globally
+ 'semantic-show-parser-state-mode arg)))
+
+(defcustom semantic-show-parser-state-mode-hook nil
+ "Hook run at the end of function `semantic-show-parser-state-mode'."
+ :group 'semantic
+ :type 'hook)
+
+(defvar semantic-show-parser-state-mode-map
+ (let ((km (make-sparse-keymap)))
+ km)
+ "Keymap for show-parser-state minor mode.")
+
+(defvar semantic-show-parser-state-mode nil
+ "Non-nil if show-parser-state minor mode is enabled.
+Use the command `semantic-show-parser-state-mode' to change this variable.")
+(make-variable-buffer-local 'semantic-show-parser-state-mode)
+
+(defun semantic-show-parser-state-mode-setup ()
+ "Setup option `semantic-show-parser-state-mode'.
+The minor mode can be turned on only if semantic feature is available
+and the current buffer was set up for parsing. When minor mode is
+enabled parse the current buffer if needed. Return non-nil if the
+minor mode is enabled."
+ (if semantic-show-parser-state-mode
+ (if (not (and (featurep 'semantic) (semantic-active-p)))
+ (progn
+ ;; Disable minor mode if semantic stuff not available
+ (setq semantic-show-parser-state-mode nil)
+ (error "Buffer %s was not set up for parsing"
+ (buffer-name)))
+ ;; Set up mode line
+
+ (when (not
+ (memq 'semantic-show-parser-state-string mode-line-modified))
+ (setq mode-line-modified
+ (append mode-line-modified
+ '(semantic-show-parser-state-string))))
+ ;; Add hooks
+ (semantic-make-local-hook 'semantic-edits-new-change-hooks)
+ (add-hook 'semantic-edits-new-change-hooks
+ 'semantic-show-parser-state-marker nil t)
+ (semantic-make-local-hook
'semantic-edits-incremental-reparse-failed-hook)
+ (add-hook 'semantic-edits-incremental-reparse-failed-hook
+ 'semantic-show-parser-state-marker nil t)
+ (semantic-make-local-hook 'semantic-after-partial-cache-change-hook)
+ (add-hook 'semantic-after-partial-cache-change-hook
+ 'semantic-show-parser-state-marker nil t)
+ (semantic-make-local-hook 'semantic-after-toplevel-cache-change-hook)
+ (add-hook 'semantic-after-toplevel-cache-change-hook
+ 'semantic-show-parser-state-marker nil t)
+ (semantic-show-parser-state-marker)
+
+ (semantic-make-local-hook 'semantic-before-auto-parse-hooks)
+ (add-hook 'semantic-before-auto-parse-hooks
+ 'semantic-show-parser-state-auto-marker nil t)
+ (semantic-make-local-hook 'semantic-after-auto-parse-hooks)
+ (add-hook 'semantic-after-auto-parse-hooks
+ 'semantic-show-parser-state-marker nil t)
+
+ (semantic-make-local-hook 'semantic-before-idle-scheduler-reparse-hook)
+ (add-hook 'semantic-before-idle-scheduler-reparse-hook
+ 'semantic-show-parser-state-auto-marker nil t)
+ (semantic-make-local-hook 'semantic-after-idle-scheduler-reparse-hook)
+ (add-hook 'semantic-after-idle-scheduler-reparse-hook
+ 'semantic-show-parser-state-marker nil t)
+ )
+ ;; Remove parts of mode line
+ (setq mode-line-modified
+ (delq 'semantic-show-parser-state-string mode-line-modified))
+ ;; Remove hooks
+ (remove-hook 'semantic-edits-new-change-hooks
+ 'semantic-show-parser-state-marker t)
+ (remove-hook 'semantic-edits-incremental-reparse-failed-hook
+ 'semantic-show-parser-state-marker t)
+ (remove-hook 'semantic-after-partial-cache-change-hook
+ 'semantic-show-parser-state-marker t)
+ (remove-hook 'semantic-after-toplevel-cache-change-hook
+ 'semantic-show-parser-state-marker t)
+
+ (remove-hook 'semantic-before-auto-parse-hooks
+ 'semantic-show-parser-state-auto-marker t)
+ (remove-hook 'semantic-after-auto-parse-hooks
+ 'semantic-show-parser-state-marker t)
+
+ (remove-hook 'semantic-before-idle-scheduler-reparse-hook
+ 'semantic-show-parser-state-auto-marker t)
+ (remove-hook 'semantic-after-idle-scheduler-reparse-hook
+ 'semantic-show-parser-state-marker t)
+ )
+ semantic-show-parser-state-mode)
+
+;;;###autoload
+(defun semantic-show-parser-state-mode (&optional arg)
+ "Minor mode for displaying parser cache state in the modeline.
+The cache can be in one of three states. They are
+Up to date, Partial reprase needed, and Full reparse needed.
+The state is indicated in the modeline with the following characters:
+ `-' -> The cache is up to date.
+ `!' -> The cache requires a full update.
+ `~' -> The cache needs to be incrementally parsed.
+ `%' -> The cache is not currently parseable.
+ `@' -> Auto-parse in progress (not set here.)
+With prefix argument ARG, turn on if positive, otherwise off. The
+minor mode can be turned on only if semantic feature is available and
+the current buffer was set up for parsing. Return non-nil if the
+minor mode is enabled."
+ (interactive
+ (list (or current-prefix-arg
+ (if semantic-show-parser-state-mode 0 1))))
+ (setq semantic-show-parser-state-mode
+ (if arg
+ (>
+ (prefix-numeric-value arg)
+ 0)
+ (not semantic-show-parser-state-mode)))
+ (semantic-show-parser-state-mode-setup)
+ (run-hooks 'semantic-show-parser-state-mode-hook)
+ (if (interactive-p)
+ (message "show-parser-state minor mode %sabled"
+ (if semantic-show-parser-state-mode "en" "dis")))
+ (semantic-mode-line-update)
+ semantic-show-parser-state-mode)
+
+(semantic-add-minor-mode 'semantic-show-parser-state-mode
+ ""
+ semantic-show-parser-state-mode-map)
+
+(defvar semantic-show-parser-state-string nil
+ "String showing the parser state for this buffer.
+See `semantic-show-parser-state-marker' for details.")
+(make-variable-buffer-local 'semantic-show-parser-state-string)
+
+(defun semantic-show-parser-state-marker (&rest ignore)
+ "Set `semantic-show-parser-state-string' to indicate parser state.
+This marker is one of the following:
+ `-' -> The cache is up to date.
+ `!' -> The cache requires a full update.
+ `~' -> The cache needs to be incrementally parsed.
+ `%' -> The cache is not currently parseable.
+ `@' -> Auto-parse in progress (not set here.)
+Arguments IGNORE are ignored, and accepted so this can be used as a hook
+in many situations."
+ (setq semantic-show-parser-state-string
+ (cond ((semantic-parse-tree-needs-rebuild-p)
+ "!")
+ ((semantic-parse-tree-needs-update-p)
+ "^")
+ ((semantic-parse-tree-unparseable-p)
+ "%")
+ (t
+ "-")))
+ ;;(message "Setup mode line indicator to [%s]"
semantic-show-parser-state-string)
+ (semantic-mode-line-update))
+
+(defun semantic-show-parser-state-auto-marker ()
+ "Hook function run before an autoparse.
+Set up `semantic-show-parser-state-marker' to show `@'
+to indicate a parse in progress."
+ (unless (semantic-parse-tree-up-to-date-p)
+ (setq semantic-show-parser-state-string "@")
+ (semantic-mode-line-update)
+ ;; For testing.
+ ;;(sit-for 1)
+ ))
+
+
+;;;;
+;;;; Minor mode to make function decls sticky.
+;;;;
+
+;;;###autoload
+(defun global-semantic-stickyfunc-mode (&optional arg)
+ "Toggle global use of option `semantic-stickyfunc-mode'.
+If ARG is positive, enable, if it is negative, disable.
+If ARG is nil, then toggle."
+ (interactive "P")
+ (setq global-semantic-stickyfunc-mode
+ (semantic-toggle-minor-mode-globally
+ 'semantic-stickyfunc-mode arg)))
+
+;;;###autoload
+(defcustom global-semantic-stickyfunc-mode nil
+ "If non-nil, enable global use of `semantic-stickyfunc-mode'.
+This minor mode only works for Emacs 21 or later.
+When enabled, the header line is enabled, and the first line
+of the current function or method is displayed in it.
+This makes it appear that the first line of that tag is
+`sticky' to the top of the window."
+ :group 'semantic
+ :group 'semantic-modes
+ :type 'boolean
+ :require 'semantic/util-modes
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (global-semantic-stickyfunc-mode (if val 1 -1))))
+
+(defcustom semantic-stickyfunc-mode-hook nil
+ "Hook run at the end of function `semantic-stickyfunc-mode'."
+ :group 'semantic
+ :type 'hook)
+
+(defvar semantic-stickyfunc-mode-map
+ (let ((km (make-sparse-keymap)))
+ (define-key km [ header-line down-mouse-1 ] 'semantic-stickyfunc-menu)
+ km)
+ "Keymap for stickyfunc minor mode.")
+
+(defvar semantic-stickyfunc-popup-menu nil
+ "Menu used if the user clicks on the header line used by stickyfunc mode.")
+
+(easy-menu-define
+ semantic-stickyfunc-popup-menu
+ semantic-stickyfunc-mode-map
+ "Stickyfunc Menu"
+ '("Stickyfunc Mode" :visible (progn nil)
+ [ "Copy Headerline Tag" senator-copy-tag
+ :active (semantic-current-tag)
+ :help "Copy the current tag to the tag ring"]
+ [ "Kill Headerline Tag" senator-kill-tag
+ :active (semantic-current-tag)
+ :help "Kill tag text to the kill ring, and copy the tag to the tag ring"
+ ]
+ [ "Copy Headerline Tag to Register" senator-copy-tag-to-register
+ :active (semantic-current-tag)
+ :help "Copy the current tag to a register"
+ ]
+ [ "Narrow To Headerline Tag" senator-narrow-to-defun
+ :active (semantic-current-tag)
+ :help "Narrow to the bounds of the current tag."]
+ [ "Fold Headerline Tag" senator-fold-tag-toggle
+ :active (semantic-current-tag)
+ :style toggle
+ :selected (let ((tag (semantic-current-tag)))
+ (and tag (semantic-tag-folded-p tag)))
+ :help "Fold the current tag to one line"
+ ]
+ "---"
+ [ "About This Header Line"
+ (lambda () (interactive)
+ (describe-function 'semantic-stickyfunc-mode)) t])
+ )
+
+(defvar semantic-stickyfunc-mode nil
+ "Non-nil if stickyfunc minor mode is enabled.
+Use the command `semantic-stickyfunc-mode' to change this variable.")
+(make-variable-buffer-local 'semantic-stickyfunc-mode)
+
+(defcustom semantic-stickyfunc-indent-string
+ (if (and window-system (not (featurep 'xemacs)))
+ (concat
+ (condition-case nil
+ ;; Test scroll bar location
+ (let ((charwidth (frame-char-width))
+ (scrollpos (frame-parameter (selected-frame)
+ 'vertical-scroll-bars))
+ )
+ (if (or (eq scrollpos 'left)
+ ;; Now wait a minute. If you turn scroll-bar-mode
+ ;; on, then off, the new value is t, not left.
+ ;; Will this mess up older emacs where the default
+ ;; was on the right? I don't think so since they don't
+ ;; support a header line.
+ (eq scrollpos t))
+ (let ((w (when (boundp 'scroll-bar-width)
+ (symbol-value 'scroll-bar-width))))
+
+ (if (not w)
+ (setq w (frame-parameter (selected-frame)
+ 'scroll-bar-width)))
+
+ ;; in 21.2, the frame parameter is sometimes empty
+ ;; so we need to get the value here.
+ (if (not w)
+ (setq w (+ (get 'scroll-bar-width 'x-frame-parameter)
+ ;; In 21.4, or perhaps 22.1 the x-frame
+ ;; parameter is different from the frame
+ ;; parameter by only 1 pixel.
+ 1)))
+
+ (if (not w)
+ " "
+ (setq w (+ 2 w)) ; Some sort of border around
+ ; the scrollbar.
+ (make-string (/ w charwidth) ? )))
+ ""))
+ (error ""))
+ (condition-case nil
+ ;; Test fringe size.
+ (let* ((f (window-fringes))
+ (fw (car f))
+ (numspace (/ fw (frame-char-width)))
+ )
+ (make-string numspace ? ))
+ (error
+ ;; Well, the fancy new Emacs functions failed. Try older
+ ;; tricks.
+ (condition-case nil
+ ;; I'm not so sure what's up with the 21.1-21.3 fringe.
+ ;; It looks to be about 1 space wide.
+ (if (get 'fringe 'face)
+ " "
+ "")
+ (error ""))))
+ )
+ ;; Not Emacs or a window system means no scrollbar or fringe,
+ ;; and perhaps not even a header line to worry about.
+ "")
+ "String used to indent the stickyfunc header.
+Customize this string to match the space used by scrollbars and
+fringe so it does not appear that the code is moving left/right
+when it lands in the sticky line."
+ :group 'semantic
+ :type 'string)
+
+(defvar semantic-stickyfunc-old-hlf nil
+ "Value of the header line when entering sticky func mode.")
+
+(defconst semantic-stickyfunc-header-line-format
+ (cond ((featurep 'xemacs)
+ nil)
+ ((>= emacs-major-version 22)
+ '(:eval (list
+ ;; Magic bit I found on emacswiki.
+ (propertize " " 'display '((space :align-to 0)))
+ (semantic-stickyfunc-fetch-stickyline))))
+ ((= emacs-major-version 21)
+ '(:eval (list semantic-stickyfunc-indent-string
+ (semantic-stickyfunc-fetch-stickyline))))
+ (t nil))
+ "The header line format used by sticky func mode.")
+
+(defun semantic-stickyfunc-mode-setup ()
+ "Setup option `semantic-stickyfunc-mode'.
+For semantic enabled buffers, make the function declaration for the top most
+function \"sticky\". This is accomplished by putting the first line of
+text for that function in Emacs 21's header line."
+ (if semantic-stickyfunc-mode
+ (progn
+ (unless (and (featurep 'semantic) (semantic-active-p))
+ ;; Disable minor mode if semantic stuff not available
+ (setq semantic-stickyfunc-mode nil)
+ (error "Buffer %s was not set up for parsing" (buffer-name)))
+ (unless (boundp 'default-header-line-format)
+ ;; Disable if there are no header lines to use.
+ (setq semantic-stickyfunc-mode nil)
+ (error "Sticky Function mode requires Emacs 21"))
+ ;; Enable the mode
+ ;; Save previous buffer local value of header line format.
+ (when (and (local-variable-p 'header-line-format (current-buffer))
+ (not (eq header-line-format
+ semantic-stickyfunc-header-line-format)))
+ (set (make-local-variable 'semantic-stickyfunc-old-hlf)
+ header-line-format))
+ (setq header-line-format semantic-stickyfunc-header-line-format)
+ )
+ ;; Disable sticky func mode
+ ;; Restore previous buffer local value of header line format if
+ ;; the current one is the sticky func one.
+ (when (eq header-line-format semantic-stickyfunc-header-line-format)
+ (kill-local-variable 'header-line-format)
+ (when (local-variable-p 'semantic-stickyfunc-old-hlf (current-buffer))
+ (setq header-line-format semantic-stickyfunc-old-hlf)
+ (kill-local-variable 'semantic-stickyfunc-old-hlf))))
+ semantic-stickyfunc-mode)
+
+;;;###autoload
+(defun semantic-stickyfunc-mode (&optional arg)
+ "Minor mode to show the title of a tag in the header line.
+Enables/disables making the header line of functions sticky.
+A function (or other tag class specified by
+`semantic-stickyfunc-sticky-classes') has a header line, meaning the
+first line which describes the rest of the construct. This first
+line is what is displayed in the Emacs 21 header line.
+
+With prefix argument ARG, turn on if positive, otherwise off. The
+minor mode can be turned on only if semantic feature is available and
+the current buffer was set up for parsing. Return non-nil if the
+minor mode is enabled."
+ (interactive
+ (list (or current-prefix-arg
+ (if semantic-stickyfunc-mode 0 1))))
+ (setq semantic-stickyfunc-mode
+ (if arg
+ (>
+ (prefix-numeric-value arg)
+ 0)
+ (not semantic-stickyfunc-mode)))
+ (semantic-stickyfunc-mode-setup)
+ (run-hooks 'semantic-stickyfunc-mode-hook)
+ (if (interactive-p)
+ (message "Stickyfunc minor mode %sabled"
+ (if semantic-stickyfunc-mode "en" "dis")))
+ (semantic-mode-line-update)
+ semantic-stickyfunc-mode)
+
+(defvar semantic-stickyfunc-sticky-classes
+ '(function type)
+ "List of tag classes which sticky func will display in the header line.")
+(make-variable-buffer-local 'semantic-stickyfunc-sticky-classes)
+
+(defun semantic-stickyfunc-tag-to-stick ()
+ "Return the tag to stick at the current point."
+ (let ((tags (nreverse (semantic-find-tag-by-overlay (point)))))
+ ;; Get rid of non-matching tags.
+ (while (and tags
+ (not (member
+ (semantic-tag-class (car tags))
+ semantic-stickyfunc-sticky-classes))
+ )
+ (setq tags (cdr tags)))
+ (car tags)))
+
+(defun semantic-stickyfunc-fetch-stickyline ()
+ "Make the function at the top of the current window sticky.
+Capture it's function declaration, and place it in the header line.
+If there is no function, disable the header line."
+ (let ((str
+ (save-excursion
+ (goto-char (window-start (selected-window)))
+ (forward-line -1)
+ (end-of-line)
+ ;; Capture this function
+ (let* ((tag (semantic-stickyfunc-tag-to-stick)))
+ ;; TAG is nil if there was nothing of the apropriate type there.
+ (if (not tag)
+ ;; Set it to be the text under the header line
+ (buffer-substring (point-at-bol) (point-at-eol))
+ ;; Get it
+ (goto-char (semantic-tag-start tag))
+ ;; Klaus Berndl <address@hidden>:
+ ;; goto the tag name; this is especially needed for languages
+ ;; like c++ where a often used style is like:
+ ;; void
+ ;; ClassX::methodM(arg1...)
+ ;; {
+ ;; ...
+ ;; }
+ ;; Without going to the tag-name we would get"void" in the
+ ;; header line which is IMHO not really useful
+ (search-forward (semantic-tag-name tag) nil t)
+ (buffer-substring (point-at-bol) (point-at-eol))
+ ))))
+ (start 0))
+ (while (string-match "%" str start)
+ (setq str (replace-match "%%" t t str 0)
+ start (1+ (match-end 0)))
+ )
+ ;; In 21.4 (or 22.1) the heder doesn't expand tabs. Hmmmm.
+ ;; We should replace them here.
+ ;;
+ ;; This hack assumes that tabs are kept smartly at tab boundaries
+ ;; instead of in a tab boundary where it might only represent 4 spaces.
+ (while (string-match "\t" str start)
+ (setq str (replace-match " " t t str 0)))
+ str))
+
+(defun semantic-stickyfunc-menu (event)
+ "Popup a menu that can help a user understand stickyfunc-mode.
+Argument EVENT describes the event that caused this function to be called."
+ (interactive "e")
+ (let* ((startwin (selected-window))
+ (win (car (car (cdr event))))
+ )
+ (select-window win t)
+ (save-excursion
+ (goto-char (window-start win))
+ (sit-for 0)
+ (popup-menu semantic-stickyfunc-popup-menu event)
+ )
+ (select-window startwin)))
+
+
+(semantic-add-minor-mode 'semantic-stickyfunc-mode
+ "" ;; Don't need indicator. It's quite visible
+ semantic-stickyfunc-mode-map)
+
+
+
+;;;;
+;;;; Minor mode to make highlight the current function
+;;;;
+
+;; Highlight the first like of the function we are in if it is different
+;; from the the tag going off the top of the screen.
+
+;;;###autoload
+(defun global-semantic-highlight-func-mode (&optional arg)
+ "Toggle global use of option `semantic-highlight-func-mode'.
+If ARG is positive, enable, if it is negative, disable.
+If ARG is nil, then toggle."
+ (interactive "P")
+ (setq global-semantic-highlight-func-mode
+ (semantic-toggle-minor-mode-globally
+ 'semantic-highlight-func-mode arg)))
+
+;;;###autoload
+(defcustom global-semantic-highlight-func-mode nil
+ "If non-nil, enable global use of `semantic-highlight-func-mode'.
+When enabled, the first line of the current tag is highlighted."
+ :group 'semantic
+ :group 'semantic-modes
+ :type 'boolean
+ :require 'semantic/util-modes
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (global-semantic-highlight-func-mode (if val 1 -1))))
+
+(defcustom semantic-highlight-func-mode-hook nil
+ "Hook run at the end of function `semantic-highlight-func-mode'."
+ :group 'semantic
+ :type 'hook)
+
+(defvar semantic-highlight-func-mode-map
+ (let ((km (make-sparse-keymap))
+ (m3 (if (featurep 'xemacs) [ button3 ] [ mouse-3 ]))
+ )
+ (define-key km m3 'semantic-highlight-func-menu)
+ km)
+ "Keymap for highlight-func minor mode.")
+
+(defvar semantic-highlight-func-popup-menu nil
+ "Menu used if the user clicks on the header line used by
`semantic-highlight-func-mode'.")
+
+(easy-menu-define
+ semantic-highlight-func-popup-menu
+ semantic-highlight-func-mode-map
+ "Highlight-Func Menu"
+ '("Highlight-Func Mode" :visible (progn nil)
+ [ "Copy Tag" senator-copy-tag
+ :active (semantic-current-tag)
+ :help "Copy the current tag to the tag ring"]
+ [ "Kill Tag" senator-kill-tag
+ :active (semantic-current-tag)
+ :help "Kill tag text to the kill ring, and copy the tag to the tag ring"
+ ]
+ [ "Copy Tag to Register" senator-copy-tag-to-register
+ :active (semantic-current-tag)
+ :help "Copy the current tag to a register"
+ ]
+ [ "Narrow To Tag" senator-narrow-to-defun
+ :active (semantic-current-tag)
+ :help "Narrow to the bounds of the current tag."]
+ [ "Fold Tag" senator-fold-tag-toggle
+ :active (semantic-current-tag)
+ :style toggle
+ :selected (let ((tag (semantic-stickyfunc-tag-to-stick)))
+ (and tag (semantic-tag-folded-p tag)))
+ :help "Fold the current tag to one line"
+ ]
+ "---"
+ [ "About This Tag" semantic-describe-tag t])
+ )
+
+(defun semantic-highlight-func-menu (event)
+ "Popup a menu that displays things to do to the current tag.
+Argument EVENT describes the event that caused this function to be called."
+ (interactive "e")
+ (let* ((startwin (selected-window))
+ (win (semantic-event-window event))
+ )
+ (select-window win t)
+ (save-excursion
+ ;(goto-char (window-start win))
+ (mouse-set-point event)
+ (sit-for 0)
+ (semantic-popup-menu semantic-highlight-func-popup-menu)
+ )
+ (select-window startwin)))
+
+(defvar semantic-highlight-func-mode nil
+ "Non-nil if highlight-func minor mode is enabled.
+Use the command `semantic-highlight-func-mode' to change this variable.")
+(make-variable-buffer-local 'semantic-highlight-func-mode)
+
+(defvar semantic-highlight-func-ct-overlay nil
+ "Overlay used to highlight the tag the cursor is in.")
+(make-variable-buffer-local 'semantic-highlight-func-ct-overlay)
+
+(defface semantic-highlight-func-current-tag-face
+ '((((class color) (background dark))
+ ;; Put this back to something closer to black later.
+ (:background "gray20"))
+ (((class color) (background light))
+ (:background "gray90")))
+ "Face used to show the top of current function."
+ :group 'semantic-faces)
+
+
+(defun semantic-highlight-func-mode-setup ()
+ "Setup option `semantic-highlight-func-mode'.
+For semantic enabled buffers, highlight the first line of the
+current tag declaration."
+ (if semantic-highlight-func-mode
+ (progn
+ (unless (and (featurep 'semantic) (semantic-active-p))
+ ;; Disable minor mode if semantic stuff not available
+ (setq semantic-highlight-func-mode nil)
+ (error "Buffer %s was not set up for parsing" (buffer-name)))
+ ;; Setup our hook
+ (add-hook 'post-command-hook
'semantic-highlight-func-highlight-current-tag nil t)
+ )
+ ;; Disable highlight func mode
+ (remove-hook 'post-command-hook
'semantic-highlight-func-highlight-current-tag t)
+ (semantic-highlight-func-highlight-current-tag t)
+ )
+ semantic-highlight-func-mode)
+
+;;;###autoload
+(defun semantic-highlight-func-mode (&optional arg)
+ "Minor mode to highlight the first line of the current tag.
+Enables/disables making the header line of functions sticky.
+A function (or other tag class specified by
+`semantic-stickyfunc-sticky-classes') is highlighted, meaning the
+first line which describes the rest of the construct.
+
+See `semantic-stickyfunc-mode' for putting a function in the
+header line. This mode recycles the stickyfunc configuration
+classes list.
+
+With prefix argument ARG, turn on if positive, otherwise off. The
+minor mode can be turned on only if semantic feature is available and
+the current buffer was set up for parsing. Return non-nil if the
+minor mode is enabled."
+ (interactive
+ (list (or current-prefix-arg
+ (if semantic-highlight-func-mode 0 1))))
+ (setq semantic-highlight-func-mode
+ (if arg
+ (>
+ (prefix-numeric-value arg)
+ 0)
+ (not semantic-highlight-func-mode)))
+ (semantic-highlight-func-mode-setup)
+ (run-hooks 'semantic-highlight-func-mode-hook)
+ (if (interactive-p)
+ (message "Highlight-Func minor mode %sabled"
+ (if semantic-highlight-func-mode "en" "dis")))
+ semantic-highlight-func-mode)
+
+(defun semantic-highlight-func-highlight-current-tag (&optional disable)
+ "Highlight the current tag under point.
+Optional argument DISABLE will turn off any active highlight.
+If the current tag for this buffer is different from the last time this
+function was called, move the overlay."
+ (when (and (not (minibufferp))
+ (or (not semantic-highlight-func-ct-overlay)
+ (eq (semantic-overlay-buffer
+ semantic-highlight-func-ct-overlay)
+ (current-buffer))))
+ (let* ((tag (semantic-stickyfunc-tag-to-stick))
+ (ol semantic-highlight-func-ct-overlay))
+ (when (not ol)
+ ;; No overlay in this buffer. Make one.
+ (setq ol (semantic-make-overlay (point-min) (point-min)
+ (current-buffer) t nil))
+ (semantic-overlay-put ol 'highlight-func t)
+ (semantic-overlay-put ol 'face
'semantic-highlight-func-current-tag-face)
+ (semantic-overlay-put ol 'keymap semantic-highlight-func-mode-map)
+ (semantic-overlay-put ol 'help-echo
+ "Current Function : mouse-3 - Context menu")
+ (setq semantic-highlight-func-ct-overlay ol)
+ )
+
+ ;; TAG is nil if there was nothing of the apropriate type there.
+ (if (or (not tag) disable)
+ ;; No tag, make the overlay go away.
+ (progn
+ (semantic-overlay-put ol 'tag nil)
+ (semantic-overlay-move ol (point-min) (point-min) (current-buffer))
+ )
+
+ ;; We have a tag, if it is the same, do nothing.
+ (unless (eq (semantic-overlay-get ol 'tag) tag)
+ (save-excursion
+ (goto-char (semantic-tag-start tag))
+ (search-forward (semantic-tag-name tag) nil t)
+ (semantic-overlay-put ol 'tag tag)
+ (semantic-overlay-move ol (point-at-bol) (point-at-eol))
+ )
+ )
+ )))
+ nil)
+
+(semantic-add-minor-mode 'semantic-highlight-func-mode
+ "" ;; Don't need indicator. It's quite visible
+ nil)
+
+(provide 'semantic/util-modes)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/util-modes"
+;; End:
+
+;;; semantic/util-modes.el ends here
Index: cedet/semantic/util.el
===================================================================
RCS file: cedet/semantic/util.el
diff -N cedet/semantic/util.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/util.el 28 Sep 2009 15:15:10 -0000 1.2
@@ -0,0 +1,508 @@
+;;; semantic/util.el --- Utilities for use with semantic tag tables
+
+;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
+;;; 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Semantic utility API for use with semantic tag tables.
+;;
+
+(require 'semantic)
+
+(eval-when-compile
+ (require 'semantic/db-find)
+ ;; For semantic-find-tags-by-class, semantic--find-tags-by-function,
+ ;; and semantic-brute-find-tag-standard:
+ (require 'semantic/find))
+
+(declare-function data-debug-insert-stuff-list "data-debug")
+(declare-function data-debug-insert-thing "data-debug")
+(declare-function semantic-ctxt-current-symbol-and-bounds "semantic/ctxt")
+
+;;; Code:
+
+(defvar semantic-type-relation-separator-character '(".")
+ "Character strings used to separate a parent/child relationship.
+This list of strings are used for displaying or finding separators
+in variable field dereferencing. The first character will be used for
+display. In C, a type field is separated like this: \"type.field\"
+thus, the character is a \".\". In C, and additional value of \"->\"
+would be in the list, so that \"type->field\" could be found.")
+(make-variable-buffer-local 'semantic-type-relation-separator-character)
+
+(defvar semantic-equivalent-major-modes nil
+ "List of major modes which are considered equivalent.
+Equivalent modes share a parser, and a set of override methods.
+A value of nil means that the current major mode is the only one.")
+(make-variable-buffer-local 'semantic-equivalent-major-modes)
+
+;; These semanticdb calls will throw warnings in the byte compiler.
+;; Doing the right thing to make them available at compile time
+;; really messes up the compilation sequence.
+(defun semantic-file-tag-table (file)
+ "Return a tag table for FILE.
+If it is loaded, return the stream after making sure it's ok.
+If FILE is not loaded, check to see if `semanticdb' feature exists,
+ and use it to get tags from files not in memory.
+If FILE is not loaded, and semanticdb is not available, find the file
+ and parse it."
+ (save-match-data
+ (if (find-buffer-visiting file)
+ (save-excursion
+ (set-buffer (find-buffer-visiting file))
+ (semantic-fetch-tags))
+ ;; File not loaded
+ (if (and (require 'semantic/db-mode)
+ (semanticdb-minor-mode-p))
+ ;; semanticdb is around, use it.
+ (semanticdb-file-stream file)
+ ;; Get the stream ourselves.
+ (save-excursion
+ (set-buffer (find-file-noselect file))
+ (semantic-fetch-tags))))))
+
+(semantic-alias-obsolete 'semantic-file-token-stream
+ 'semantic-file-tag-table)
+
+(defun semantic-something-to-tag-table (something)
+ "Convert SOMETHING into a semantic tag table.
+Something can be a tag with a valid BUFFER property, a tag table, a
+buffer, or a filename. If SOMETHING is nil return nil."
+ (cond
+ ;; A list of tags
+ ((and (listp something)
+ (semantic-tag-p (car something)))
+ something)
+ ;; A buffer
+ ((bufferp something)
+ (save-excursion
+ (set-buffer something)
+ (semantic-fetch-tags)))
+ ;; A Tag: Get that tag's buffer
+ ((and (semantic-tag-with-position-p something)
+ (semantic-tag-in-buffer-p something))
+ (save-excursion
+ (set-buffer (semantic-tag-buffer something))
+ (semantic-fetch-tags)))
+ ;; Tag with a file name in it
+ ((and (semantic-tag-p something)
+ (semantic-tag-file-name something)
+ (file-exists-p (semantic-tag-file-name something)))
+ (semantic-file-tag-table
+ (semantic-tag-file-name something)))
+ ;; A file name
+ ((and (stringp something)
+ (file-exists-p something))
+ (semantic-file-tag-table something))
+ ;; A Semanticdb table
+ ((and (featurep 'semantic/db)
+ (semanticdb-minor-mode-p)
+ (semanticdb-abstract-table-child-p something))
+ (semanticdb-refresh-table something)
+ (semanticdb-get-tags something))
+ ;; Semanticdb find-results
+ ((and (featurep 'semantic/db)
+ (semanticdb-minor-mode-p)
+ (require 'semantic/db-find)
+ (semanticdb-find-results-p something))
+ (semanticdb-strip-find-results something))
+ ;; NOTE: This commented out since if a search result returns
+ ;; empty, that empty would turn into everything on the next search.
+ ;; Use the current buffer for nil
+;; ((null something)
+;; (semantic-fetch-tags))
+ ;; don't know what it is
+ (t nil)))
+
+(semantic-alias-obsolete 'semantic-something-to-stream
+ 'semantic-something-to-tag-table)
+
+;;; Recursive searching through dependency trees
+;;
+;; This will depend on the general searching APIS defined above.
+;; but will add full recursion through the dependencies list per
+;; stream.
+(defun semantic-recursive-find-nonterminal-by-name (name buffer)
+ "Recursively find the first occurrence of NAME.
+Start search with BUFFER. Recurse through all dependencies till found.
+The return item is of the form (BUFFER TOKEN) where BUFFER is the buffer
+in which TOKEN (the token found to match NAME) was found.
+
+THIS ISN'T USED IN SEMANTIC. DELETE ME SOON."
+ (save-excursion
+ (set-buffer buffer)
+ (let* ((stream (semantic-fetch-tags))
+ (includelist (or (semantic-find-tags-by-class 'include stream)
+ "empty.silly.thing"))
+ (found (semantic-find-first-tag-by-name name stream))
+ (unfound nil))
+ (while (and (not found) includelist)
+ (let ((fn (semantic-dependency-tag-file (car includelist))))
+ (if (and fn (not (member fn unfound)))
+ (save-excursion
+ (save-match-data
+ (set-buffer (find-file-noselect fn)))
+ (message "Scanning %s" (buffer-file-name))
+ (setq stream (semantic-fetch-tags))
+ (setq found (semantic-find-first-tag-by-name name stream))
+ (if found
+ (setq found (cons (current-buffer) (list found)))
+ (setq includelist
+ (append includelist
+ (semantic-find-tags-by-class
+ 'include stream))))
+ (setq unfound (cons fn unfound)))))
+ (setq includelist (cdr includelist)))
+ found)))
+(make-obsolete 'semantic-recursive-find-nonterminal-by-name
+ "Do not use this function.")
+
+;;; Completion APIs
+;;
+;; These functions provide minibuffer reading/completion for lists of
+;; nonterminals.
+(defvar semantic-read-symbol-history nil
+ "History for a symbol read.")
+
+(defun semantic-read-symbol (prompt &optional default stream filter)
+ "Read a symbol name from the user for the current buffer.
+PROMPT is the prompt to use.
+Optional arguments:
+DEFAULT is the default choice. If no default is given, one is read
+from under point.
+STREAM is the list of tokens to complete from.
+FILTER is provides a filter on the types of things to complete.
+FILTER must be a function to call on each element."
+ (if (not default) (setq default (thing-at-point 'symbol)))
+ (if (not stream) (setq stream (semantic-fetch-tags)))
+ (setq stream
+ (if filter
+ (semantic--find-tags-by-function filter stream)
+ (semantic-brute-find-tag-standard stream)))
+ (if (and default (string-match ":" prompt))
+ (setq prompt
+ (concat (substring prompt 0 (match-end 0))
+ " (default: " default ") ")))
+ (completing-read prompt stream nil t ""
+ 'semantic-read-symbol-history
+ default))
+
+(defun semantic-read-variable (prompt &optional default stream)
+ "Read a variable name from the user for the current buffer.
+PROMPT is the prompt to use.
+Optional arguments:
+DEFAULT is the default choice. If no default is given, one is read
+from under point.
+STREAM is the list of tokens to complete from."
+ (semantic-read-symbol
+ prompt default
+ (or (semantic-find-tags-by-class
+ 'variable (or stream (current-buffer)))
+ (error "No local variables"))))
+
+(defun semantic-read-function (prompt &optional default stream)
+ "Read a function name from the user for the current buffer.
+PROMPT is the prompt to use.
+Optional arguments:
+DEFAULT is the default choice. If no default is given, one is read
+from under point.
+STREAM is the list of tags to complete from."
+ (semantic-read-symbol
+ prompt default
+ (or (semantic-find-tags-by-class
+ 'function (or stream (current-buffer)))
+ (error "No local functions"))))
+
+(defun semantic-read-type (prompt &optional default stream)
+ "Read a type name from the user for the current buffer.
+PROMPT is the prompt to use.
+Optional arguments:
+DEFAULT is the default choice. If no default is given, one is read
+from under point.
+STREAM is the list of tags to complete from."
+ (semantic-read-symbol
+ prompt default
+ (or (semantic-find-tags-by-class
+ 'type (or stream (current-buffer)))
+ (error "No local types"))))
+
+
+;;; Interactive Functions for
+;;
+(defun semantic-describe-tag (&optional tag)
+ "Describe TAG in the minibuffer.
+If TAG is nil, describe the tag under the cursor."
+ (interactive)
+ (if (not tag) (setq tag (semantic-current-tag)))
+ (semantic-fetch-tags)
+ (if tag (message (semantic-format-tag-summarize tag))))
+
+
+;;; Putting keys on tags.
+;;
+(defun semantic-add-label (label value &optional tag)
+ "Add a LABEL with VALUE on TAG.
+If TAG is not specified, use the tag at point."
+ (interactive "sLabel: \nXValue (eval): ")
+ (if (not tag)
+ (progn
+ (semantic-fetch-tags)
+ (setq tag (semantic-current-tag))))
+ (semantic--tag-put-property tag (intern label) value)
+ (message "Added label %s with value %S" label value))
+
+(defun semantic-show-label (label &optional tag)
+ "Show the value of LABEL on TAG.
+If TAG is not specified, use the tag at point."
+ (interactive "sLabel: ")
+ (if (not tag)
+ (progn
+ (semantic-fetch-tags)
+ (setq tag (semantic-current-tag))))
+ (message "%s: %S" label (semantic--tag-get-property tag (intern label))))
+
+
+;;; Hacks
+;;
+;; Some hacks to help me test these functions
+(defun semantic-describe-buffer-var-helper (varsym buffer)
+ "Display to standard out the value of VARSYM in BUFFER."
+ (require 'data-debug)
+ (let ((value (save-excursion
+ (set-buffer buffer)
+ (symbol-value varsym))))
+ (cond
+ ((and (consp value)
+ (< (length value) 10))
+ ;; Draw the list of things in the list.
+ (princ (format " %s: #<list of %d items>\n"
+ varsym (length value)))
+ (data-debug-insert-stuff-list
+ value " " )
+ )
+ (t
+ ;; Else do a one-liner.
+ (data-debug-insert-thing
+ value " " (concat " " (symbol-name varsym) ": "))
+ ))))
+
+(defun semantic-describe-buffer ()
+ "Describe the semantic environment for the current buffer."
+ (interactive)
+ (let ((buff (current-buffer))
+ )
+
+ (with-output-to-temp-buffer (help-buffer)
+ (help-setup-xref (list #'semantic-describe-buffer) (interactive-p))
+ (with-current-buffer standard-output
+ (princ "Semantic Configuration in ")
+ (princ (buffer-name buff))
+ (princ "\n\n")
+
+ (princ "Buffer specific configuration items:\n")
+ (let ((vars '(major-mode
+ semantic-case-fold
+ semantic-expand-nonterminal
+ semantic-parser-name
+ semantic-parse-tree-state
+ semantic-lex-analyzer
+ semantic-lex-reset-hooks
+ )))
+ (dolist (V vars)
+ (semantic-describe-buffer-var-helper V buff)))
+
+ (princ "\nGeneral configuration items:\n")
+ (let ((vars '(semantic-inhibit-functions
+ semantic-init-hook
+ semantic-init-db-hook
+ semantic-unmatched-syntax-hook
+ semantic--before-fetch-tags-hook
+ semantic-after-toplevel-bovinate-hook
+ semantic-after-toplevel-cache-change-hook
+ semantic-before-toplevel-cache-flush-hook
+ semantic-dump-parse
+
+ )))
+ (dolist (V vars)
+ (semantic-describe-buffer-var-helper V buff)))
+
+ (princ "\n\n")
+ (mode-local-describe-bindings-2 buff)
+ )))
+ )
+
+(defun semantic-current-tag-interactive (p)
+ "Display the current token.
+Argument P is the point to search from in the current buffer."
+ (interactive "d")
+ (require 'semantic/find)
+ (let ((tok (semantic-brute-find-innermost-tag-by-position
+ p (current-buffer))))
+ (message (mapconcat 'semantic-abbreviate-nonterminal tok ","))
+ (car tok))
+ )
+
+(defun semantic-hack-search ()
+ "Display info about something under the cursor using generic methods."
+ (interactive)
+ (require 'semantic/find)
+ (let ((strm (cdr (semantic-fetch-tags)))
+ (res nil))
+ (setq res (semantic-brute-find-tag-by-position (point) strm))
+ (if res
+ (progn
+ (pop-to-buffer "*SEMANTIC HACK RESULTS*")
+ (require 'pp)
+ (erase-buffer)
+ (insert (pp-to-string res) "\n")
+ (goto-char (point-min))
+ (shrink-window-if-larger-than-buffer))
+ (message "nil"))))
+
+(defun semantic-assert-valid-token (tok)
+ "Assert that TOK is a valid token."
+ (if (semantic-tag-p tok)
+ (if (semantic-tag-with-position-p tok)
+ (let ((o (semantic-tag-overlay tok)))
+ (if (and (semantic-overlay-p o)
+ (not (semantic-overlay-live-p o)))
+ (let ((debug-on-error t))
+ (error "Tag %s is invalid!" (semantic-tag-name tok)))
+ ;; else, tag is OK.
+ ))
+ ;; Positionless tags are also ok.
+ )
+ (let ((debug-on-error t))
+ (error "Not a semantic tag: %S" tok))))
+
+(defun semantic-sanity-check (&optional cache over notfirst)
+ "Perform a sanity check on the current buffer.
+The buffer's set of overlays, and those overlays found via the cache
+are verified against each other.
+CACHE, and OVER are the semantic cache, and the overlay list.
+NOTFIRST indicates that this was not the first call in the recursive use."
+ (interactive)
+ (if (and (not cache) (not over) (not notfirst))
+ (setq cache semantic--buffer-cache
+ over (semantic-overlays-in (point-min) (point-max))))
+ (while cache
+ (let ((chil (semantic-tag-components-with-overlays (car cache))))
+ (if (not (memq (semantic-tag-overlay (car cache)) over))
+ (message "Tag %s not in buffer overlay list."
+ (semantic-format-tag-concise-prototype (car cache))))
+ (setq over (delq (semantic-tag-overlay (car cache)) over))
+ (setq over (semantic-sanity-check chil over t))
+ (setq cache (cdr cache))))
+ (if (not notfirst)
+ ;; Strip out all overlays which aren't semantic overlays
+ (let ((o nil))
+ (while over
+ (when (and (semantic-overlay-get (car over) 'semantic)
+ (not (eq (semantic-overlay-get (car over) 'semantic)
+ 'unmatched)))
+ (setq o (cons (car over) o)))
+ (setq over (cdr over)))
+ (message "Remaining overlays: %S" o)))
+ over)
+
+;;; Interactive commands (from Senator).
+
+;; The Senator library from upstream CEDET is not included in the
+;; built-in version of Emacs. The plan is to fold it into the
+;; different parts of CEDET and Emacs, so that it works
+;; "transparently". Here are some interactive commands based on
+;; Senator.
+
+;; Symbol completion
+
+(defun semantic-find-tag-for-completion (prefix)
+ "Find all tags with name starting with PREFIX.
+This uses `semanticdb' when available."
+ (let (result ctxt)
+ ;; Try the Semantic analyzer
+ (condition-case nil
+ (and (featurep 'semantic/analyze)
+ (setq ctxt (semantic-analyze-current-context))
+ (setq result (semantic-analyze-possible-completions ctxt)))
+ (error nil))
+ (or result
+ ;; If the analyzer fails, then go into boring completion.
+ (if (and (featurep 'semantic/db)
+ (semanticdb-minor-mode-p)
+ (require 'semantic/db-find))
+ (semanticdb-fast-strip-find-results
+ (semanticdb-deep-find-tags-for-completion prefix))
+ (semantic-deep-find-tags-for-completion prefix (current-buffer))))))
+
+(defun semantic-complete-symbol (&optional predicate)
+ "Complete the symbol under point, using Semantic facilities.
+When called from a program, optional arg PREDICATE is a predicate
+determining which symbols are considered."
+ (interactive)
+ (require 'semantic/ctxt)
+ (let* ((start (car (nth 2 (semantic-ctxt-current-symbol-and-bounds
+ (point)))))
+ (pattern (regexp-quote (buffer-substring start (point))))
+ collection completion)
+ (when start
+ (if (and semantic--completion-cache
+ (eq (nth 0 semantic--completion-cache) (current-buffer))
+ (= (nth 1 semantic--completion-cache) start)
+ (save-excursion
+ (goto-char start)
+ (looking-at (nth 3 semantic--completion-cache))))
+ ;; Use cached value.
+ (setq collection (nthcdr 4 semantic--completion-cache))
+ ;; Perform new query.
+ (setq collection (semantic-find-tag-for-completion pattern))
+ (setq semantic--completion-cache
+ (append (list (current-buffer) start 0 pattern)
+ collection))))
+ (if (null collection)
+ (let ((str (if pattern (format " for \"%s\"" pattern) "")))
+ (if (window-minibuffer-p (selected-window))
+ (minibuffer-message (format " [No completions%s]" str))
+ (message "Can't find completion%s" str)))
+ (setq completion (try-completion pattern collection predicate))
+ (if (string= pattern completion)
+ (let ((list (all-completions pattern collection predicate)))
+ (setq list (sort list 'string<))
+ (if (> (length list) 1)
+ (with-output-to-temp-buffer "*Completions*"
+ (display-completion-list list pattern))
+ ;; Bury any out-of-date completions buffer.
+ (let ((win (get-buffer-window "*Completions*" 0)))
+ (if win (with-selected-window win (bury-buffer))))))
+ ;; Exact match
+ (delete-region start (point))
+ (insert completion)
+ ;; Bury any out-of-date completions buffer.
+ (let ((win (get-buffer-window "*Completions*" 0)))
+ (if win (with-selected-window win (bury-buffer))))))))
+
+(provide 'semantic/util)
+
+;;; Minor modes
+;;
+(require 'semantic/util-modes)
+
+;;; semantic/util.el ends here
Index: cedet/semantic/wisent.el
===================================================================
RCS file: cedet/semantic/wisent.el
diff -N cedet/semantic/wisent.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/wisent.el 28 Sep 2009 15:15:10 -0000 1.2
@@ -0,0 +1,346 @@
+;;; semantic/wisent.el --- Wisent - Semantic gateway
+
+;;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007
+;;; Free Software Foundation, Inc.
+
+;; Author: David Ponce <address@hidden>
+;; Maintainer: David Ponce <address@hidden>
+;; Created: 30 Aug 2001
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Here are functions necessary to use the Wisent LALR parser from
+;; Semantic environment.
+
+;;; History:
+;;
+
+;;; Code:
+
+(require 'semantic)
+(require 'semantic/wisent/wisent)
+
+;;; Lexical analysis
+;;
+(defvar wisent-lex-istream nil
+ "Input stream of `semantic-lex' syntactic tokens.")
+
+(defvar wisent-lex-lookahead nil
+ "Extra lookahead token.
+When non-nil it is directly returned by `wisent-lex-function'.")
+
+;; Maintain this alias for compatibility until all WY grammars have
+;; been translated again to Elisp code.
+(semantic-alias-obsolete 'wisent-lex-make-token-table
+ 'semantic-lex-make-type-table)
+
+(defmacro wisent-lex-eoi ()
+ "Return an End-Of-Input lexical token.
+The EOI token is like this: ($EOI "" POINT-MAX . POINT-MAX)."
+ `(cons ',wisent-eoi-term
+ (cons ""
+ (cons (point-max) (point-max)))))
+
+(defmacro define-wisent-lexer (name doc &rest body)
+ "Create a new lexical analyzer with NAME.
+DOC is a documentation string describing this analyzer.
+When a token is available in `wisent-lex-istream', eval BODY forms
+sequentially. BODY must return a lexical token for the LALR parser.
+
+Each token in input was produced by `semantic-lex', it is a list:
+
+ (TOKSYM START . END)
+
+TOKSYM is a terminal symbol used in the grammar.
+START and END mark boundary in the current buffer of that token's
+value.
+
+Returned tokens must have the form:
+
+ (TOKSYM VALUE START . END)
+
+where VALUE is the buffer substring between START and END positions."
+ `(defun
+ ,name () ,doc
+ (cond
+ (wisent-lex-lookahead
+ (prog1 wisent-lex-lookahead
+ (setq wisent-lex-lookahead nil)))
+ (wisent-lex-istream
+ ,@body)
+ ((wisent-lex-eoi)))))
+
+(define-wisent-lexer wisent-lex
+ "Return the next available lexical token in Wisent's form.
+The variable `wisent-lex-istream' contains the list of lexical tokens
+produced by `semantic-lex'. Pop the next token available and convert
+it to a form suitable for the Wisent's parser."
+ (let* ((tk (car wisent-lex-istream)))
+ ;; Eat input stream
+ (setq wisent-lex-istream (cdr wisent-lex-istream))
+ (cons (semantic-lex-token-class tk)
+ (cons (semantic-lex-token-text tk)
+ (semantic-lex-token-bounds tk)))))
+
+;;; Syntax analysis
+;;
+(defvar wisent-error-function nil
+ "Function used to report parse error.
+By default use the function `wisent-message'.")
+(make-variable-buffer-local 'wisent-error-function)
+
+(defvar wisent-lexer-function 'wisent-lex
+ "Function used to obtain the next lexical token in input.
+Should be a lexical analyzer created with `define-wisent-lexer'.")
+(make-variable-buffer-local 'wisent-lexer-function)
+
+;; Tag production
+;;
+(defsubst wisent-raw-tag (semantic-tag)
+ "Return raw form of given Semantic tag SEMANTIC-TAG.
+Should be used in semantic actions, in grammars, to build a Semantic
+parse tree."
+ (nconc semantic-tag
+ (if (or $region
+ (setq $region (nthcdr 2 wisent-input)))
+ (list (car $region) (cdr $region))
+ (list (point-max) (point-max)))))
+
+(defsubst wisent-cook-tag (raw-tag)
+ "From raw form of Semantic tag RAW-TAG, return a list of cooked tags.
+Should be used in semantic actions, in grammars, to build a Semantic
+parse tree."
+ (let* ((cooked (semantic--tag-expand raw-tag))
+ (l cooked))
+ (while l
+ (semantic--tag-put-property (car l) 'reparse-symbol $nterm)
+ (setq l (cdr l)))
+ cooked))
+
+;; Unmatched syntax collector
+;;
+(defun wisent-collect-unmatched-syntax (nomatch)
+ "Add lexical token NOMATCH to the cache of unmatched tokens.
+See also the variable `semantic-unmatched-syntax-cache'.
+
+NOMATCH is in Wisent's form: (SYMBOL VALUE START . END)
+and will be collected in `semantic-lex' form: (SYMBOL START . END)."
+ (let ((region (cddr nomatch)))
+ (and (number-or-marker-p (car region))
+ (number-or-marker-p (cdr region))
+ (setq semantic-unmatched-syntax-cache
+ (cons (cons (car nomatch) region)
+ semantic-unmatched-syntax-cache)))))
+
+;; Parser plug-ins
+;;
+;; The following functions permit to plug the Wisent LALR parser in
+;; Semantic toolkit. They use the standard API provided by Semantic
+;; to plug parsers in.
+;;
+;; Two plug-ins are available, BUT ONLY ONE MUST BE USED AT A TIME:
+;;
+;; - `wisent-parse-stream' designed to override the standard function
+;; `semantic-parse-stream'.
+;;
+;; - `wisent-parse-region' designed to override the standard function
+;; `semantic-parse-region'.
+;;
+;; Maybe the latter is faster because it eliminates a lot of function
+;; call.
+;;
+(defun wisent-parse-stream (stream goal)
+ "Parse STREAM using the Wisent LALR parser.
+GOAL is a nonterminal symbol to start parsing at.
+Return the list (STREAM SEMANTIC-STREAM) where STREAM are those
+elements of STREAM that have not been used. SEMANTIC-STREAM is the
+list of semantic tags found.
+The LALR parser automaton must be available in buffer local variable
+`semantic--parse-table'.
+
+Must be installed by `semantic-install-function-overrides' to override
+the standard function `semantic-parse-stream'."
+ (let (wisent-lex-istream wisent-lex-lookahead la-elt cache)
+
+ ;; IMPLEMENTATION NOTES:
+ ;; `wisent-parse' returns a lookahead token when it stopped
+ ;; parsing before encountering the end of input. To re-enter the
+ ;; parser it is necessary to push back in the lexical input stream
+ ;; the last lookahead token issued. Because the format of
+ ;; lookahead tokens and tokens in STREAM can be different the
+ ;; lookahead token is put in the variable `wisent-lex-lookahead'
+ ;; before calling `wisent-parse'. Wisent's lexers always pop the
+ ;; next lexical token from that variable when non nil, then from
+ ;; the lexical input stream.
+ ;;
+ ;; The first element of STREAM is used to keep lookahead tokens
+ ;; across successive calls to `wisent-parse-stream'. In fact
+ ;; what is kept is a stack of lookaheads encountered so far. It
+ ;; is cleared when `wisent-parse' returns a valid semantic tag,
+ ;; or twice the same lookahead token! The latter indicates that
+ ;; there is a syntax error on that token. If so, tokens currently
+ ;; in the lookahead stack have not been used, and are moved into
+ ;; `semantic-unmatched-syntax-cache'. When the parser will be
+ ;; re-entered, a new lexical token will be read from STREAM.
+ ;;
+ ;; The first element of STREAM that contains the lookahead stack
+ ;; has this format (compatible with the format of `semantic-lex'
+ ;; tokens):
+ ;;
+ ;; (LOOKAHEAD-STACK START . END)
+ ;;
+ ;; where LOOKAHEAD-STACK is a list of lookahead tokens. And
+ ;; START/END are the bounds of the lookahead at top of stack.
+
+ ;; Retrieve lookahead token from stack
+ (setq la-elt (car stream))
+ (if (consp (car la-elt))
+ ;; The first elt of STREAM contains a lookahead stack
+ (setq wisent-lex-lookahead (caar la-elt)
+ stream (cdr stream))
+ (setq la-elt nil))
+ ;; Parse
+ (setq wisent-lex-istream stream
+ cache (semantic-safe "wisent-parse-stream: %s"
+ (condition-case error-to-filter
+ (wisent-parse semantic--parse-table
+ wisent-lexer-function
+ wisent-error-function
+ goal)
+ (args-out-of-range
+ (if (and (not debug-on-error)
+ (= wisent-parse-max-stack-size
+ (nth 2 error-to-filter)))
+ (progn
+ (message "wisent-parse-stream: %s"
+ (error-message-string error-to-filter))
+ (message "wisent-parse-max-stack-size \
+might need to be increased"))
+ (apply 'signal error-to-filter))))))
+ ;; Manage returned lookahead token
+ (if wisent-lookahead
+ (if (eq (caar la-elt) wisent-lookahead)
+ ;; It is already at top of lookahead stack
+ (progn
+ (setq cache nil
+ la-elt (car la-elt))
+ (while la-elt
+ ;; Collect unmatched tokens from the stack
+ (run-hook-with-args
+ 'wisent-discarding-token-functions (car la-elt))
+ (setq la-elt (cdr la-elt))))
+ ;; New lookahead token
+ (if (or (consp cache) ;; Clear the stack if parse succeeded
+ (null la-elt))
+ (setq la-elt (cons nil nil)))
+ ;; Push it into the stack
+ (setcar la-elt (cons wisent-lookahead (car la-elt)))
+ ;; Update START/END
+ (setcdr la-elt (cddr wisent-lookahead))
+ ;; Push (LOOKAHEAD-STACK START . END) in STREAM
+ (setq wisent-lex-istream (cons la-elt wisent-lex-istream))))
+ ;; Return (STREAM SEMANTIC-STREAM)
+ (list wisent-lex-istream
+ (if (consp cache) cache '(nil))
+ )))
+
+(defun wisent-parse-region (start end &optional goal depth returnonerror)
+ "Parse the area between START and END using the Wisent LALR parser.
+Return the list of semantic tags found.
+Optional arguments GOAL is a nonterminal symbol to start parsing at,
+DEPTH is the lexical depth to scan, and RETURNONERROR is a flag to
+stop parsing on syntax error, when non-nil.
+The LALR parser automaton must be available in buffer local variable
+`semantic--parse-table'.
+
+Must be installed by `semantic-install-function-overrides' to override
+the standard function `semantic-parse-region'."
+ (if (or (< start (point-min)) (> end (point-max)) (< end start))
+ (error "Invalid bounds [%s %s] passed to `wisent-parse-region'"
+ start end))
+ (let* ((case-fold-search semantic-case-fold)
+ (wisent-lex-istream (semantic-lex start end depth))
+ ptree tag cooked lstack wisent-lex-lookahead)
+ ;; Loop while there are lexical tokens available
+ (while wisent-lex-istream
+ ;; Parse
+ (setq wisent-lex-lookahead (car lstack)
+ tag (semantic-safe "wisent-parse-region: %s"
+ (wisent-parse semantic--parse-table
+ wisent-lexer-function
+ wisent-error-function
+ goal)))
+ ;; Manage returned lookahead token
+ (if wisent-lookahead
+ (if (eq (car lstack) wisent-lookahead)
+ ;; It is already at top of lookahead stack
+ (progn
+ (setq tag nil)
+ (while lstack
+ ;; Collect unmatched tokens from lookahead stack
+ (run-hook-with-args
+ 'wisent-discarding-token-functions (car lstack))
+ (setq lstack (cdr lstack))))
+ ;; Push new lookahead token into the stack
+ (setq lstack (cons wisent-lookahead lstack))))
+ ;; Manage the parser result
+ (cond
+ ;; Parse succeeded, cook result
+ ((consp tag)
+ (setq lstack nil ;; Clear the lookahead stack
+ cooked (semantic--tag-expand tag)
+ ptree (append cooked ptree))
+ (while cooked
+ (setq tag (car cooked)
+ cooked (cdr cooked))
+ (or (semantic--tag-get-property tag 'reparse-symbol)
+ (semantic--tag-put-property tag 'reparse-symbol goal)))
+ )
+ ;; Return on error if requested
+ (returnonerror
+ (setq wisent-lex-istream nil)
+ ))
+ ;; Work in progress...
+ (if wisent-lex-istream
+ (and (eq semantic-working-type 'percent)
+ (boundp 'semantic--progress-reporter)
+ semantic--progress-reporter
+ (progress-reporter-update
+ semantic--progress-reporter
+ (/ (* 100 (semantic-lex-token-start
+ (car wisent-lex-istream)))
+ (point-max))))))
+ ;; Return parse tree
+ (nreverse ptree)))
+
+;;; Interfacing with edebug
+;;
+(add-hook
+ 'edebug-setup-hook
+ #'(lambda ()
+
+ (def-edebug-spec define-wisent-lexer
+ (&define name stringp def-body)
+ )
+
+ ))
+
+(provide 'semantic/wisent)
+
+;;; semantic/wisent.el ends here
Index: cedet/semantic/analyze/complete.el
===================================================================
RCS file: cedet/semantic/analyze/complete.el
diff -N cedet/semantic/analyze/complete.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/analyze/complete.el 28 Sep 2009 15:15:10 -0000 1.2
@@ -0,0 +1,263 @@
+;;; semantic/analyze/complete.el --- Smart Completions
+
+;;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Caclulate smart completions.
+;;
+;; Uses the analyzer context routine to determine the best possible
+;; list of completions.
+;;
+;;; History:
+;;
+;; Code was moved here from semantic-analyze.el
+
+(require 'semantic/analyze)
+
+;; For semantic-find-* macros:
+(eval-when-compile (require 'semantic/find))
+
+;;; Code:
+
+;;; Helper Fcns
+;;
+;;
+;;;###autoload
+(define-overloadable-function semantic-analyze-type-constants (type)
+ "For the tag TYPE, return any constant symbols of TYPE.
+Used as options when completing.")
+
+(defun semantic-analyze-type-constants-default (type)
+ "Do nothing with TYPE."
+ nil)
+
+(defun semantic-analyze-tags-of-class-list (tags classlist)
+ "Return the tags in TAGS that are of classes in CLASSLIST."
+ (let ((origc tags))
+ ;; Accept only tags that are of the datatype specified by
+ ;; the desired classes.
+ (setq tags (apply 'nconc ;; All input lists are permutable.
+ (mapcar (lambda (class)
+ (semantic-find-tags-by-class class origc))
+ classlist)))
+ tags))
+
+;;; MAIN completion calculator
+;;
+;;;###autoload
+(define-overloadable-function semantic-analyze-possible-completions (context)
+ "Return a list of semantic tags which are possible completions.
+CONTEXT is either a position (such as point), or a precalculated
+context. Passing in a context is useful if the caller also needs
+to access parts of the analysis.
+Completions run through the following filters:
+ * Elements currently in scope
+ * Constants currently in scope
+ * Elements match the :prefix in the CONTEXT.
+ * Type of the completion matches the type of the context.
+Context type matching can identify the following:
+ * No specific type
+ * Assignment into a variable of some type.
+ * Argument to a function with type constraints.
+When called interactively, displays the list of possible completions
+in a buffer."
+ (interactive "d")
+ ;; In theory, we don't need the below since the context will
+ ;; do it for us.
+ ;;(semantic-refresh-tags-safe)
+ (with-syntax-table semantic-lex-syntax-table
+ (let* ((context (if (semantic-analyze-context-child-p context)
+ context
+ (semantic-analyze-current-context context)))
+ (ans (if (not context)
+ (error "Nothing to Complete.")
+ (:override))))
+ ;; If interactive, display them.
+ (when (interactive-p)
+ (with-output-to-temp-buffer "*Possible Completions*"
+ (semantic-analyze-princ-sequence ans "" (current-buffer)))
+ (shrink-window-if-larger-than-buffer
+ (get-buffer-window "*Possible Completions*")))
+ ans)))
+
+(defun semantic-analyze-possible-completions-default (context)
+ "Default method for producing smart completions.
+Argument CONTEXT is an object specifying the locally derived context."
+ (let* ((a context)
+ (desired-type (semantic-analyze-type-constraint a))
+ (desired-class (oref a prefixclass))
+ (prefix (oref a prefix))
+ (prefixtypes (oref a prefixtypes))
+ (completetext nil)
+ (completetexttype nil)
+ (scope (oref a scope))
+ (localvar (oref scope localvar))
+ (c nil))
+
+ ;; Calculate what our prefix string is so that we can
+ ;; find all our matching text.
+ (setq completetext (car (reverse prefix)))
+ (if (semantic-tag-p completetext)
+ (setq completetext (semantic-tag-name completetext)))
+
+ (if (and (not completetext) (not desired-type))
+ (error "Nothing to complete"))
+
+ (if (not completetext) (setq completetext ""))
+
+ ;; This better be a reasonable type, or we should fry it.
+ ;; The prefixtypes should always be at least 1 less than
+ ;; the prefix since the type is never looked up for the last
+ ;; item when calculating a sequence.
+ (setq completetexttype (car (reverse prefixtypes)))
+ (when (or (not completetexttype)
+ (not (and (semantic-tag-p completetexttype)
+ (eq (semantic-tag-class completetexttype) 'type))))
+ ;; What should I do here? I think this is an error condition.
+ (setq completetexttype nil)
+ ;; If we had something that was a completetexttype but it wasn't
+ ;; valid, then express our dismay!
+ (when (> (length prefix) 1)
+ (let* ((errprefix (car (cdr (reverse prefix)))))
+ (error "Cannot find types for `%s'"
+ (cond ((semantic-tag-p errprefix)
+ (semantic-format-tag-prototype errprefix))
+ (t
+ (format "%S" errprefix)))))
+ ))
+
+ ;; There are many places to get our completion stream for.
+ ;; Here we go.
+ (if completetexttype
+
+ (setq c (semantic-find-tags-for-completion
+ completetext
+ (semantic-analyze-scoped-type-parts completetexttype scope)
+ ))
+
+ ;; No type based on the completetext. This is a free-range
+ ;; var or function. We need to expand our search beyond this
+ ;; scope into semanticdb, etc.
+ (setq c (nconc
+ ;; Argument list and local variables
+ (semantic-find-tags-for-completion completetext localvar)
+ ;; The current scope
+ (semantic-find-tags-for-completion completetext (oref scope
fullscope))
+ ;; The world
+ (semantic-analyze-find-tags-by-prefix completetext))
+ )
+ )
+
+ (let ((origc c)
+ (dtname (semantic-tag-name desired-type)))
+
+ ;; Reset c.
+ (setq c nil)
+
+ ;; Loop over all the found matches, and catagorize them
+ ;; as being possible features.
+ (while origc
+
+ (cond
+ ;; Strip operators
+ ((semantic-tag-get-attribute (car origc) :operator-flag)
+ nil
+ )
+
+ ;; If we are completing from within some prefix,
+ ;; then we want to exclude constructors and destructors
+ ((and completetexttype
+ (or (semantic-tag-get-attribute (car origc) :constructor-flag)
+ (semantic-tag-get-attribute (car origc) :destructor-flag)))
+ nil
+ )
+
+ ;; If there is a desired type, we need a pair of restrictions
+ (desired-type
+
+ (cond
+ ;; Ok, we now have a completion list based on the text we found
+ ;; we want to complete on. Now filter that stream against the
+ ;; type we want to search for.
+ ((string= dtname (semantic-analyze-type-to-name (semantic-tag-type
(car origc))))
+ (setq c (cons (car origc) c))
+ )
+
+ ;; Now anything that is a compound type which could contain
+ ;; additional things which are of the desired type
+ ((semantic-tag-type (car origc))
+ (let ((att (semantic-analyze-tag-type (car origc) scope))
+ )
+ (if (and att (semantic-tag-type-members att))
+ (setq c (cons (car origc) c))))
+ )
+
+ ) ; cond
+ ); desired type
+
+ ;; No desired type, no other restrictions. Just add.
+ (t
+ (setq c (cons (car origc) c)))
+
+ ); cond
+
+ (setq origc (cdr origc)))
+
+ (when desired-type
+ ;; Some types, like the enum in C, have special constant values that
+ ;; we could complete with. Thus, if the target is an enum, we can
+ ;; find possible symbol values to fill in that value.
+ (let ((constants
+ (semantic-analyze-type-constants desired-type)))
+ (if constants
+ (progn
+ ;; Filter
+ (setq constants
+ (semantic-find-tags-for-completion
+ completetext constants))
+ ;; Add to the list
+ (setq c (nconc c constants)))
+ )))
+ )
+
+ (when desired-class
+ (setq c (semantic-analyze-tags-of-class-list c desired-class)))
+
+ ;; Pull out trash.
+ ;; NOTE TO SELF: Is this too slow?
+ ;; OTHER NOTE: Do we not want to strip duplicates by name and
+ ;; only by position? When are duplicate by name but not by tag
+ ;; useful?
+ (setq c (semantic-unique-tag-table-by-name c))
+
+ ;; All done!
+
+ c))
+
+(provide 'semantic/analyze/complete)
+
+;; Local variables:
+;; generated-autoload-file: "../loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/analyze/complete"
+;; End:
+
+;;; semantic/analyze/complete.el ends here
Index: cedet/semantic/analyze/debug.el
===================================================================
RCS file: cedet/semantic/analyze/debug.el
diff -N cedet/semantic/analyze/debug.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/analyze/debug.el 28 Sep 2009 15:15:10 -0000 1.2
@@ -0,0 +1,624 @@
+;;; semantic/analyze/debug.el --- Debug the analyzer
+
+;;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Provide a top-order debugging tool for figuring out what's going on with
+;; smart completion and analyzer mode.
+
+(require 'semantic)
+(require 'semantic/analyze)
+(require 'semantic/analyze/complete)
+(require 'semantic/db-typecache)
+
+;; For semantic-find-tags-by-class:
+(eval-when-compile (require 'semantic/find))
+
+(declare-function ede-get-locator-object "ede/files")
+
+;;; Code:
+
+(defun semantic-analyze-debug-assist ()
+ "Debug semantic analysis at the current point."
+ (interactive)
+ (let ((actualfcn (fetch-overload 'semantic-analyze-current-context))
+ (ctxt (semantic-analyze-current-context))
+ )
+ ;; What to show.
+ (if actualfcn
+ (message "Mode %s does not use the default analyzer."
+ major-mode)
+ ;; Debug our context.
+ )
+ (or (semantic-analyzer-debug-test-local-context)
+ (and ctxt (semantic-analyzer-debug-found-prefix ctxt))
+ )
+
+ ))
+
+(defun semantic-analyzer-debug-found-prefix (ctxt)
+ "Debug the prefix found by the analyzer output CTXT."
+ (let* ((pf (oref ctxt prefix))
+ (pft (oref ctxt prefixtypes))
+ (idx 0)
+ (stop nil)
+ (comp (condition-case nil
+ (semantic-analyze-possible-completions ctxt)
+ (error nil)))
+ )
+ (while (and (nth idx pf) (not stop))
+ (let ((pentry (nth idx pf))
+ (ptentry (nth idx pft)))
+ (if (or (stringp pentry) (not ptentry))
+ ;; Found someting ok. stop
+ (setq stop t)
+ (setq idx (1+ idx)))))
+ ;; We found the first non-tag entry. What is the situation?
+ (cond
+ ((and (eq idx 0) (stringp (car pf)))
+ ;; First part, we couldn't find it.
+ (semantic-analyzer-debug-global-symbol ctxt (car pf) comp))
+ ((not (nth (1- idx) pft)) ;; idx can't be 0 here.
+ ;; The previous entry failed to have an identifiable data
+ ;; type, which is a global search.
+ (semantic-analyzer-debug-missing-datatype ctxt idx comp))
+ ((and (nth (1- idx) pft) (stringp (nth idx pf)))
+ ;; Non-first search, didn't find string in known data type.
+ (semantic-analyzer-debug-missing-innertype ctxt idx comp))
+ (t
+ ;; Things are ok?
+ (message "Things look ok."))
+ )))
+
+(defun semantic-analyzer-debug-global-symbol (ctxt prefix comp)
+ "Debug why we can't find the first entry in the CTXT PREFIX.
+Argument COMP are possible completions here."
+ (let ((tab semanticdb-current-table)
+ (finderr nil)
+ (origbuf (current-buffer))
+ )
+ (with-output-to-temp-buffer (help-buffer)
+ (with-current-buffer standard-output
+ (princ "Unable to find prefix ")
+ (princ prefix)
+ (princ ".\n\n")
+
+ ;; NOTE: This line is copied from semantic-analyze-current-context.
+ ;; You will need to update both places.
+ (condition-case err
+ (save-excursion
+ (set-buffer origbuf)
+ (let* ((position (or (cdr-safe (oref ctxt bounds)) (point)))
+ (prefixtypes nil) ; Used as type return
+ (scope (semantic-calculate-scope position))
+ )
+ (semantic-analyze-find-tag-sequence
+ (list prefix "") scope 'prefixtypes)
+ )
+ )
+ (error (setq finderr err)))
+
+ (if finderr
+ (progn
+ (princ "The prefix lookup code threw the following error:\n ")
+ (prin1 finderr)
+ (princ "\n\nTo debug this error you can do this:
+ M-x toggle-debug-on-error RET
+and then re-run the debug analyzer.\n")
+ )
+ ;; No find error, just not found
+ (princ "The prefix ")
+ (princ prefix)
+ (princ " could not be found in the local scope,
+nor in any search tables.\n")
+ )
+ (princ "\n")
+
+ ;; Describe local scope, and why we might not be able to
+ ;; find it.
+ (semantic-analyzer-debug-describe-scope ctxt)
+
+ (semantic-analyzer-debug-show-completions comp)
+
+ (princ "When Semantic cannot find a symbol, it could be because the
include
+path was setup incorrectly.\n")
+
+ (semantic-analyzer-debug-insert-include-summary tab)
+
+ ))
+ (semantic-analyzer-debug-add-buttons)
+ ))
+
+(defun semantic-analyzer-debug-missing-datatype (ctxt idx comp)
+ "Debug why we can't find a datatype entry for CTXT prefix at IDX.
+Argument COMP are possible completions here."
+ (let* ((prefixitem (nth idx (oref ctxt prefix)))
+ (dt (nth (1- idx) (oref ctxt prefixtypes)))
+ (tt (semantic-tag-type prefixitem))
+ (tab semanticdb-current-table)
+ )
+ (when dt (error "Missing Datatype debugger is confused"))
+ (with-output-to-temp-buffer (help-buffer)
+ (with-current-buffer standard-output
+ (princ "Unable to find datatype for: \"")
+ (princ (semantic-format-tag-prototype prefixitem))
+ (princ "\".
+Declared type is: ")
+ (when (semantic-tag-p tt)
+ (semantic-analyzer-debug-insert-tag tt)
+ (princ "\nRaw data type is: "))
+ (princ (format "%S" tt))
+ (princ "
+
+Semantic could not find this data type in any of its global tables.
+
+Semantic locates datatypes through either the local scope, or the global
+typecache.
+")
+
+ ;; Describe local scope, and why we might not be able to
+ ;; find it.
+ (semantic-analyzer-debug-describe-scope ctxt '(type))
+
+ ;; Describe the typecache.
+ (princ "\nSemantic creates and maintains a type cache for each buffer.
+If the type is a global type, then it should appear in they typecache.
+To examine the typecache, type:
+
+ M-x semanticdb-typecache-dump RET
+
+Current typecache Statistics:\n")
+ (princ (format " %4d types global in this file\n %4d types from
includes.\n"
+ (length (semanticdb-typecache-file-tags tab))
+ (length (semanticdb-typecache-include-tags tab))))
+
+ (princ "\nIf the datatype is not in the typecache, then your include
+path may be incorrect. ")
+
+ (semantic-analyzer-debug-insert-include-summary tab)
+
+ ;; End with-buffer
+ ))
+ (semantic-analyzer-debug-add-buttons)
+ ))
+
+(defun semantic-analyzer-debug-missing-innertype (ctxt idx comp)
+ "Debug why we can't find an entry for CTXT prefix at IDX for known type.
+We need to see if we have possible completions against the entry before
+being too vocal about it.
+Argument COMP are possible completions here."
+ (let* ((prefixitem (nth idx (oref ctxt prefix)))
+ (prevprefix (nth (1- idx) (oref ctxt prefix)))
+ (dt (nth (1- idx) (oref ctxt prefixtypes)))
+ (desired-type (semantic-analyze-type-constraint ctxt))
+ (orig-buffer (current-buffer))
+ (ots (semantic-analyze-tag-type prevprefix
+ (oref ctxt scope)
+ t ; Don't deref
+ ))
+ )
+ (when (not dt) (error "Missing Innertype debugger is confused"))
+ (with-output-to-temp-buffer (help-buffer)
+ (with-current-buffer standard-output
+ (princ "Cannot find prefix \"")
+ (princ prefixitem)
+ (princ "\" in datatype:
+ ")
+ (semantic-analyzer-debug-insert-tag dt)
+ (princ "\n")
+
+ (cond
+ ;; Any language with a namespace.
+ ((string= (semantic-tag-type dt) "namespace")
+ (princ "Semantic may not have found all possible namespaces with
+the name ")
+ (princ (semantic-tag-name dt))
+ (princ ". You can debug the entire typecache, including merged
namespaces
+with the command:
+
+ M-x semanticdb-typecache-dump RET")
+ )
+
+ ;; @todo - external declarations??
+ (nil
+ nil)
+
+ ;; A generic explanation
+ (t
+ (princ "\nSemantic has found the datatype ")
+ (semantic-analyzer-debug-insert-tag dt)
+ (if (or (not (semantic-equivalent-tag-p ots dt))
+ (not (save-excursion
+ (set-buffer orig-buffer)
+ (car (semantic-analyze-dereference-metatype
+ ots (oref ctxt scope))))))
+ (let ((lasttype ots)
+ (nexttype (save-excursion
+ (set-buffer orig-buffer)
+ (car (semantic-analyze-dereference-metatype
+ ots (oref ctxt scope))))))
+ (if (eq nexttype lasttype)
+ (princ "\n [ Debugger error trying to help with metatypes
]")
+
+ (if (eq ots dt)
+ (princ "\nwhich is a metatype")
+ (princ "\nwhich is derived from metatype ")
+ (semantic-analyzer-debug-insert-tag lasttype)))
+
+ (princ ".\nThe Metatype stack is:\n")
+ (princ " ")
+ (semantic-analyzer-debug-insert-tag lasttype)
+ (princ "\n")
+ (while (and nexttype
+ (not (eq nexttype lasttype)))
+ (princ " ")
+ (semantic-analyzer-debug-insert-tag nexttype)
+ (princ "\n")
+ (setq lasttype nexttype
+ nexttype
+ (save-excursion
+ (set-buffer orig-buffer)
+ (car (semantic-analyze-dereference-metatype
+ nexttype (oref ctxt scope)))))
+ )
+ (when (not nexttype)
+ (princ " nil\n\n")
+ (princ
+ "Last metatype is nil. This means that semantic cannot
derive
+the list of members because the type referred to cannot be found.\n")
+ )
+ )
+ (princ "\nand its list of members.")
+
+ (if (not comp)
+ (progn
+ (princ " Semantic does not know what
+possible completions there are for \"")
+ (princ prefixitem)
+ (princ "\". Examine the known
+members below for more."))
+ (princ " Semantic knows of some
+possible completions for \"")
+ (princ prefixitem)
+ (princ "\".")))
+ )
+ ;; end cond
+ )
+
+ (princ "\n")
+ (semantic-analyzer-debug-show-completions comp)
+
+ (princ "\nKnown members of ")
+ (princ (semantic-tag-name dt))
+ (princ ":\n")
+ (dolist (M (semantic-tag-type-members dt))
+ (princ " ")
+ ;;(princ (semantic-format-tag-prototype M))
+ (semantic-analyzer-debug-insert-tag M)
+ (princ "\n"))
+
+ ;; This doesn't refer to in-type completions.
+ ;;(semantic-analyzer-debug-global-miss-text prefixitem)
+
+ ;; More explanation
+ (when desired-type
+ (princ "\nWhen there are known members that would make good completion
+candidates that are not in the completion list, then the most likely
+cause is a type constraint. Semantic has determined that there is a
+type constraint looking for the type ")
+ (if (semantic-tag-p desired-type)
+ (semantic-analyzer-debug-insert-tag desired-type)
+ (princ (format "%S" desired-type)))
+ (princ "."))
+ ))
+ (semantic-analyzer-debug-add-buttons)
+
+ ))
+
+
+(defun semantic-analyzer-debug-test-local-context ()
+ "Test the local context parsed from the file."
+ (let* ((prefixandbounds (semantic-ctxt-current-symbol-and-bounds (point)))
+ (prefix (car prefixandbounds))
+ (bounds (nth 2 prefixandbounds))
+ )
+ (when (and (or (not prefixandbounds)
+ (not prefix)
+ (not bounds))
+ )
+ (with-output-to-temp-buffer (help-buffer)
+ (with-current-buffer standard-output
+ (princ "Local Context Parser Failed.
+
+If this is unexpected, then there is likely a bug in the Semantic
+local context parser.
+
+Consider debugging the function ")
+ (let ((lcf (fetch-overload 'semantic-ctxt-current-symbol-and-bounds)))
+ (if lcf
+ (princ (symbol-name lcf))
+ (princ "semantic-ctxt-current-symbol-and-bounds,
+or implementing a version specific to ")
+ (princ (symbol-name major-mode))
+ )
+ (princ ".\n"))
+ (semantic-analyzer-debug-add-buttons)
+ t)))
+ ))
+
+;;; General Inserters with help
+;;
+(defun semantic-analyzer-debug-show-completions (comp)
+ "Show the completion list COMP."
+ (if (not comp)
+ (princ "\nNo known possible completions.\n")
+
+ (princ "\nPossible completions are:\n")
+ (dolist (C comp)
+ (princ " ")
+ (cond ((stringp C)
+ (princ C)
+ )
+ ((semantic-tag-p C)
+ (semantic-analyzer-debug-insert-tag C)))
+ (princ "\n"))
+ (princ "\n")))
+
+(defvar semantic-dependency-system-include-path)
+
+(defun semantic-analyzer-debug-insert-include-summary (table)
+ "Display a summary of includes for the semanticdb TABLE."
+ (require 'semantic/dep)
+ (semantic-fetch-tags)
+ (let ((inc (semantic-find-tags-by-class 'include table))
+ ;;(path (semanticdb-find-test-translate-path-no-loading))
+ (unk
+ (save-excursion
+ (set-buffer (semanticdb-get-buffer table))
+ semanticdb-find-lost-includes))
+ (ip
+ (save-excursion
+ (set-buffer (semanticdb-get-buffer table))
+ semantic-dependency-system-include-path))
+ (edeobj
+ (save-excursion
+ (set-buffer (semanticdb-get-buffer table))
+ (and (boundp 'ede-object)
+ ede-object)))
+ (edeproj
+ (save-excursion
+ (set-buffer (semanticdb-get-buffer table))
+ (and (boundp 'ede-object-project)
+ ede-object-project))))
+
+ (princ "\n\nInclude Path Summary:")
+ (when edeobj
+ (princ "\n\nThis file's project include search is handled by the EDE
object:\n")
+ (princ " Buffer Target: ")
+ (princ (object-print edeobj))
+ (princ "\n")
+ (when (not (eq edeobj edeproj))
+ (princ " Buffer Project: ")
+ (princ (object-print edeproj))
+ (princ "\n"))
+ (when edeproj
+ (let ((loc (ede-get-locator-object edeproj)))
+ (princ " Backup Locator: ")
+ (princ (object-print loc))
+ (princ "\n")))
+ )
+
+ (princ "\n\nThe system include path is:\n")
+ (dolist (dir ip)
+ (princ " ")
+ (princ dir)
+ (princ "\n"))
+
+ (princ "\n\nInclude Summary: ")
+ (princ (semanticdb-full-filename table))
+ (princ "\n\n")
+ (princ (format "%s contains %d includes.\n"
+ (file-name-nondirectory
+ (semanticdb-full-filename table))
+ (length inc)))
+ (let ((ok 0)
+ (unknown 0)
+ (unparsed 0)
+ (all 0))
+ (dolist (i inc)
+ (let* ((fileinner (semantic-dependency-tag-file i))
+ (tableinner (when fileinner
+ (semanticdb-file-table-object fileinner t))))
+ (cond ((not fileinner)
+ (setq unknown (1+ unknown)))
+ ((number-or-marker-p (oref tableinner pointmax))
+ (setq ok (1+ ok)))
+ (t
+ (setq unparsed (1+ unparsed))))))
+ (setq all (+ ok unknown unparsed))
+ (when (not (= 0 all))
+ (princ (format " Unknown Includes: %d\n" unknown))
+ (princ (format " Unparsed Includes: %d\n" unparsed))
+ (princ (format " Parsed Includes: %d\n" ok)))
+ )
+
+ ;; Unknowns...
+ (if unk
+ (progn
+ (princ "\nA likely cause of an unfound tag is missing include files.")
+ (semantic-analyzer-debug-insert-tag-list
+ "The following includes were not found" unk)
+
+ (princ "\nYou can fix the include path for ")
+ (princ (symbol-name (oref table major-mode)))
+ (princ " by using this function:
+
+M-x semantic-customize-system-include-path RET
+
+which customizes the mode specific variable for the mode-local
+variable `semantic-dependency-system-include-path'.")
+ )
+
+ (princ "\n No unknown includes.\n"))
+ ))
+
+(defun semantic-analyzer-debug-describe-scope (ctxt &optional classconstraint)
+ "Describe the scope in CTXT for finding a global symbol.
+Optional argument CLASSCONSTRAINT says to output to tags of that class."
+ (let* ((scope (oref ctxt :scope))
+ (parents (oref scope parents))
+ (cc (or classconstraint (oref ctxt prefixclass)))
+ )
+ (princ "\nLocal Scope Information:")
+ (princ "\n * Tag Class Constraint against SCOPE: ")
+ (princ (format "%S" classconstraint))
+
+ (if parents
+ (semantic-analyzer-debug-insert-tag-list
+ " >> Known parent types with possible in scope symbols"
+ parents)
+ (princ "\n * No known parents in current scope."))
+
+ (let ((si (semantic-analyze-tags-of-class-list
+ (oref scope scope) cc))
+ (lv (semantic-analyze-tags-of-class-list
+ (oref scope localvar) cc))
+ )
+ (if si
+ (semantic-analyzer-debug-insert-tag-list
+ " >> Known symbols within the current scope"
+ si)
+ (princ "\n * No known symbols currently in scope."))
+
+ (if lv
+ (semantic-analyzer-debug-insert-tag-list
+ " >> Known symbols that are declared locally"
+ lv)
+ (princ "\n * No known symbols declared locally."))
+ )
+ )
+ )
+
+(defun semantic-analyzer-debug-global-miss-text (name-in)
+ "Use 'princ' to show text describing not finding symbol NAME-IN.
+NAME is the name of the unfound symbol."
+ (let ((name (cond ((stringp name-in)
+ name-in)
+ ((semantic-tag-p name-in)
+ (semantic-format-tag-name name-in))
+ (t (format "%S" name-in)))))
+ (when (not (string= name ""))
+ (princ "\nIf ")
+ (princ name)
+ (princ " is a local variable, argument, or symbol in some
+namespace or class exposed via scoping statements, then it should
+appear in the scope.
+
+Debugging the scope can be done with:
+ M-x semantic-calculate-scope RET
+
+If the prefix is a global symbol, in an included file, then
+your search path may be incomplete.
+"))))
+
+;;; Utils
+;;
+(defun semantic-analyzer-debug-insert-tag-list (text taglist)
+ "Prefixing with TEXT, dump TAGLIST in a help buffer."
+ (princ "\n") (princ text) (princ ":\n")
+
+ (dolist (M taglist)
+ (princ " ")
+ ;;(princ (semantic-format-tag-prototype M))
+ (semantic-analyzer-debug-insert-tag M)
+ (princ "\n"))
+ )
+
+(defun semantic-analyzer-debug-insert-tag (tag &optional parent)
+ "Display a TAG by name, with possible jumpitude.
+PARENT is a possible parent (by nesting) tag."
+ (let ((str (semantic-format-tag-prototype tag parent)))
+ (if (and (semantic-tag-with-position-p tag)
+ (semantic-tag-file-name tag))
+ (insert-button str
+ 'mouse-face 'custom-button-pressed-face
+ 'tag tag
+ 'action
+ `(lambda (button)
+ (let ((buff nil)
+ (pnt nil))
+ (save-excursion
+ (semantic-go-to-tag
+ (button-get button 'tag))
+ (setq buff (current-buffer))
+ (setq pnt (point)))
+ (if (get-buffer-window buff)
+ (select-window (get-buffer-window buff))
+ (pop-to-buffer buff t))
+ (goto-char pnt)
+ (pulse-line-hook-function)))
+ )
+ (princ "\"")
+ (princ str)
+ (princ "\""))
+ ))
+
+(defvar semantic-analyzer-debug-orig nil
+ "The originating buffer for a help button.")
+
+(defun semantic-analyzer-debug-add-buttons ()
+ "Add push-buttons to the *Help* buffer.
+Look for key expressions, and add push-buttons near them."
+ (let ((orig-buffer (make-marker)))
+ (set-marker orig-buffer (point) (current-buffer))
+ (save-excursion
+ ;; Get a buffer ready.
+ (set-buffer "*Help*")
+ (toggle-read-only -1)
+ (goto-char (point-min))
+ (set (make-local-variable 'semantic-analyzer-debug-orig) orig-buffer)
+ ;; First, add do-in buttons to recommendations.
+ (while (re-search-forward "^\\s-*M-x \\(\\(\\w\\|\\s_\\)+\\) " nil t)
+ (let ((fcn (match-string 1)))
+ (when (not (fboundp (intern-soft fcn)))
+ (error "Help Err: Can't find %s" fcn))
+ (end-of-line)
+ (insert " ")
+ (insert-button "[ Do It ]"
+ 'mouse-face 'custom-button-pressed-face
+ 'do-fcn fcn
+ 'action `(lambda (arg)
+ (let ((M semantic-analyzer-debug-orig))
+ (set-buffer (marker-buffer M))
+ (goto-char M))
+ (call-interactively (quote ,(intern-soft
fcn))))
+ )
+ ))
+ ;; Do something else?
+
+ ;; Clean up the mess
+ (toggle-read-only 1)
+ (set-buffer-modified-p nil)
+ )))
+
+(provide 'semantic/analyze/debug)
+
+;;; semantic/analyze/debug.el ends here
Index: cedet/semantic/analyze/fcn.el
===================================================================
RCS file: cedet/semantic/analyze/fcn.el
diff -N cedet/semantic/analyze/fcn.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/analyze/fcn.el 28 Sep 2009 15:15:10 -0000 1.2
@@ -0,0 +1,337 @@
+;;; semantic/analyze/fcn.el --- Analyzer support functions.
+
+;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Analyzer support functions.
+
+;;; Code:
+
+(require 'semantic)
+(eval-when-compile (require 'semantic/find))
+
+(declare-function semanticdb-typecache-merge-streams "semantic/db-typecache")
+(declare-function semantic-scope-find name "semantic/scope")
+(declare-function semantic-scope-set-typecache "semantic/scope")
+(declare-function semantic-scope-tag-get-scope "semantic/scope")
+
+;;; Small Mode Specific Options
+;;
+;; These queries allow a major mode to help the analyzer make decisions.
+;;
+(define-overloadable-function semantic-analyze-tag-prototype-p (tag)
+ "Non-nil if TAG is a prototype."
+ )
+
+(defun semantic-analyze-tag-prototype-p-default (tag)
+ "Non-nil if TAG is a prototype."
+ (let ((p (semantic-tag-get-attribute tag :prototype-flag)))
+ (cond
+ ;; Trust the parser author.
+ (p p)
+ ;; Empty types might be a prototype.
+ ((eq (semantic-tag-class tag) 'type)
+ (not (semantic-tag-type-members tag)))
+ ;; No other heuristics.
+ (t nil))
+ ))
+
+;;------------------------------------------------------------
+
+(define-overloadable-function semantic-analyze-split-name (name)
+ "Split a tag NAME into a sequence.
+Sometimes NAMES are gathered from the parser that are compounded,
+such as in C++ where foo::bar means:
+ \"The class BAR in the namespace FOO.\"
+Return the string NAME for no change, or a list if it needs to be split.")
+
+(defun semantic-analyze-split-name-default (name)
+ "Don't split up NAME by default."
+ name)
+
+(define-overloadable-function semantic-analyze-unsplit-name (namelist)
+ "Assemble a NAMELIST into a string representing a compound name.
+Return the string representing the compound name.")
+
+(defun semantic-analyze-unsplit-name-default (namelist)
+ "Concatenate the names in NAMELIST with a . between."
+ (mapconcat 'identity namelist "."))
+
+;;; SELECTING
+;;
+;; If you narrow things down to a list of tags that all mean
+;; the same thing, how to you pick one? Select or merge.
+;;
+
+(defun semantic-analyze-select-best-tag (sequence &optional tagclass)
+ "For a SEQUENCE of tags, all with good names, pick the best one.
+If SEQUENCE is made up of namespaces, merge the namespaces together.
+If SEQUENCE has several prototypes, find the non-prototype.
+If SEQUENCE has some items w/ no type information, find the one with a type.
+If SEQUENCE is all prototypes, or has no prototypes, get the first one.
+Optional TAGCLASS indicates to restrict the return to only
+tags of TAGCLASS."
+
+ ;; If there is a srew up and we get just one tag.. massage over it.
+ (when (semantic-tag-p sequence)
+ (setq sequence (list sequence)))
+
+ ;; Filter out anything not of TAGCLASS
+ (when tagclass
+ (setq sequence (semantic-find-tags-by-class tagclass sequence)))
+
+ (if (< (length sequence) 2)
+ ;; If the remaining sequence is 1 tag or less, just return it
+ ;; and skip the rest of this mumbo-jumbo.
+ (car sequence)
+
+ ;; 1)
+ ;; This step will eliminate a vast majority of the types,
+ ;; in addition to merging namespaces together.
+ ;;
+ ;; 2)
+ ;; It will also remove prototypes.
+ (require 'semantic/db-typecache)
+ (setq sequence (semanticdb-typecache-merge-streams sequence nil))
+
+ (if (< (length sequence) 2)
+ ;; If the remaining sequence after the merge is 1 tag or less,
+ ;; just return it and skip the rest of this mumbo-jumbo.
+ (car sequence)
+
+ (let ((best nil)
+ (notypeinfo nil)
+ )
+ (while (and (not best) sequence)
+
+ ;; 3) select a non-prototype.
+ (if (not (semantic-tag-type (car sequence)))
+ (setq notypeinfo (car sequence))
+
+ (setq best (car sequence))
+ )
+
+ (setq sequence (cdr sequence)))
+
+ ;; Select the best, or at least the prototype.
+ (or best notypeinfo)))))
+
+;;; Tag Finding
+;;
+;; Mechanism for lookup up tags by name.
+;;
+(defun semantic-analyze-find-tags-by-prefix (prefix)
+ ;; @todo - only used in semantic-complete. Find something better?
+ "Attempt to find a tag with PREFIX.
+This is a wrapper on top of semanticdb, and semantic search functions.
+Almost all searches use the same arguments."
+ (if (and (fboundp 'semanticdb-minor-mode-p)
+ (semanticdb-minor-mode-p))
+ ;; Search the database & concatenate all matches together.
+ (semanticdb-strip-find-results
+ (semanticdb-find-tags-for-completion prefix)
+ 'name)
+ ;; Search just this file because there is no DB available.
+ (semantic-find-tags-for-completion
+ prefix (current-buffer))))
+
+;;; Finding Datatypes
+;;
+
+(define-overloadable-function semantic-analyze-dereference-metatype (type
scope &optional type-declaration)
+ ;; todo - move into typecahe!!
+ "Return a concrete type tag based on input TYPE tag.
+A concrete type is an actual declaration of a memory description,
+such as a structure, or class. A meta type is an alias,
+or a typedef in C or C++. If TYPE is concrete, it
+is returned. If it is a meta type, it will return the concrete
+type defined by TYPE.
+The default behavior always returns TYPE.
+Override functions need not return a real semantic tag.
+Just a name, or short tag will be ok. It will be expanded here.
+SCOPE is the scope object with additional items in which to search for names."
+ (catch 'default-behavior
+ (let* ((ans-tuple (:override
+ ;; Nothing fancy, just return type by default.
+ (throw 'default-behavior (list type type-declaration))))
+ (ans-type (car ans-tuple))
+ (ans-type-declaration (cadr ans-tuple)))
+ (list (semantic-analyze-dereference-metatype-1 ans-type scope)
ans-type-declaration))))
+
+;; Finding a data type by name within a project.
+;;
+(defun semantic-analyze-type-to-name (type)
+ "Get the name of TAG's type.
+The TYPE field in a tag can be nil (return nil)
+or a string, or a non-positional tag."
+ (cond ((semantic-tag-p type)
+ (semantic-tag-name type))
+ ((stringp type)
+ type)
+ ((listp type)
+ (car type))
+ (t nil)))
+
+(defun semantic-analyze-tag-type (tag &optional scope nometaderef)
+ "Return the semantic tag for a type within the type of TAG.
+TAG can be a variable, function or other type of tag.
+The behavior of TAG's type is defined by `semantic-analyze-type'.
+Optional SCOPE represents a calculated scope in which the
+types might be found. This can be nil.
+If NOMETADEREF, then do not dereference metatypes. This is
+used by the analyzer debugger."
+ (semantic-analyze-type (semantic-tag-type tag) scope nometaderef))
+
+(defun semantic-analyze-type (type-declaration &optional scope nometaderef)
+ "Return the semantic tag for TYPE-DECLARATION.
+TAG can be a variable, function or other type of tag.
+The type of tag (such as a class or struct) is a name.
+Lookup this name in database, and return all slots/fields
+within that types field. Also handles anonymous types.
+Optional SCOPE represents a calculated scope in which the
+types might be found. This can be nil.
+If NOMETADEREF, then do not dereference metatypes. This is
+used by the analyzer debugger."
+ (require 'semantic/scope)
+ (let ((name nil)
+ (typetag nil)
+ )
+
+ ;; Is it an anonymous type?
+ (if (and type-declaration
+ (semantic-tag-p type-declaration)
+ (semantic-tag-of-class-p type-declaration 'type)
+ (not (semantic-analyze-tag-prototype-p type-declaration))
+ )
+ ;; We have an anonymous type for TAG with children.
+ ;; Use this type directly.
+ (if nometaderef
+ type-declaration
+ (semantic-analyze-dereference-metatype-stack
+ type-declaration scope type-declaration))
+
+ ;; Not an anonymous type. Look up the name of this type
+ ;; elsewhere, and report back.
+ (setq name (semantic-analyze-type-to-name type-declaration))
+
+ (if (and name (not (string= name "")))
+ (progn
+ ;; Find a type of that name in scope.
+ (setq typetag (and scope (semantic-scope-find name 'type scope)))
+ ;; If no typetag, try the typecache
+ (when (not typetag)
+ (setq typetag (semanticdb-typecache-find name))))
+
+ ;; No name to look stuff up with.
+ (error "Semantic tag %S has no type information"
+ (semantic-tag-name type-declaration)))
+
+ ;; Handle lists of tags.
+ (when (and (consp typetag) (semantic-tag-p (car typetag)))
+ (setq typetag (semantic-analyze-select-best-tag typetag 'type))
+ )
+
+ ;; We now have a tag associated with the type. We need to deref it.
+ ;;
+ ;; If we were asked not to (ie - debugger) push the typecache anyway.
+ (if nometaderef
+ typetag
+ (unwind-protect
+ (progn
+ (semantic-scope-set-typecache
+ scope (semantic-scope-tag-get-scope typetag))
+ (semantic-analyze-dereference-metatype-stack typetag scope
type-declaration)
+ )
+ (semantic-scope-set-typecache scope nil)
+ )))))
+
+(defun semantic-analyze-dereference-metatype-stack (type scope &optional
type-declaration)
+ "Dereference metatypes repeatedly until we hit a real TYPE.
+Uses `semantic-analyze-dereference-metatype'.
+Argument SCOPE is the scope object with additional items in which to search.
+Optional argument TYPE-DECLARATION is how TYPE was found referenced."
+ (let ((lasttype type)
+ (lasttypedeclaration type-declaration)
+ (nexttype (semantic-analyze-dereference-metatype type scope
type-declaration))
+ (idx 0))
+ (catch 'metatype-recursion
+ (while (and nexttype (not (eq (car nexttype) lasttype)))
+ (setq lasttype (car nexttype)
+ lasttypedeclaration (cadr nexttype))
+ (setq nexttype (semantic-analyze-dereference-metatype lasttype scope
lasttypedeclaration))
+ (setq idx (1+ idx))
+ (when (> idx 20) (message "Possible metatype recursion for %S"
+ (semantic-tag-name lasttype))
+ (throw 'metatype-recursion nil))
+ ))
+ lasttype))
+
+;; @ TODO - the typecache can also return a stack of scope names.
+
+(defun semantic-analyze-dereference-metatype-1 (ans scope)
+ "Do extra work after dereferencing a metatype.
+ANS is the answer from the the language specific query.
+SCOPE is the current scope."
+ (require 'semantic/scope)
+ ;; If ANS is a string, or if ANS is a short tag, we
+ ;; need to do some more work to look it up.
+ (if (stringp ans)
+ ;; The metatype is just a string... look it up.
+ (or (and scope (car-safe
+ ;; @todo - should this be `find the best one'?
+ (semantic-scope-find ans 'type scope)))
+ (let ((tcsans nil))
+ (prog1
+ (setq tcsans
+ (semanticdb-typecache-find ans))
+ ;; While going through the metatype, if we have
+ ;; a scope, push our new cache in.
+ (when scope
+ (semantic-scope-set-typecache
+ scope (semantic-scope-tag-get-scope tcsans))
+ ))
+ ))
+ (when (and (semantic-tag-p ans)
+ (eq (semantic-tag-class ans) 'type))
+ ;; We have a tag.
+ (if (semantic-analyze-tag-prototype-p ans)
+ ;; It is a prototype.. find the real one.
+ (or (and scope
+ (car-safe
+ (semantic-scope-find (semantic-tag-name ans)
+ 'type scope)))
+ (let ((tcsans nil))
+ (prog1
+ (setq tcsans
+ (semanticdb-typecache-find (semantic-tag-name ans)))
+ ;; While going through the metatype, if we have
+ ;; a scope, push our new cache in.
+ (when scope
+ (semantic-scope-set-typecache
+ scope (semantic-scope-tag-get-scope tcsans))
+ ))))
+ ;; We have a tag, and it is not a prototype.
+ ans))
+ ))
+
+(provide 'semantic/analyze/fcn)
+
+;;; semantic/analyze/fcn.el ends here
Index: cedet/semantic/analyze/refs.el
===================================================================
RCS file: cedet/semantic/analyze/refs.el
diff -N cedet/semantic/analyze/refs.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/analyze/refs.el 28 Sep 2009 15:15:10 -0000 1.2
@@ -0,0 +1,332 @@
+;;; semantic/analyze/refs.el --- Analysis of the references between tags.
+
+;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Analyze the references between tags.
+;;
+;; The original purpose of these analysis is to provide a way to jump
+;; between a prototype and implementation.
+;;
+;; Finding all prototype/impl matches is hard because you have to search
+;; through the entire set of allowed databases to capture all possible
+;; refs. The core analysis class stores basic starting point, and then
+;; entire raw search data, which is expensive to calculate.
+;;
+;; Once the raw data is available, queries for impl, prototype, or
+;; perhaps other things become cheap.
+
+(require 'semantic)
+(require 'semantic/analyze)
+(require 'semantic/db-find)
+(eval-when-compile (require 'semantic/find))
+
+(declare-function data-debug-new-buffer "data-debug")
+(declare-function data-debug-insert-object-slots "eieio-datadebug")
+(declare-function semantic-momentary-highlight-tag "semantic/decorate")
+
+;;; Code:
+(defclass semantic-analyze-references ()
+ ((tag :initarg :tag
+ :type semantic-tag
+ :documentation
+ "The starting TAG we are providing references analysis for.")
+ (tagdb :initarg :tagdb
+ :documentation
+ "The database that tag can be found in.")
+ (scope :initarg :scope
+ :documentation "A Scope object.")
+ (rawsearchdata :initarg :rawsearchdata
+ :documentation
+ "The raw search data for TAG's name across all databases.")
+ ;; Note: Should I cache queried data here? I expect that searching
+ ;; through rawsearchdata will be super-fast, so why bother?
+ )
+ "Class containing data from a semantic analysis.")
+
+(define-overloadable-function semantic-analyze-tag-references (tag &optional
db)
+ "Analyze the references for TAG.
+Returns a class with information about TAG.
+
+Optional argument DB is a database. It will be used to help
+locate TAG.
+
+Use `semantic-analyze-current-tag' to debug this fcn.")
+
+(defun semantic-analyze-tag-references-default (tag &optional db)
+ "Analyze the references for TAG.
+Returns a class with information about TAG.
+
+Optional argument DB is a database. It will be used to help
+locate TAG.
+
+Use `semantic-analyze-current-tag' to debug this fcn."
+ (when (not (semantic-tag-p tag)) (signal 'wrong-type-argument (list
'semantic-tag-p tag)))
+ (let ((allhits nil)
+ (scope nil)
+ )
+ (save-excursion
+ (semantic-go-to-tag tag db)
+ (setq scope (semantic-calculate-scope))
+
+ (setq allhits (semantic--analyze-refs-full-lookup tag scope))
+
+ (semantic-analyze-references (semantic-tag-name tag)
+ :tag tag
+ :tagdb db
+ :scope scope
+ :rawsearchdata allhits)
+ )))
+
+;;; METHODS
+;;
+;; These accessor methods will calculate the useful bits from the context, and
cache values
+;; into the context.
+(defmethod semantic-analyze-refs-impl ((refs semantic-analyze-references)
&optional in-buffer)
+ "Return the implementations derived in the reference analyzer REFS.
+Optional argument IN-BUFFER indicates that the returned tag should be in an
active buffer."
+ (let ((allhits (oref refs rawsearchdata))
+ (impl nil)
+ )
+ (semanticdb-find-result-mapc
+ (lambda (T DB)
+ "Examine T in the database DB, and sont it."
+ (let* ((ans (semanticdb-normalize-one-tag DB T))
+ (aT (cdr ans))
+ (aDB (car ans))
+ )
+ (when (not (semantic-tag-prototype-p aT))
+ (when in-buffer (save-excursion (semantic-go-to-tag aT aDB)))
+ (push aT impl))))
+ allhits)
+ impl))
+
+(defmethod semantic-analyze-refs-proto ((refs semantic-analyze-references)
&optional in-buffer)
+ "Return the prototypes derived in the reference analyzer REFS.
+Optional argument IN-BUFFER indicates that the returned tag should be in an
active buffer."
+ (let ((allhits (oref refs rawsearchdata))
+ (proto nil))
+ (semanticdb-find-result-mapc
+ (lambda (T DB)
+ "Examine T in the database DB, and sort it."
+ (let* ((ans (semanticdb-normalize-one-tag DB T))
+ (aT (cdr ans))
+ (aDB (car ans))
+ )
+ (when (semantic-tag-prototype-p aT)
+ (when in-buffer (save-excursion (semantic-go-to-tag aT aDB)))
+ (push aT proto))))
+ allhits)
+ proto))
+
+;;; LOOKUP
+;;
+(defun semantic--analyze-refs-full-lookup (tag scope)
+ "Perform a full lookup for all occurances of TAG in the current project.
+TAG should be the tag currently under point.
+PARENT is the list of tags that are parents to TAG by
+containment, as opposed to reference."
+ (if (not (oref scope parents))
+ ;; If this tag has some named parent, but is not
+ (semantic--analyze-refs-full-lookup-simple tag)
+
+ ;; We have some sort of lineage we need to consider when we do
+ ;; our side lookup of tags.
+ (semantic--analyze-refs-full-lookup-with-parents tag scope)
+ ))
+
+(defun semantic--analyze-refs-find-child-in-find-results (find-results name
class)
+ "Find in FIND-RESULT a tag NAME which is a child of a tag in FIND-RESULTS.
+CLASS is the class of the tag that ought to be returned."
+ (let ((ans nil)
+ (subans nil))
+ ;; Loop over each segment of the find results.
+ (dolist (FDB find-results)
+ (setq subans nil)
+ ;; Loop over each tag in the find results.
+ (dolist (T (cdr FDB))
+ ;; For each tag, get the children.
+ (let* ((chil (semantic-tag-type-members T))
+ (match (semantic-find-tags-by-name name chil)))
+ ;; Go over the matches, looking for matching tag class.
+ (dolist (M match)
+ (when (semantic-tag-of-class-p M class)
+ (push M subans)))))
+ ;; Store current matches into a new find results.
+ (when subans
+ (push (cons (car FDB) subans) ans))
+ )
+ ans))
+
+(defun semantic--analyze-refs-find-tags-with-parent (find-results parents)
+ "Find in FIND-RESULTS all tags with PARNTS.
+NAME is the name of the tag needing finding.
+PARENTS is a list of names."
+ (let ((ans nil))
+ (semanticdb-find-result-mapc
+ (lambda (tag db)
+ (let* ((p (semantic-tag-named-parent tag))
+ (ps (when (stringp p)
+ (semantic-analyze-split-name p))))
+ (when (stringp ps) (setq ps (list ps)))
+ (when (and ps (equal ps parents))
+ ;; We could optimize this, but it seems unlikely.
+ (push (list db tag) ans))
+ ))
+ find-results)
+ ans))
+
+(defun semantic--analyze-refs-full-lookup-with-parents (tag scope)
+ "Perform a lookup for all occurances of TAG based on TAG's SCOPE.
+TAG should be the tag currently under point."
+ (let* ((classmatch (semantic-tag-class tag))
+ (plist (mapcar (lambda (T) (semantic-tag-name T)) (oref scope
parents)))
+ ;; The first item in the parent list
+ (name (car plist))
+ ;; Stuff from the simple list.
+ (simple (semantic--analyze-refs-full-lookup-simple tag t))
+ ;; Find all hits for the first parent name.
+ (brute (semanticdb-find-tags-collector
+ (lambda (table tags)
+ (semanticdb-find-tags-by-name-method table name tags)
+ )
+ nil nil t))
+ ;; Prime the answer.
+ (answer (semantic--analyze-refs-find-tags-with-parent simple plist))
+ )
+ ;; First parent is already search to initialize "brute".
+ (setq plist (cdr plist))
+ ;; Go through the list of parents, and try to find matches.
+ ;; As we cycle through plist, for each level look for NAME,
+ ;; and compare the named-parent, and also dive into the next item of
+ ;; plist.
+ (while (and plist brute)
+
+ ;; Find direct matches
+ (let* ((direct (semantic--analyze-refs-find-child-in-find-results
+ brute (semantic-tag-name tag) classmatch))
+ (pdirect (semantic--analyze-refs-find-tags-with-parent
+ direct plist)))
+ (setq answer (append pdirect answer)))
+
+ ;; The next set of search items.
+ (setq brute (semantic--analyze-refs-find-child-in-find-results
+ brute (car plist) 'type))
+
+ (setq plist (cdr plist)))
+
+ ;; Brute now has the children from the very last match.
+ (let* ((direct (semantic--analyze-refs-find-child-in-find-results
+ brute (semantic-tag-name tag) classmatch))
+ )
+ (setq answer (append direct answer)))
+
+ answer))
+
+(defun semantic--analyze-refs-full-lookup-simple (tag &optional noerror)
+ "Perform a simple lookup for occurances of TAG in the current project.
+TAG should be the tag currently under point.
+Optional NOERROR means don't throw errors on failure to find something.
+This only compares the tag name, and does not infer any matches in namespaces,
+or parts of some other data structure.
+Only works for tags in the global namespace."
+ (let* ((name (semantic-tag-name tag))
+ (brute (semanticdb-find-tags-collector
+ (lambda (table tags)
+ (semanticdb-find-tags-by-name-method table name tags)
+ )
+ nil nil t))
+ )
+
+ (when (and (not brute) (not noerror))
+ ;; An error, because tag under point ought to be found.
+ (error "Cannot find any references to %s in wide search" name))
+
+ (let* ((classmatch (semantic-tag-class tag))
+ (RES
+ (semanticdb-find-tags-collector
+ (lambda (table tags)
+ (semantic-find-tags-by-class classmatch tags)
+ ;; @todo - Add parent check also.
+ )
+ brute nil)))
+
+ (when (and (not RES) (not noerror))
+ (error "Cannot find any definitions for %s in wide search"
+ (semantic-tag-name tag)))
+
+ ;; Return the matching tags and databases.
+ RES)))
+
+
+;;; USER COMMANDS
+;;
+;;;###autoload
+(defun semantic-analyze-current-tag ()
+ "Analyze the tag under point."
+ (interactive)
+ (let* ((tag (semantic-current-tag))
+ (start (current-time))
+ (sac (semantic-analyze-tag-references tag))
+ (end (current-time))
+ )
+ (message "Analysis took %.2f seconds." (semantic-elapsed-time start end))
+ (if sac
+ (progn
+ (require 'eieio-datadebug)
+ (data-debug-new-buffer "*Analyzer Reference ADEBUG*")
+ (data-debug-insert-object-slots sac "]"))
+ (message "No Context to analyze here."))))
+
+;;;###autoload
+(defun semantic-analyze-proto-impl-toggle ()
+ "Toggle between the implementation, and a prototype of tag under point."
+ (interactive)
+ (require 'semantic/decorate)
+ (semantic-fetch-tags)
+ (let* ((tag (semantic-current-tag))
+ (sar (if tag
+ (semantic-analyze-tag-references tag)
+ (error "Point must be in a declaration")))
+ (target (if (semantic-tag-prototype-p tag)
+ (car (semantic-analyze-refs-impl sar t))
+ (car (semantic-analyze-refs-proto sar t))))
+ )
+
+ (when (not target)
+ (error "Could not find suitable %s"
+ (if (semantic-tag-prototype-p tag) "implementation" "prototype")))
+
+ (push-mark)
+ (semantic-go-to-tag target)
+ (switch-to-buffer (current-buffer))
+ (semantic-momentary-highlight-tag target))
+ )
+
+(provide 'semantic/analyze/refs)
+
+;; Local variables:
+;; generated-autoload-file: "../loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/analyze/refs"
+;; End:
+
+;;; semantic/analyze/refs.el ends here
Index: cedet/semantic/bovine/c-by.el
===================================================================
RCS file: cedet/semantic/bovine/c-by.el
diff -N cedet/semantic/bovine/c-by.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/bovine/c-by.el 28 Sep 2009 15:15:10 -0000 1.2
@@ -0,0 +1,2196 @@
+;;; semantic/bovine/c-by.el --- Generated parser support file
+
+;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+;;; 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; This file was generated from the grammar file semantic/bovine/c.by
+;; in the CEDET repository.
+
+;;; Code:
+
+(require 'semantic/lex)
+(eval-when-compile (require 'semantic/bovine))
+
+(declare-function semantic-c-reconstitute-token "semantic/bovine/c")
+(declare-function semantic-c-reconstitute-template "semantic/bovine/c")
+(declare-function semantic-expand-c-tag "semantic/bovine/c")
+
+(defconst semantic-c-by--keyword-table
+ (semantic-lex-make-keyword-table
+ '(("extern" . EXTERN)
+ ("static" . STATIC)
+ ("const" . CONST)
+ ("volatile" . VOLATILE)
+ ("register" . REGISTER)
+ ("signed" . SIGNED)
+ ("unsigned" . UNSIGNED)
+ ("inline" . INLINE)
+ ("virtual" . VIRTUAL)
+ ("mutable" . MUTABLE)
+ ("struct" . STRUCT)
+ ("union" . UNION)
+ ("enum" . ENUM)
+ ("typedef" . TYPEDEF)
+ ("class" . CLASS)
+ ("typename" . TYPENAME)
+ ("namespace" . NAMESPACE)
+ ("using" . USING)
+ ("new" . NEW)
+ ("delete" . DELETE)
+ ("template" . TEMPLATE)
+ ("throw" . THROW)
+ ("reentrant" . REENTRANT)
+ ("try" . TRY)
+ ("catch" . CATCH)
+ ("operator" . OPERATOR)
+ ("public" . PUBLIC)
+ ("private" . PRIVATE)
+ ("protected" . PROTECTED)
+ ("friend" . FRIEND)
+ ("if" . IF)
+ ("else" . ELSE)
+ ("do" . DO)
+ ("while" . WHILE)
+ ("for" . FOR)
+ ("switch" . SWITCH)
+ ("case" . CASE)
+ ("default" . DEFAULT)
+ ("return" . RETURN)
+ ("break" . BREAK)
+ ("continue" . CONTINUE)
+ ("sizeof" . SIZEOF)
+ ("void" . VOID)
+ ("char" . CHAR)
+ ("wchar_t" . WCHAR)
+ ("short" . SHORT)
+ ("int" . INT)
+ ("long" . LONG)
+ ("float" . FLOAT)
+ ("double" . DOUBLE)
+ ("bool" . BOOL)
+ ("_P" . UNDERP)
+ ("__P" . UNDERUNDERP))
+ '(("__P" summary "Common macro to eliminate prototype compatibility on some
compilers")
+ ("_P" summary "Common macro to eliminate prototype compatibility on some
compilers")
+ ("bool" summary "Primitive boolean type")
+ ("double" summary "Primitive floating-point type (double-precision 64-bit
IEEE 754)")
+ ("float" summary "Primitive floating-point type (single-precision 32-bit
IEEE 754)")
+ ("long" summary "Integral primitive type (-9223372036854775808 to
9223372036854775807)")
+ ("int" summary "Integral Primitive Type: (-2147483648 to 2147483647)")
+ ("short" summary "Integral Primitive Type: (-32768 to 32767)")
+ ("wchar_t" summary "Wide Character Type")
+ ("char" summary "Integral Character Type: (0 to 256)")
+ ("void" summary "Built in typeless type: void")
+ ("sizeof" summary "Compile time macro: sizeof(<type or variable>) // size
in bytes")
+ ("continue" summary "Non-local continue within a loop (for, do/while):
continue;")
+ ("break" summary "Non-local exit within a loop or switch (for, do/while,
switch): break;")
+ ("return" summary "return <value>;")
+ ("default" summary "switch (<variable>) { case <constvalue>: code; ...
default: code; }")
+ ("case" summary "switch (<variable>) { case <constvalue>: code; ...
default: code; }")
+ ("switch" summary "switch (<variable>) { case <constvalue>: code; ...
default: code; }")
+ ("for" summary "for(<init>; <condition>; <increment>) { code }")
+ ("while" summary "do { code } while (<condition>); or while (<condition>)
{ code };")
+ ("do" summary " do { code } while (<condition>);")
+ ("else" summary "if (<condition>) { code } [ else { code } ]")
+ ("if" summary "if (<condition>) { code } [ else { code } ]")
+ ("friend" summary "friend class <CLASSNAME>")
+ ("catch" summary "try { <body> } catch { <catch code> }")
+ ("try" summary "try { <body> } catch { <catch code> }")
+ ("reentrant" summary "<type> <methoddef> (<method args>) reentrant ...")
+ ("throw" summary "<type> <methoddef> (<method args>) throw (<exception>)
...")
+ ("template" summary "template <class TYPE ...> TYPE_OR_FUNCTION")
+ ("delete" summary "delete <object>;")
+ ("new" summary "new <classname>();")
+ ("using" summary "using <namespace>;")
+ ("namespace" summary "Namespace Declaration: namespace <name> { ... };")
+ ("typename" summary "typename is used to handle a qualified name as a
typename;")
+ ("class" summary "Class Declaration: class <name>[:parents] { ... };")
+ ("typedef" summary "Arbitrary Type Declaration: typedef <typedeclaration>
<name>;")
+ ("enum" summary "Enumeration Type Declaration: enum [name] { ... };")
+ ("union" summary "Union Type Declaration: union [name] { ... };")
+ ("struct" summary "Structure Type Declaration: struct [name] { ... };")
+ ("mutable" summary "Member Declaration Modifier: mutable <type> <name>
...")
+ ("virtual" summary "Method Modifier: virtual <type> <name>(...) ...")
+ ("inline" summary "Function Modifier: inline <return type> <name>(...)
{...};")
+ ("unsigned" summary "Numeric Type Modifier: unsigned <numeric type>
<name> ...")
+ ("signed" summary "Numeric Type Modifier: signed <numeric type> <name>
...")
+ ("register" summary "Declaration Modifier: register <type> <name> ...")
+ ("volatile" summary "Declaration Modifier: volatile <type> <name> ...")
+ ("const" summary "Declaration Modifier: const <type> <name> ...")
+ ("static" summary "Declaration Modifier: static <type> <name> ...")
+ ("extern" summary "Declaration Modifier: extern <type> <name> ...")))
+ "Table of language keywords.")
+
+(defconst semantic-c-by--token-table
+ (semantic-lex-make-type-table
+ '(("semantic-list"
+ (BRACKETS . "\\[\\]")
+ (PARENS . "()")
+ (VOID_BLCK . "^(void)$")
+ (BRACE_BLCK . "^{")
+ (PAREN_BLCK . "^(")
+ (BRACK_BLCK . "\\[.*\\]$"))
+ ("close-paren"
+ (RBRACE . "}")
+ (RPAREN . ")"))
+ ("open-paren"
+ (LBRACE . "{")
+ (LPAREN . "("))
+ ("symbol"
+ (RESTRICT . "\\<\\(__\\)?restrict\\>"))
+ ("number"
+ (ZERO . "^0$"))
+ ("string"
+ (CPP . "\"C\\+\\+\"")
+ (C . "\"C\""))
+ ("punctuation"
+ (OR . "\\`[|]\\'")
+ (HAT . "\\`\\^\\'")
+ (MOD . "\\`[%]\\'")
+ (TILDE . "\\`[~]\\'")
+ (COMA . "\\`[,]\\'")
+ (GREATER . "\\`[>]\\'")
+ (LESS . "\\`[<]\\'")
+ (EQUAL . "\\`[=]\\'")
+ (BANG . "\\`[!]\\'")
+ (MINUS . "\\`[-]\\'")
+ (PLUS . "\\`[+]\\'")
+ (DIVIDE . "\\`[/]\\'")
+ (AMPERSAND . "\\`[&]\\'")
+ (STAR . "\\`[*]\\'")
+ (SEMICOLON . "\\`[;]\\'")
+ (COLON . "\\`[:]\\'")
+ (PERIOD . "\\`[.]\\'")
+ (HASH . "\\`[#]\\'")))
+ 'nil)
+ "Table of lexical tokens.")
+
+(defconst semantic-c-by--parse-table
+ `(
+ (bovine-toplevel
+ (declaration)
+ ) ;; end bovine-toplevel
+
+ (bovine-inner-scope
+ (codeblock)
+ ) ;; end bovine-inner-scope
+
+ (declaration
+ (macro)
+ (type)
+ (define)
+ (var-or-fun)
+ (extern-c)
+ (template)
+ (using)
+ ) ;; end declaration
+
+ (codeblock
+ (define)
+ (codeblock-var-or-fun)
+ (type)
+ (using)
+ ) ;; end codeblock
+
+ (extern-c-contents
+ (open-paren
+ ,(semantic-lambda
+ (list nil))
+ )
+ (declaration)
+ (close-paren
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end extern-c-contents
+
+ (extern-c
+ (EXTERN
+ string
+ "\"C\""
+ semantic-list
+ ,(semantic-lambda
+ (semantic-tag
+ "C"
+ 'extern :members
+ (semantic-parse-region
+ (car
+ (nth 2 vals))
+ (cdr
+ (nth 2 vals))
+ 'extern-c-contents
+ 1)))
+ )
+ (EXTERN
+ string
+ "\"C\\+\\+\""
+ semantic-list
+ ,(semantic-lambda
+ (semantic-tag
+ "C"
+ 'extern :members
+ (semantic-parse-region
+ (car
+ (nth 2 vals))
+ (cdr
+ (nth 2 vals))
+ 'extern-c-contents
+ 1)))
+ )
+ (EXTERN
+ string
+ "\"C\""
+ ,(semantic-lambda
+ (list nil))
+ )
+ (EXTERN
+ string
+ "\"C\\+\\+\""
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end extern-c
+
+ (macro
+ (spp-macro-def
+ ,(semantic-lambda
+ (semantic-tag-new-variable
+ (nth 0 vals) nil nil :constant-flag t))
+ )
+ (spp-system-include
+ ,(semantic-lambda
+ (semantic-tag-new-include
+ (nth 0 vals) t))
+ )
+ (spp-include
+ ,(semantic-lambda
+ (semantic-tag-new-include
+ (nth 0 vals) nil))
+ )
+ ) ;; end macro
+
+ (define
+ (spp-macro-def
+ ,(semantic-lambda
+ (semantic-tag-new-variable
+ (nth 0 vals) nil nil :constant-flag t))
+ )
+ (spp-macro-undef
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end define
+
+ (unionparts
+ (semantic-list
+ ,(semantic-lambda
+ (semantic-parse-region
+ (car
+ (nth 0 vals))
+ (cdr
+ (nth 0 vals))
+ 'classsubparts
+ 1))
+ )
+ ) ;; end unionparts
+
+ (opt-symbol
+ (symbol)
+ ( ;;EMPTY
+ )
+ ) ;; end opt-symbol
+
+ (classsubparts
+ (open-paren
+ "{"
+ ,(semantic-lambda
+ (list nil))
+ )
+ (close-paren
+ "}"
+ ,(semantic-lambda
+ (list nil))
+ )
+ (class-protection
+ opt-symbol
+ punctuation
+ "\\`[:]\\'"
+ ,(semantic-lambda
+ (semantic-tag
+ (car
+ (nth 0 vals))
+ 'label))
+ )
+ (var-or-fun)
+ (FRIEND
+ func-decl
+ ,(semantic-lambda
+ (semantic-tag
+ (car
+ (nth 1 vals))
+ 'friend))
+ )
+ (FRIEND
+ CLASS
+ symbol
+ ,(semantic-lambda
+ (semantic-tag
+ (nth 2 vals)
+ 'friend))
+ )
+ (type)
+ (define)
+ (template)
+ ( ;;EMPTY
+ )
+ ) ;; end classsubparts
+
+ (opt-class-parents
+ (punctuation
+ "\\`[:]\\'"
+ class-parents
+ opt-template-specifier
+ ,(semantic-lambda
+ (list
+ (nth 1 vals)))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda)
+ )
+ ) ;; end opt-class-parents
+
+ (one-class-parent
+ (opt-class-protection
+ opt-class-declmods
+ namespace-symbol
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (car
+ (nth 2 vals))
+ "class" nil nil :protection
+ (car
+ (nth 0 vals))))
+ )
+ (opt-class-declmods
+ opt-class-protection
+ namespace-symbol
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (car
+ (nth 2 vals))
+ "class" nil nil :protection
+ (car
+ (nth 1 vals))))
+ )
+ ) ;; end one-class-parent
+
+ (class-parents
+ (one-class-parent
+ punctuation
+ "\\`[,]\\'"
+ class-parents
+ ,(semantic-lambda
+ (cons
+ (nth 0 vals)
+ (nth 2 vals)))
+ )
+ (one-class-parent
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)))
+ )
+ ) ;; end class-parents
+
+ (opt-class-declmods
+ (class-declmods
+ opt-class-declmods
+ ,(semantic-lambda
+ (list nil))
+ )
+ ( ;;EMPTY
+ )
+ ) ;; end opt-class-declmods
+
+ (class-declmods
+ (VIRTUAL)
+ ) ;; end class-declmods
+
+ (class-protection
+ (PUBLIC)
+ (PRIVATE)
+ (PROTECTED)
+ ) ;; end class-protection
+
+ (opt-class-protection
+ (class-protection
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda
+ (list
+ "unspecified"))
+ )
+ ) ;; end opt-class-protection
+
+ (namespaceparts
+ (semantic-list
+ ,(semantic-lambda
+ (semantic-parse-region
+ (car
+ (nth 0 vals))
+ (cdr
+ (nth 0 vals))
+ 'namespacesubparts
+ 1))
+ )
+ ) ;; end namespaceparts
+
+ (namespacesubparts
+ (open-paren
+ "{"
+ ,(semantic-lambda
+ (list nil))
+ )
+ (close-paren
+ "}"
+ ,(semantic-lambda
+ (list nil))
+ )
+ (type)
+ (var-or-fun)
+ (define)
+ (class-protection
+ punctuation
+ "\\`[:]\\'"
+ ,(semantic-lambda
+ (semantic-tag
+ (car
+ (nth 0 vals))
+ 'label))
+ )
+ (template)
+ (using)
+ ( ;;EMPTY
+ )
+ ) ;; end namespacesubparts
+
+ (enumparts
+ (semantic-list
+ ,(semantic-lambda
+ (semantic-parse-region
+ (car
+ (nth 0 vals))
+ (cdr
+ (nth 0 vals))
+ 'enumsubparts
+ 1))
+ )
+ ) ;; end enumparts
+
+ (enumsubparts
+ (symbol
+ opt-assign
+ ,(semantic-lambda
+ (semantic-tag-new-variable
+ (nth 0 vals)
+ "int"
+ (car
+ (nth 1 vals)) :constant-flag t))
+ )
+ (open-paren
+ "{"
+ ,(semantic-lambda
+ (list nil))
+ )
+ (close-paren
+ "}"
+ ,(semantic-lambda
+ (list nil))
+ )
+ (punctuation
+ "\\`[,]\\'"
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end enumsubparts
+
+ (opt-name
+ (symbol)
+ ( ;;EMPTY
+ ,(semantic-lambda
+ (list
+ ""))
+ )
+ ) ;; end opt-name
+
+ (typesimple
+ (struct-or-class
+ opt-class
+ opt-name
+ opt-template-specifier
+ opt-class-parents
+ semantic-list
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (car
+ (nth 2 vals))
+ (car
+ (nth 0 vals))
+ (let
+ (
+ (semantic-c-classname
+ (cons
+ (car
+ (nth 2 vals))
+ (car
+ (nth 0 vals)))))
+ (semantic-parse-region
+ (car
+ (nth 5 vals))
+ (cdr
+ (nth 5 vals))
+ 'classsubparts
+ 1))
+ (nth 4 vals) :template-specifier
+ (nth 3 vals) :parent
+ (car
+ (nth 1 vals))))
+ )
+ (struct-or-class
+ opt-class
+ opt-name
+ opt-template-specifier
+ opt-class-parents
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (car
+ (nth 2 vals))
+ (car
+ (nth 0 vals)) nil
+ (nth 4 vals) :template-specifier
+ (nth 3 vals) :prototype t :parent
+ (car
+ (nth 1 vals))))
+ )
+ (UNION
+ opt-class
+ opt-name
+ unionparts
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (car
+ (nth 2 vals))
+ (nth 0 vals)
+ (nth 3 vals) nil :parent
+ (car
+ (nth 1 vals))))
+ )
+ (ENUM
+ opt-class
+ opt-name
+ enumparts
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (car
+ (nth 2 vals))
+ (nth 0 vals)
+ (nth 3 vals) nil :parent
+ (car
+ (nth 1 vals))))
+ )
+ (TYPEDEF
+ declmods
+ typeformbase
+ cv-declmods
+ typedef-symbol-list
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (nth 4 vals)
+ (nth 0 vals) nil
+ (list
+ (nth 2 vals))))
+ )
+ ) ;; end typesimple
+
+ (typedef-symbol-list
+ (typedefname
+ punctuation
+ "\\`[,]\\'"
+ typedef-symbol-list
+ ,(semantic-lambda
+ (cons
+ (nth 0 vals)
+ (nth 2 vals)))
+ )
+ (typedefname
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)))
+ )
+ ) ;; end typedef-symbol-list
+
+ (typedefname
+ (opt-stars
+ symbol
+ opt-bits
+ opt-array
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)
+ (nth 1 vals)))
+ )
+ ) ;; end typedefname
+
+ (struct-or-class
+ (STRUCT)
+ (CLASS)
+ ) ;; end struct-or-class
+
+ (type
+ (typesimple
+ punctuation
+ "\\`[;]\\'"
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ (NAMESPACE
+ symbol
+ namespaceparts
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (nth 1 vals)
+ (nth 0 vals)
+ (nth 2 vals) nil))
+ )
+ (NAMESPACE
+ namespaceparts
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ "unnamed"
+ (nth 0 vals)
+ (nth 1 vals) nil))
+ )
+ (NAMESPACE
+ symbol
+ punctuation
+ "\\`[=]\\'"
+ typeformbase
+ punctuation
+ "\\`[;]\\'"
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (nth 1 vals)
+ (nth 0 vals)
+ (list
+ (semantic-tag-new-type
+ (car
+ (nth 3 vals))
+ (nth 0 vals) nil nil)) nil :kind
+ 'alias))
+ )
+ ) ;; end type
+
+ (using
+ (USING
+ usingname
+ punctuation
+ "\\`[;]\\'"
+ ,(semantic-lambda
+ (semantic-tag
+ (car
+ (nth 1 vals))
+ 'using :type
+ (nth 1 vals)))
+ )
+ ) ;; end using
+
+ (usingname
+ (typeformbase
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (car
+ (nth 0 vals))
+ "class" nil nil :prototype t))
+ )
+ (NAMESPACE
+ typeformbase
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (car
+ (nth 1 vals))
+ "namespace" nil nil :prototype t))
+ )
+ ) ;; end usingname
+
+ (template
+ (TEMPLATE
+ template-specifier
+ opt-friend
+ template-definition
+ ,(semantic-lambda
+ (semantic-c-reconstitute-template
+ (nth 3 vals)
+ (nth 1 vals)))
+ )
+ ) ;; end template
+
+ (opt-friend
+ (FRIEND)
+ ( ;;EMPTY
+ )
+ ) ;; end opt-friend
+
+ (opt-template-specifier
+ (template-specifier
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda)
+ )
+ ) ;; end opt-template-specifier
+
+ (template-specifier
+ (punctuation
+ "\\`[<]\\'"
+ template-specifier-types
+ punctuation
+ "\\`[>]\\'"
+ ,(semantic-lambda
+ (nth 1 vals))
+ )
+ ) ;; end template-specifier
+
+ (template-specifier-types
+ (template-var
+ template-specifier-type-list
+ ,(semantic-lambda
+ (cons
+ (nth 0 vals)
+ (nth 1 vals)))
+ )
+ ( ;;EMPTY
+ )
+ ) ;; end template-specifier-types
+
+ (template-specifier-type-list
+ (punctuation
+ "\\`[,]\\'"
+ template-specifier-types
+ ,(semantic-lambda
+ (nth 1 vals))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda)
+ )
+ ) ;; end template-specifier-type-list
+
+ (template-var
+ (template-type
+ opt-template-equal
+ ,(semantic-lambda
+ (cons
+ (car
+ (nth 0 vals))
+ (cdr
+ (nth 0 vals))))
+ )
+ (string
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)))
+ )
+ (number
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)))
+ )
+ (opt-stars
+ opt-ref
+ namespace-symbol
+ ,(semantic-lambda
+ (nth 2 vals))
+ )
+ (semantic-list
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)))
+ )
+ (SIZEOF
+ semantic-list
+ ,(semantic-lambda
+ (list
+ (nth 1 vals)))
+ )
+ ) ;; end template-var
+
+ (opt-template-equal
+ (punctuation
+ "\\`[=]\\'"
+ symbol
+ punctuation
+ "\\`[<]\\'"
+ template-specifier-types
+ punctuation
+ "\\`[>]\\'"
+ ,(semantic-lambda
+ (list
+ (nth 1 vals)))
+ )
+ (punctuation
+ "\\`[=]\\'"
+ symbol
+ ,(semantic-lambda
+ (list
+ (nth 1 vals)))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda)
+ )
+ ) ;; end opt-template-equal
+
+ (template-type
+ (CLASS
+ symbol
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (nth 1 vals)
+ "class" nil nil))
+ )
+ (STRUCT
+ symbol
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (nth 1 vals)
+ "struct" nil nil))
+ )
+ (TYPENAME
+ symbol
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (nth 1 vals)
+ "class" nil nil))
+ )
+ (declmods
+ typeformbase
+ cv-declmods
+ opt-stars
+ opt-ref
+ variablearg-opt-name
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (car
+ (nth 1 vals)) nil nil nil :constant-flag
+ (if
+ (member
+ "const"
+ (append
+ (nth 0 vals)
+ (nth 2 vals))) t nil) :typemodifiers
+ (delete
+ "const"
+ (append
+ (nth 0 vals)
+ (nth 2 vals))) :reference
+ (car
+ (nth 4 vals)) :pointer
+ (car
+ (nth 3 vals))))
+ )
+ ) ;; end template-type
+
+ (template-definition
+ (type
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ (var-or-fun
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ ) ;; end template-definition
+
+ (opt-stars
+ (punctuation
+ "\\`[*]\\'"
+ opt-starmod
+ opt-stars
+ ,(semantic-lambda
+ (list
+ (1+
+ (car
+ (nth 2 vals)))))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda
+ (list
+ 0))
+ )
+ ) ;; end opt-stars
+
+ (opt-starmod
+ (STARMOD
+ opt-starmod
+ ,(semantic-lambda
+ (cons
+ (car
+ (nth 0 vals))
+ (nth 1 vals)))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda)
+ )
+ ) ;; end opt-starmod
+
+ (STARMOD
+ (CONST)
+ ) ;; end STARMOD
+
+ (declmods
+ (DECLMOD
+ declmods
+ ,(semantic-lambda
+ (cons
+ (car
+ (nth 0 vals))
+ (nth 1 vals)))
+ )
+ (DECLMOD
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda)
+ )
+ ) ;; end declmods
+
+ (DECLMOD
+ (EXTERN)
+ (STATIC)
+ (CVDECLMOD)
+ (INLINE)
+ (REGISTER)
+ (FRIEND)
+ (TYPENAME)
+ (METADECLMOD)
+ (VIRTUAL)
+ ) ;; end DECLMOD
+
+ (metadeclmod
+ (METADECLMOD
+ ,(semantic-lambda)
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda)
+ )
+ ) ;; end metadeclmod
+
+ (CVDECLMOD
+ (CONST)
+ (VOLATILE)
+ ) ;; end CVDECLMOD
+
+ (cv-declmods
+ (CVDECLMOD
+ cv-declmods
+ ,(semantic-lambda
+ (cons
+ (car
+ (nth 0 vals))
+ (nth 1 vals)))
+ )
+ (CVDECLMOD
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda)
+ )
+ ) ;; end cv-declmods
+
+ (METADECLMOD
+ (VIRTUAL)
+ (MUTABLE)
+ ) ;; end METADECLMOD
+
+ (opt-ref
+ (punctuation
+ "\\`[&]\\'"
+ ,(semantic-lambda
+ (list
+ 1))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda
+ (list
+ 0))
+ )
+ ) ;; end opt-ref
+
+ (typeformbase
+ (typesimple
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ (STRUCT
+ symbol
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (nth 1 vals)
+ (nth 0 vals) nil nil))
+ )
+ (UNION
+ symbol
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (nth 1 vals)
+ (nth 0 vals) nil nil))
+ )
+ (ENUM
+ symbol
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (nth 1 vals)
+ (nth 0 vals) nil nil))
+ )
+ (builtintype
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ (symbol
+ template-specifier
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (nth 0 vals)
+ "class" nil nil :template-specifier
+ (nth 1 vals)))
+ )
+ (namespace-symbol-for-typeformbase
+ opt-template-specifier
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (car
+ (nth 0 vals))
+ "class" nil nil :template-specifier
+ (nth 1 vals)))
+ )
+ (symbol
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)))
+ )
+ ) ;; end typeformbase
+
+ (signedmod
+ (UNSIGNED)
+ (SIGNED)
+ ) ;; end signedmod
+
+ (builtintype-types
+ (VOID)
+ (CHAR)
+ (WCHAR)
+ (SHORT
+ INT
+ ,(semantic-lambda
+ (list
+ (concat
+ (nth 0 vals)
+ " "
+ (nth 1 vals))))
+ )
+ (SHORT)
+ (INT)
+ (LONG
+ INT
+ ,(semantic-lambda
+ (list
+ (concat
+ (nth 0 vals)
+ " "
+ (nth 1 vals))))
+ )
+ (FLOAT)
+ (DOUBLE)
+ (BOOL)
+ (LONG
+ DOUBLE
+ ,(semantic-lambda
+ (list
+ (concat
+ (nth 0 vals)
+ " "
+ (nth 1 vals))))
+ )
+ (LONG
+ LONG
+ ,(semantic-lambda
+ (list
+ (concat
+ (nth 0 vals)
+ " "
+ (nth 1 vals))))
+ )
+ (LONG)
+ ) ;; end builtintype-types
+
+ (builtintype
+ (signedmod
+ builtintype-types
+ ,(semantic-lambda
+ (list
+ (concat
+ (car
+ (nth 0 vals))
+ " "
+ (car
+ (nth 1 vals)))))
+ )
+ (builtintype-types
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ (signedmod
+ ,(semantic-lambda
+ (list
+ (concat
+ (car
+ (nth 0 vals))
+ " int")))
+ )
+ ) ;; end builtintype
+
+ (codeblock-var-or-fun
+ (declmods
+ typeformbase
+ declmods
+ opt-ref
+ var-or-func-decl
+ ,(semantic-lambda
+ (semantic-c-reconstitute-token
+ (nth 4 vals)
+ (nth 0 vals)
+ (nth 1 vals)))
+ )
+ ) ;; end codeblock-var-or-fun
+
+ (var-or-fun
+ (codeblock-var-or-fun
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ (declmods
+ var-or-func-decl
+ ,(semantic-lambda
+ (semantic-c-reconstitute-token
+ (nth 1 vals)
+ (nth 0 vals) nil))
+ )
+ ) ;; end var-or-fun
+
+ (var-or-func-decl
+ (func-decl
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ (var-decl
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ ) ;; end var-or-func-decl
+
+ (func-decl
+ (opt-stars
+ opt-class
+ opt-destructor
+ functionname
+ opt-template-specifier
+ opt-under-p
+ arg-list
+ opt-post-fcn-modifiers
+ opt-throw
+ opt-initializers
+ fun-or-proto-end
+ ,(semantic-lambda
+ (nth 3 vals)
+ (list
+ 'function
+ (nth 1 vals)
+ (nth 2 vals)
+ (nth 6 vals)
+ (nth 8 vals)
+ (nth 7 vals))
+ (nth 0 vals)
+ (nth 10 vals)
+ (nth 4 vals))
+ )
+ (opt-stars
+ opt-class
+ opt-destructor
+ functionname
+ opt-template-specifier
+ opt-under-p
+ opt-post-fcn-modifiers
+ opt-throw
+ opt-initializers
+ fun-try-end
+ ,(semantic-lambda
+ (nth 3 vals)
+ (list
+ 'function
+ (nth 1 vals)
+ (nth 2 vals) nil
+ (nth 7 vals)
+ (nth 6 vals))
+ (nth 0 vals)
+ (nth 9 vals)
+ (nth 4 vals))
+ )
+ ) ;; end func-decl
+
+ (var-decl
+ (varnamelist
+ punctuation
+ "\\`[;]\\'"
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)
+ 'variable))
+ )
+ ) ;; end var-decl
+
+ (opt-under-p
+ (UNDERP
+ ,(semantic-lambda
+ (list nil))
+ )
+ (UNDERUNDERP
+ ,(semantic-lambda
+ (list nil))
+ )
+ ( ;;EMPTY
+ )
+ ) ;; end opt-under-p
+
+ (opt-initializers
+ (punctuation
+ "\\`[:]\\'"
+ namespace-symbol
+ semantic-list
+ opt-initializers)
+ (punctuation
+ "\\`[,]\\'"
+ namespace-symbol
+ semantic-list
+ opt-initializers)
+ ( ;;EMPTY
+ )
+ ) ;; end opt-initializers
+
+ (opt-post-fcn-modifiers
+ (post-fcn-modifiers
+ opt-post-fcn-modifiers
+ ,(semantic-lambda
+ (cons
+ (nth 0 vals)
+ (nth 1 vals)))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end opt-post-fcn-modifiers
+
+ (post-fcn-modifiers
+ (REENTRANT)
+ (CONST)
+ ) ;; end post-fcn-modifiers
+
+ (opt-throw
+ (THROW
+ semantic-list
+ ,(lambda (vals start end)
+ (semantic-bovinate-from-nonterminal
+ (car
+ (nth 1 vals))
+ (cdr
+ (nth 1 vals))
+ 'throw-exception-list))
+ )
+ ( ;;EMPTY
+ )
+ ) ;; end opt-throw
+
+ (throw-exception-list
+ (namespace-symbol
+ punctuation
+ "\\`[,]\\'"
+ throw-exception-list
+ ,(semantic-lambda
+ (cons
+ (car
+ (nth 0 vals))
+ (nth 2 vals)))
+ )
+ (namespace-symbol
+ close-paren
+ ")"
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ (symbol
+ close-paren
+ ")"
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)))
+ )
+ (open-paren
+ "("
+ throw-exception-list
+ ,(semantic-lambda
+ (nth 1 vals))
+ )
+ (close-paren
+ ")"
+ ,(semantic-lambda)
+ )
+ ) ;; end throw-exception-list
+
+ (opt-bits
+ (punctuation
+ "\\`[:]\\'"
+ number
+ ,(semantic-lambda
+ (list
+ (nth 1 vals)))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end opt-bits
+
+ (opt-array
+ (semantic-list
+ "\\[.*\\]$"
+ opt-array
+ ,(semantic-lambda
+ (list
+ (cons
+ 1
+ (car
+ (nth 1 vals)))))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end opt-array
+
+ (opt-assign
+ (punctuation
+ "\\`[=]\\'"
+ expression
+ ,(semantic-lambda
+ (list
+ (nth 1 vals)))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end opt-assign
+
+ (opt-restrict
+ (symbol
+ "\\<\\(__\\)?restrict\\>")
+ ( ;;EMPTY
+ )
+ ) ;; end opt-restrict
+
+ (varname
+ (opt-stars
+ opt-restrict
+ namespace-symbol
+ opt-bits
+ opt-array
+ opt-assign
+ ,(semantic-lambda
+ (nth 2 vals)
+ (nth 0 vals)
+ (nth 3 vals)
+ (nth 4 vals)
+ (nth 5 vals))
+ )
+ ) ;; end varname
+
+ (variablearg
+ (declmods
+ typeformbase
+ cv-declmods
+ opt-ref
+ variablearg-opt-name
+ ,(semantic-lambda
+ (semantic-tag-new-variable
+ (list
+ (nth 4 vals))
+ (nth 1 vals) nil :constant-flag
+ (if
+ (member
+ "const"
+ (append
+ (nth 0 vals)
+ (nth 2 vals))) t nil) :typemodifiers
+ (delete
+ "const"
+ (append
+ (nth 0 vals)
+ (nth 2 vals))) :reference
+ (car
+ (nth 3 vals))))
+ )
+ ) ;; end variablearg
+
+ (variablearg-opt-name
+ (varname
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ (opt-stars
+ ,(semantic-lambda
+ (list
+ "")
+ (nth 0 vals)
+ (list nil nil nil))
+ )
+ ) ;; end variablearg-opt-name
+
+ (varnamelist
+ (opt-ref
+ varname
+ punctuation
+ "\\`[,]\\'"
+ varnamelist
+ ,(semantic-lambda
+ (cons
+ (nth 1 vals)
+ (nth 3 vals)))
+ )
+ (opt-ref
+ varname
+ ,(semantic-lambda
+ (list
+ (nth 1 vals)))
+ )
+ ) ;; end varnamelist
+
+ (namespace-symbol
+ (symbol
+ opt-template-specifier
+ punctuation
+ "\\`[:]\\'"
+ punctuation
+ "\\`[:]\\'"
+ namespace-symbol
+ ,(semantic-lambda
+ (list
+ (concat
+ (nth 0 vals)
+ "::"
+ (car
+ (nth 4 vals)))))
+ )
+ (symbol
+ opt-template-specifier
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)))
+ )
+ ) ;; end namespace-symbol
+
+ (namespace-symbol-for-typeformbase
+ (symbol
+ opt-template-specifier
+ punctuation
+ "\\`[:]\\'"
+ punctuation
+ "\\`[:]\\'"
+ namespace-symbol-for-typeformbase
+ ,(semantic-lambda
+ (list
+ (concat
+ (nth 0 vals)
+ "::"
+ (car
+ (nth 4 vals)))))
+ )
+ (symbol
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)))
+ )
+ ) ;; end namespace-symbol-for-typeformbase
+
+ (namespace-opt-class
+ (symbol
+ punctuation
+ "\\`[:]\\'"
+ punctuation
+ "\\`[:]\\'"
+ namespace-opt-class
+ ,(semantic-lambda
+ (list
+ (concat
+ (nth 0 vals)
+ "::"
+ (car
+ (nth 3 vals)))))
+ )
+ (symbol
+ opt-template-specifier
+ punctuation
+ "\\`[:]\\'"
+ punctuation
+ "\\`[:]\\'"
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)))
+ )
+ ) ;; end namespace-opt-class
+
+ (opt-class
+ (namespace-opt-class
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end opt-class
+
+ (opt-destructor
+ (punctuation
+ "\\`[~]\\'"
+ ,(semantic-lambda
+ (list t))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end opt-destructor
+
+ (arg-list
+ (semantic-list
+ "^("
+ knr-arguments
+ ,(semantic-lambda
+ (nth 1 vals))
+ )
+ (semantic-list
+ "^("
+ ,(semantic-lambda
+ (semantic-parse-region
+ (car
+ (nth 0 vals))
+ (cdr
+ (nth 0 vals))
+ 'arg-sub-list
+ 1))
+ )
+ (semantic-list
+ "^(void)$"
+ ,(semantic-lambda)
+ )
+ ) ;; end arg-list
+
+ (knr-varnamelist
+ (varname
+ punctuation
+ "\\`[,]\\'"
+ knr-varnamelist
+ ,(semantic-lambda
+ (cons
+ (nth 0 vals)
+ (nth 2 vals)))
+ )
+ (varname
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)))
+ )
+ ) ;; end knr-varnamelist
+
+ (knr-one-variable-decl
+ (declmods
+ typeformbase
+ cv-declmods
+ knr-varnamelist
+ ,(semantic-lambda
+ (semantic-tag-new-variable
+ (nreverse
+ (nth 3 vals))
+ (nth 1 vals) nil :constant-flag
+ (if
+ (member
+ "const"
+ (append
+ (nth 2 vals))) t nil) :typemodifiers
+ (delete
+ "const"
+ (nth 2 vals))))
+ )
+ ) ;; end knr-one-variable-decl
+
+ (knr-arguments
+ (knr-one-variable-decl
+ punctuation
+ "\\`[;]\\'"
+ knr-arguments
+ ,(semantic-lambda
+ (append
+ (semantic-expand-c-tag
+ (nth 0 vals))
+ (nth 2 vals)))
+ )
+ (knr-one-variable-decl
+ punctuation
+ "\\`[;]\\'"
+ ,(semantic-lambda
+ (semantic-expand-c-tag
+ (nth 0 vals)))
+ )
+ ) ;; end knr-arguments
+
+ (arg-sub-list
+ (variablearg
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ (punctuation
+ "\\`[.]\\'"
+ punctuation
+ "\\`[.]\\'"
+ punctuation
+ "\\`[.]\\'"
+ close-paren
+ ")"
+ ,(semantic-lambda
+ (semantic-tag-new-variable
+ "..."
+ "vararg" nil))
+ )
+ (punctuation
+ "\\`[,]\\'"
+ ,(semantic-lambda
+ (list nil))
+ )
+ (open-paren
+ "("
+ ,(semantic-lambda
+ (list nil))
+ )
+ (close-paren
+ ")"
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end arg-sub-list
+
+ (operatorsym
+ (punctuation
+ "\\`[<]\\'"
+ punctuation
+ "\\`[<]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda
+ (list
+ "<<="))
+ )
+ (punctuation
+ "\\`[>]\\'"
+ punctuation
+ "\\`[>]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda
+ (list
+ ">>="))
+ )
+ (punctuation
+ "\\`[<]\\'"
+ punctuation
+ "\\`[<]\\'"
+ ,(semantic-lambda
+ (list
+ "<<"))
+ )
+ (punctuation
+ "\\`[>]\\'"
+ punctuation
+ "\\`[>]\\'"
+ ,(semantic-lambda
+ (list
+ ">>"))
+ )
+ (punctuation
+ "\\`[=]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda
+ (list
+ "=="))
+ )
+ (punctuation
+ "\\`[<]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda
+ (list
+ "<="))
+ )
+ (punctuation
+ "\\`[>]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda
+ (list
+ ">="))
+ )
+ (punctuation
+ "\\`[!]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda
+ (list
+ "!="))
+ )
+ (punctuation
+ "\\`[+]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda
+ (list
+ "+="))
+ )
+ (punctuation
+ "\\`[-]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda
+ (list
+ "-="))
+ )
+ (punctuation
+ "\\`[*]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda
+ (list
+ "*="))
+ )
+ (punctuation
+ "\\`[/]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda
+ (list
+ "/="))
+ )
+ (punctuation
+ "\\`[%]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda
+ (list
+ "%="))
+ )
+ (punctuation
+ "\\`[&]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda
+ (list
+ "&="))
+ )
+ (punctuation
+ "\\`[|]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda
+ (list
+ "|="))
+ )
+ (punctuation
+ "\\`[-]\\'"
+ punctuation
+ "\\`[>]\\'"
+ punctuation
+ "\\`[*]\\'"
+ ,(semantic-lambda
+ (list
+ "->*"))
+ )
+ (punctuation
+ "\\`[-]\\'"
+ punctuation
+ "\\`[>]\\'"
+ ,(semantic-lambda
+ (list
+ "->"))
+ )
+ (semantic-list
+ "()"
+ ,(semantic-lambda
+ (list
+ "()"))
+ )
+ (semantic-list
+ "\\[\\]"
+ ,(semantic-lambda
+ (list
+ "[]"))
+ )
+ (punctuation
+ "\\`[<]\\'")
+ (punctuation
+ "\\`[>]\\'")
+ (punctuation
+ "\\`[*]\\'")
+ (punctuation
+ "\\`[+]\\'"
+ punctuation
+ "\\`[+]\\'"
+ ,(semantic-lambda
+ (list
+ "++"))
+ )
+ (punctuation
+ "\\`[+]\\'")
+ (punctuation
+ "\\`[-]\\'"
+ punctuation
+ "\\`[-]\\'"
+ ,(semantic-lambda
+ (list
+ "--"))
+ )
+ (punctuation
+ "\\`[-]\\'")
+ (punctuation
+ "\\`[&]\\'"
+ punctuation
+ "\\`[&]\\'"
+ ,(semantic-lambda
+ (list
+ "&&"))
+ )
+ (punctuation
+ "\\`[&]\\'")
+ (punctuation
+ "\\`[|]\\'"
+ punctuation
+ "\\`[|]\\'"
+ ,(semantic-lambda
+ (list
+ "||"))
+ )
+ (punctuation
+ "\\`[|]\\'")
+ (punctuation
+ "\\`[/]\\'")
+ (punctuation
+ "\\`[=]\\'")
+ (punctuation
+ "\\`[!]\\'")
+ (punctuation
+ "\\`[~]\\'")
+ (punctuation
+ "\\`[%]\\'")
+ (punctuation
+ "\\`[,]\\'")
+ (punctuation
+ "\\`\\^\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda
+ (list
+ "^="))
+ )
+ (punctuation
+ "\\`\\^\\'")
+ ) ;; end operatorsym
+
+ (functionname
+ (OPERATOR
+ operatorsym
+ ,(semantic-lambda
+ (nth 1 vals))
+ )
+ (semantic-list
+ ,(lambda (vals start end)
+ (semantic-bovinate-from-nonterminal
+ (car
+ (nth 0 vals))
+ (cdr
+ (nth 0 vals))
+ 'function-pointer))
+ )
+ (symbol
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)))
+ )
+ ) ;; end functionname
+
+ (function-pointer
+ (open-paren
+ "("
+ punctuation
+ "\\`[*]\\'"
+ symbol
+ close-paren
+ ")"
+ ,(semantic-lambda
+ (list
+ (concat
+ "*"
+ (nth 2 vals))))
+ )
+ ) ;; end function-pointer
+
+ (fun-or-proto-end
+ (punctuation
+ "\\`[;]\\'"
+ ,(semantic-lambda
+ (list t))
+ )
+ (semantic-list
+ ,(semantic-lambda
+ (list nil))
+ )
+ (punctuation
+ "\\`[=]\\'"
+ number
+ "^0$"
+ punctuation
+ "\\`[;]\\'"
+ ,(semantic-lambda
+ (list ':pure-virtual-flag))
+ )
+ (fun-try-end
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end fun-or-proto-end
+
+ (fun-try-end
+ (TRY
+ opt-initializers
+ semantic-list
+ "^{"
+ fun-try-several-catches
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end fun-try-end
+
+ (fun-try-several-catches
+ (CATCH
+ semantic-list
+ "^("
+ semantic-list
+ "^{"
+ fun-try-several-catches
+ ,(semantic-lambda)
+ )
+ (CATCH
+ semantic-list
+ "^{"
+ fun-try-several-catches
+ ,(semantic-lambda)
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda)
+ )
+ ) ;; end fun-try-several-catches
+
+ (type-cast
+ (semantic-list
+ ,(lambda (vals start end)
+ (semantic-bovinate-from-nonterminal
+ (car
+ (nth 0 vals))
+ (cdr
+ (nth 0 vals))
+ 'type-cast-list))
+ )
+ ) ;; end type-cast
+
+ (type-cast-list
+ (open-paren
+ typeformbase
+ close-paren)
+ ) ;; end type-cast-list
+
+ (opt-stuff-after-symbol
+ (semantic-list
+ "^(")
+ (semantic-list
+ "\\[.*\\]$")
+ ( ;;EMPTY
+ )
+ ) ;; end opt-stuff-after-symbol
+
+ (multi-stage-dereference
+ (namespace-symbol
+ opt-stuff-after-symbol
+ punctuation
+ "\\`[.]\\'"
+ multi-stage-dereference)
+ (namespace-symbol
+ opt-stuff-after-symbol
+ punctuation
+ "\\`[-]\\'"
+ punctuation
+ "\\`[>]\\'"
+ multi-stage-dereference)
+ (namespace-symbol
+ opt-stuff-after-symbol)
+ ) ;; end multi-stage-dereference
+
+ (string-seq
+ (string
+ string-seq
+ ,(semantic-lambda
+ (list
+ (concat
+ (nth 0 vals)
+ (car
+ (nth 1 vals)))))
+ )
+ (string
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)))
+ )
+ ) ;; end string-seq
+
+ (expr-start
+ (punctuation
+ "\\`[-]\\'")
+ (punctuation
+ "\\`[+]\\'")
+ (punctuation
+ "\\`[*]\\'")
+ (punctuation
+ "\\`[&]\\'")
+ ) ;; end expr-start
+
+ (expression
+ (number
+ ,(semantic-lambda
+ (list
+ (identity start)
+ (identity end)))
+ )
+ (multi-stage-dereference
+ ,(semantic-lambda
+ (list
+ (identity start)
+ (identity end)))
+ )
+ (NEW
+ multi-stage-dereference
+ ,(semantic-lambda
+ (list
+ (identity start)
+ (identity end)))
+ )
+ (NEW
+ builtintype-types
+ semantic-list
+ ,(semantic-lambda
+ (list
+ (identity start)
+ (identity end)))
+ )
+ (namespace-symbol
+ ,(semantic-lambda
+ (list
+ (identity start)
+ (identity end)))
+ )
+ (string-seq
+ ,(semantic-lambda
+ (list
+ (identity start)
+ (identity end)))
+ )
+ (type-cast
+ expression
+ ,(semantic-lambda
+ (list
+ (identity start)
+ (identity end)))
+ )
+ (semantic-list
+ expression
+ ,(semantic-lambda
+ (list
+ (identity start)
+ (identity end)))
+ )
+ (semantic-list
+ ,(semantic-lambda
+ (list
+ (identity start)
+ (identity end)))
+ )
+ (expr-start
+ expression
+ ,(semantic-lambda
+ (list
+ (identity start)
+ (identity end)))
+ )
+ ) ;; end expression
+ )
+ "Parser table.")
+
+(defun semantic-c-by--install-parser ()
+ "Setup the Semantic Parser."
+ (setq semantic--parse-table semantic-c-by--parse-table
+ semantic-debug-parser-source "c.by"
+ semantic-debug-parser-class 'semantic-bovine-debug-parser
+ semantic-flex-keywords-obarray semantic-c-by--keyword-table
+ semantic-equivalent-major-modes '(c-mode c++-mode)
+ ))
+
+;;; Epilogue
+;;
+
+(provide 'semantic/bovine/c-by)
+
+;;; semantic/bovine/c-by.el ends here
Index: cedet/semantic/bovine/c.el
===================================================================
RCS file: cedet/semantic/bovine/c.el
diff -N cedet/semantic/bovine/c.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/bovine/c.el 28 Sep 2009 15:15:10 -0000 1.2
@@ -0,0 +1,1736 @@
+;;; semantic/bovine/c.el --- Semantic details for C
+
+;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+;;; 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Support for the C/C++ bovine parser for Semantic.
+;;
+;; @todo - can I support c++-font-lock-extra-types ?
+
+(require 'semantic)
+(require 'semantic/analyze)
+(require 'semantic/bovine/gcc)
+(require 'semantic/idle)
+(require 'semantic/lex-spp)
+(require 'semantic/bovine/c-by)
+
+(eval-when-compile
+ (require 'semantic/find))
+
+(declare-function semantic-brute-find-tag-by-attribute "semantic/find")
+(declare-function semanticdb-minor-mode-p "semantic/db-mode")
+(declare-function semanticdb-needs-refresh-p "semantic/db")
+(declare-function c-forward-conditional "cc-cmds")
+(declare-function ede-system-include-path "ede")
+
+;;; Compatibility
+;;
+(eval-when-compile (require 'cc-mode))
+
+(if (fboundp 'c-end-of-macro)
+ (eval-and-compile
+ (defalias 'semantic-c-end-of-macro 'c-end-of-macro))
+ ;; From cc-mode 5.30
+ (defun semantic-c-end-of-macro ()
+ "Go to the end of a preprocessor directive.
+More accurately, move point to the end of the closest following line
+that doesn't end with a line continuation backslash.
+
+This function does not do any hidden buffer changes."
+ (while (progn
+ (end-of-line)
+ (when (and (eq (char-before) ?\\)
+ (not (eobp)))
+ (forward-char)
+ t))))
+ )
+
+;;; Code:
+(define-child-mode c++-mode c-mode
+ "`c++-mode' uses the same parser as `c-mode'.")
+
+
+;;; Include Paths
+;;
+(defcustom-mode-local-semantic-dependency-system-include-path
+ c-mode semantic-c-dependency-system-include-path
+ '("/usr/include")
+ "The system include path used by the C langauge.")
+
+(defcustom semantic-default-c-path nil
+ "Default set of include paths for C code.
+Used by `semantic-dep' to define an include path.
+NOTE: In process of obsoleting this."
+ :group 'c
+ :group 'semantic
+ :type '(repeat (string :tag "Path")))
+
+(defvar-mode-local c-mode semantic-dependency-include-path
+ semantic-default-c-path
+ "System path to search for include files.")
+
+;;; Compile Options
+;;
+;; Compiler options need to show up after path setup, but before
+;; the preprocessor section.
+
+(when (member system-type '(gnu gnu/linux darwin cygwin))
+ (semantic-gcc-setup))
+
+;;; Pre-processor maps
+;;
+;;; Lexical analysis
+(defvar semantic-lex-c-preprocessor-symbol-map-builtin
+ '( ("__THROW" . "")
+ ("__const" . "const")
+ ("__restrict" . "")
+ ("__declspec" . ((spp-arg-list ("foo") 1 . 2)))
+ ("__attribute__" . ((spp-arg-list ("foo") 1 . 2)))
+ )
+ "List of symbols to include by default.")
+
+(defvar semantic-c-in-reset-preprocessor-table nil
+ "Non-nil while resetting the preprocessor symbol map.
+Used to prevent a reset while trying to parse files that are
+part of the preprocessor map.")
+
+(defvar semantic-lex-c-preprocessor-symbol-file)
+(defvar semantic-lex-c-preprocessor-symbol-map)
+
+(defun semantic-c-reset-preprocessor-symbol-map ()
+ "Reset the C preprocessor symbol map based on all input variables."
+ (when (featurep 'semantic/bovine/c)
+ (let ((filemap nil)
+ )
+ (when (and (not semantic-c-in-reset-preprocessor-table)
+ (featurep 'semantic/db-mode)
+ (semanticdb-minor-mode-p))
+ (let ( ;; Don't use external parsers. We need the internal one.
+ (semanticdb-out-of-buffer-create-table-fcn nil)
+ ;; Don't recurse while parsing these files the first time.
+ (semantic-c-in-reset-preprocessor-table t)
+ )
+ (dolist (sf semantic-lex-c-preprocessor-symbol-file)
+ ;; Global map entries
+ (let* ((table (semanticdb-file-table-object sf t)))
+ (when table
+ (when (semanticdb-needs-refresh-p table)
+ (condition-case nil
+ ;; Call with FORCE, as the file is very likely to
+ ;; not be in a buffer.
+ (semanticdb-refresh-table table t)
+ (error (message "Error updating tables for %S"
+ (object-name table)))))
+ (setq filemap (append filemap (oref table lexical-table)))
+ )
+ ))))
+
+ (setq-mode-local c-mode
+ semantic-lex-spp-macro-symbol-obarray
+ (semantic-lex-make-spp-table
+ (append semantic-lex-c-preprocessor-symbol-map-builtin
+ semantic-lex-c-preprocessor-symbol-map
+ filemap))
+ )
+ )))
+
+(defcustom semantic-lex-c-preprocessor-symbol-map nil
+ "Table of C Preprocessor keywords used by the Semantic C lexer.
+Each entry is a cons cell like this:
+ ( \"KEYWORD\" . \"REPLACEMENT\" )
+Where KEYWORD is the macro that gets replaced in the lexical phase,
+and REPLACEMENT is a string that is inserted in it's place. Empty string
+implies that the lexical analyzer will discard KEYWORD when it is encountered.
+
+Alternately, it can be of the form:
+ ( \"KEYWORD\" ( LEXSYM1 \"str\" 1 1 ) ... ( LEXSYMN \"str\" 1 1 ) )
+where LEXSYM is a symbol that would normally be produced by the
+lexical analyzer, such as `symbol' or `string'. The string in the
+second position is the text that makes up the replacement. This is
+the way to have multiple lexical symbols in a replacement. Using the
+first way to specify text like \"foo::bar\" would not work, because :
+is a sepearate lexical symbol.
+
+A quick way to see what you would need to insert is to place a
+definition such as:
+
+#define MYSYM foo::bar
+
+into a C file, and do this:
+ \\[semantic-lex-spp-describe]
+
+The output table will describe the symbols needed."
+ :group 'c
+ :type '(repeat (cons (string :tag "Keyword")
+ (sexp :tag "Replacement")))
+ :set (lambda (sym value)
+ (set-default sym value)
+ (condition-case nil
+ (semantic-c-reset-preprocessor-symbol-map)
+ (error nil))
+ )
+ )
+
+(defcustom semantic-lex-c-preprocessor-symbol-file nil
+ "List of C/C++ files that contain preprocessor macros for the C lexer.
+Each entry is a filename and each file is parsed, and those macros
+are included in every C/C++ file parsed by semantic.
+You can use this variable instead of `semantic-lex-c-preprocessor-symbol-map'
+to store your global macros in a more natural way."
+ :group 'c
+ :type '(repeat (file :tag "File"))
+ :set (lambda (sym value)
+ (set-default sym value)
+ (condition-case nil
+ (semantic-c-reset-preprocessor-symbol-map)
+ (error nil))
+ )
+ )
+
+(defcustom semantic-c-member-of-autocast 't
+ "Non-nil means classes with a '->' operator will cast to it's return type.
+
+For Examples:
+
+ class Foo {
+ Bar *operator->();
+ }
+
+ Foo foo;
+
+if `semantic-c-member-of-autocast' is non-nil :
+ foo->[here completion will list method of Bar]
+
+if `semantic-c-member-of-autocast' is nil :
+ foo->[here completion will list method of Foo]"
+ :group 'c
+ :type 'boolean)
+
+(define-lex-spp-macro-declaration-analyzer semantic-lex-cpp-define
+ "A #define of a symbol with some value.
+Record the symbol in the semantic preprocessor.
+Return the the defined symbol as a special spp lex token."
+ "^\\s-*#\\s-*define\\s-+\\(\\(\\sw\\|\\s_\\)+\\)" 1
+ (goto-char (match-end 0))
+ (skip-chars-forward " \t")
+ (if (eolp)
+ nil
+ (let* ((name (buffer-substring-no-properties
+ (match-beginning 1) (match-end 1)))
+ (with-args (save-excursion
+ (goto-char (match-end 0))
+ (looking-at "(")))
+ (semantic-lex-spp-replacements-enabled nil)
+ ;; Temporarilly override the lexer to include
+ ;; special items needed inside a macro
+ (semantic-lex-analyzer #'semantic-cpp-lexer)
+ (raw-stream
+ (semantic-lex-spp-stream-for-macro (save-excursion
+ (semantic-c-end-of-macro)
+ (point))))
+ )
+
+ ;; Only do argument checking if the paren was immediatly after
+ ;; the macro name.
+ (if with-args
+ (semantic-lex-spp-first-token-arg-list (car raw-stream)))
+
+ ;; Magical spp variable for end point.
+ (setq semantic-lex-end-point (point))
+
+ ;; Handled nested macro streams.
+ (semantic-lex-spp-merge-streams raw-stream)
+ )))
+
+(define-lex-spp-macro-undeclaration-analyzer semantic-lex-cpp-undef
+ "A #undef of a symbol.
+Remove the symbol from the semantic preprocessor.
+Return the the defined symbol as a special spp lex token."
+ "^\\s-*#\\s-*undef\\s-+\\(\\(\\sw\\|\\s_\\)+\\)" 1)
+
+
+;;; Conditional Skipping
+;;
+(defcustom semantic-c-obey-conditional-section-parsing-flag t
+ "*Non-nil means to interpret preprocessor #if sections.
+This implies that some blocks of code will not be parsed based on the
+values of the conditions in the #if blocks."
+ :group 'c
+ :type 'boolean)
+
+(defun semantic-c-skip-conditional-section ()
+ "Skip one section of a conditional.
+Moves forward to a matching #elif, #else, or #endif.
+Moves completely over balanced #if blocks."
+ (require 'cc-cmds)
+ (let ((done nil))
+ ;; (if (looking-at "^\\s-*#if")
+ ;; (semantic-lex-spp-push-if (point))
+ (end-of-line)
+ (while (and semantic-c-obey-conditional-section-parsing-flag
+ (and (not done)
+ (re-search-forward
+
"^\\s-*#\\s-*\\(if\\(n?def\\)?\\|el\\(if\\|se\\)\\|endif\\)\\>"
+ nil t)))
+ (goto-char (match-beginning 0))
+ (cond
+ ((looking-at "^\\s-*#\\s-*if")
+ ;; We found a nested if. Skip it.
+ (c-forward-conditional 1))
+ ((looking-at "^\\s-*#\\s-*elif")
+ ;; We need to let the preprocessor analize this one.
+ (beginning-of-line)
+ (setq done t)
+ )
+ ((looking-at "^\\s-*#\\s-*\\(endif\\|else\\)\\>")
+ ;; We are at the end. Pop our state.
+ ;; (semantic-lex-spp-pop-if)
+ ;; Note: We include ELSE and ENDIF the same. If skip some previous
+ ;; section, then we should do the else by default, making it much
+ ;; like the endif.
+ (end-of-line)
+ (forward-char 1)
+ (setq done t))
+ (t
+ ;; We found an elif. Stop here.
+ (setq done t))))))
+
+(define-lex-regex-analyzer semantic-lex-c-if
+ "Code blocks wrapped up in #if, or #ifdef.
+Uses known macro tables in SPP to determine what block to skip."
+
"^\\s-*#\\s-*\\(if\\|ifndef\\|ifdef\\|elif\\)\\s-+\\(!?defined(\\|\\)\\s-*\\(\\(\\sw\\|\\s_\\)+\\)\\(\\s-*)\\)?\\s-*$"
+ (semantic-c-do-lex-if))
+
+(defun semantic-c-do-lex-if ()
+ "Handle lexical CPP if statements."
+ (let* ((sym (buffer-substring-no-properties
+ (match-beginning 3) (match-end 3)))
+ (defstr (buffer-substring-no-properties
+ (match-beginning 2) (match-end 2)))
+ (defined (string= defstr "defined("))
+ (notdefined (string= defstr "!defined("))
+ (ift (buffer-substring-no-properties
+ (match-beginning 1) (match-end 1)))
+ (ifdef (or (string= ift "ifdef")
+ (and (string= ift "if") defined)
+ (and (string= ift "elif") defined)
+ ))
+ (ifndef (or (string= ift "ifndef")
+ (and (string= ift "if") notdefined)
+ (and (string= ift "elif") notdefined)
+ ))
+ )
+ (if (or (and (or (string= ift "if") (string= ift "elif"))
+ (string= sym "0"))
+ (and ifdef (not (semantic-lex-spp-symbol-p sym)))
+ (and ifndef (semantic-lex-spp-symbol-p sym)))
+ ;; The if indecates to skip this preprocessor section
+ (let ((pt nil))
+ ;; (message "%s %s yes" ift sym)
+ (beginning-of-line)
+ (setq pt (point))
+ ;;(c-forward-conditional 1)
+ ;; This skips only a section of a conditional. Once that section
+ ;; is opened, encountering any new #else or related conditional
+ ;; should be skipped.
+ (semantic-c-skip-conditional-section)
+ (setq semantic-lex-end-point (point))
+ (semantic-push-parser-warning (format "Skip #%s %s" ift sym)
+ pt (point))
+;; (semantic-lex-push-token
+;; (semantic-lex-token 'c-preprocessor-skip pt (point)))
+ nil)
+ ;; Else, don't ignore it, but do handle the internals.
+ ;;(message "%s %s no" ift sym)
+ (end-of-line)
+ (setq semantic-lex-end-point (point))
+ nil)))
+
+(define-lex-regex-analyzer semantic-lex-c-macro-else
+ "Ignore an #else block.
+We won't see the #else due to the macro skip section block
+unless we are actively parsing an open #if statement. In that
+case, we must skip it since it is the ELSE part."
+ "^\\s-*#\\s-*\\(else\\)"
+ (let ((pt (point)))
+ (semantic-c-skip-conditional-section)
+ (setq semantic-lex-end-point (point))
+ (semantic-push-parser-warning "Skip #else" pt (point))
+;; (semantic-lex-push-token
+;; (semantic-lex-token 'c-preprocessor-skip pt (point)))
+ nil))
+
+(define-lex-regex-analyzer semantic-lex-c-macrobits
+ "Ignore various forms of #if/#else/#endif conditionals."
+ "^\\s-*#\\s-*\\(if\\(n?def\\)?\\|endif\\|elif\\|else\\)"
+ (semantic-c-end-of-macro)
+ (setq semantic-lex-end-point (point))
+ nil)
+
+(define-lex-spp-include-analyzer semantic-lex-c-include-system
+ "Identify include strings, and return special tokens."
+ "^\\s-*#\\s-*include\\s-*<\\([^ \t\n>]+\\)>" 0
+ ;; Hit 1 is the name of the include.
+ (goto-char (match-end 0))
+ (setq semantic-lex-end-point (point))
+ (cons (buffer-substring-no-properties (match-beginning 1)
+ (match-end 1))
+ 'system))
+
+(define-lex-spp-include-analyzer semantic-lex-c-include
+ "Identify include strings, and return special tokens."
+ "^\\s-*#\\s-*include\\s-*\"\\([^ \t\n>]+\\)\"" 0
+ ;; Hit 1 is the name of the include.
+ (goto-char (match-end 0))
+ (setq semantic-lex-end-point (point))
+ (cons (buffer-substring-no-properties (match-beginning 1)
+ (match-end 1))
+ nil))
+
+
+(define-lex-regex-analyzer semantic-lex-c-ignore-ending-backslash
+ "Skip backslash ending a line.
+Go to the next line."
+ "\\\\\\s-*\n"
+ (setq semantic-lex-end-point (match-end 0)))
+
+(define-lex-regex-analyzer semantic-lex-c-namespace-begin-macro
+ "Handle G++'s namespace macros which the pre-processor can't handle."
+ "\\(_GLIBCXX_BEGIN_NAMESPACE\\)(\\s-*\\(\\(?:\\w\\|\\s_\\)+\\)\\s-*)"
+ (let* ((nsend (match-end 1))
+ (sym-start (match-beginning 2))
+ (sym-end (match-end 2))
+ (ms (buffer-substring-no-properties sym-start sym-end)))
+ ;; Push the namespace keyword.
+ (semantic-lex-push-token
+ (semantic-lex-token 'NAMESPACE (match-beginning 0) nsend "namespace"))
+ ;; Push the name.
+ (semantic-lex-push-token
+ (semantic-lex-token 'symbol sym-start sym-end ms))
+ )
+ (goto-char (match-end 0))
+ (let ((start (point))
+ (end 0))
+ ;; If we can't find a matching end, then create the fake list.
+ (when (re-search-forward "_GLIBCXX_END_NAMESPACE" nil t)
+ (setq end (point))
+ (semantic-lex-push-token
+ (semantic-lex-token 'semantic-list start end
+ (list 'prefix-fake)))))
+ (setq semantic-lex-end-point (point)))
+
+(defcustom semantic-lex-c-nested-namespace-ignore-second t
+ "Should _GLIBCXX_BEGIN_NESTED_NAMESPACE ignore the second namespace?
+It is really there, but if a majority of uses is to squeeze out
+the second namespace in use, then it should not be included.
+
+If you are having problems with smart completion and STL templates,
+it may that this is set incorrectly. After changing the value
+of this flag, you will need to delete any semanticdb cache files
+that may have been incorrectly parsed."
+ :group 'semantic
+ :type 'boolean)
+
+(define-lex-regex-analyzer semantic-lex-c-VC++-begin-std-namespace
+ "Handle VC++'s definition of the std namespace."
+ "\\(_STD_BEGIN\\)"
+ (semantic-lex-push-token
+ (semantic-lex-token 'NAMESPACE (match-beginning 0) (match-end 0)
"namespace"))
+ (semantic-lex-push-token
+ (semantic-lex-token 'symbol (match-beginning 0) (match-end 0) "std"))
+ (goto-char (match-end 0))
+ (let ((start (point))
+ (end 0))
+ (when (re-search-forward "_STD_END" nil t)
+ (setq end (point))
+ (semantic-lex-push-token
+ (semantic-lex-token 'semantic-list start end
+ (list 'prefix-fake)))))
+ (setq semantic-lex-end-point (point)))
+
+(define-lex-regex-analyzer semantic-lex-c-VC++-end-std-namespace
+ "Handle VC++'s definition of the std namespace."
+ "\\(_STD_END\\)"
+ (goto-char (match-end 0))
+ (setq semantic-lex-end-point (point)))
+
+(define-lex-regex-analyzer semantic-lex-c-namespace-begin-nested-macro
+ "Handle G++'s namespace macros which the pre-processor can't handle."
+
"\\(_GLIBCXX_BEGIN_NESTED_NAMESPACE\\)(\\s-*\\(\\(?:\\w\\|\\s_\\)+\\)\\s-*,\\s-*\\(\\(?:\\w\\|\\s_\\)+\\)\\s-*)"
+ (goto-char (match-end 0))
+ (let* ((nsend (match-end 1))
+ (sym-start (match-beginning 2))
+ (sym-end (match-end 2))
+ (ms (buffer-substring-no-properties sym-start sym-end))
+ (sym2-start (match-beginning 3))
+ (sym2-end (match-end 3))
+ (ms2 (buffer-substring-no-properties sym2-start sym2-end)))
+ ;; Push the namespace keyword.
+ (semantic-lex-push-token
+ (semantic-lex-token 'NAMESPACE (match-beginning 0) nsend "namespace"))
+ ;; Push the name.
+ (semantic-lex-push-token
+ (semantic-lex-token 'symbol sym-start sym-end ms))
+
+ (goto-char (match-end 0))
+ (let ((start (point))
+ (end 0))
+ ;; If we can't find a matching end, then create the fake list.
+ (when (re-search-forward "_GLIBCXX_END_NESTED_NAMESPACE" nil t)
+ (setq end (point))
+ (if semantic-lex-c-nested-namespace-ignore-second
+ ;; The same as _GLIBCXX_BEGIN_NAMESPACE
+ (semantic-lex-push-token
+ (semantic-lex-token 'semantic-list start end
+ (list 'prefix-fake)))
+ ;; Do both the top and second level namespace
+ (semantic-lex-push-token
+ (semantic-lex-token 'semantic-list start end
+ ;; We'll depend on a quick hack
+ (list 'prefix-fake-plus
+ (semantic-lex-token 'NAMESPACE
+ sym-end sym2-start
+ "namespace")
+ (semantic-lex-token 'symbol
+ sym2-start sym2-end
+ ms2)
+ (semantic-lex-token 'semantic-list start
end
+ (list 'prefix-fake)))
+ )))
+ )))
+ (setq semantic-lex-end-point (point)))
+
+(define-lex-regex-analyzer semantic-lex-c-namespace-end-macro
+ "Handle G++'s namespace macros which the pre-processor can't handle."
+ "_GLIBCXX_END_\\(NESTED_\\)?NAMESPACE"
+ (goto-char (match-end 0))
+ (setq semantic-lex-end-point (point)))
+
+(define-lex-regex-analyzer semantic-lex-c-string
+ "Detect and create a C string token."
+ "L?\\(\\s\"\\)"
+ ;; Zing to the end of this string.
+ (semantic-lex-push-token
+ (semantic-lex-token
+ 'string (point)
+ (save-excursion
+ ;; Skip L prefix if present.
+ (goto-char (match-beginning 1))
+ (semantic-lex-unterminated-syntax-protection 'string
+ (forward-sexp 1)
+ (point))
+ ))))
+
+(define-lex-regex-analyzer semantic-c-lex-ignore-newline
+ "Detect and ignore newline tokens.
+Use this ONLY if newlines are not whitespace characters (such as when
+they are comment end characters)."
+ ;; Just like semantic-lex-ignore-newline, but also ignores
+ ;; trailing \.
+ "\\s-*\\\\?\\s-*\\(\n\\|\\s>\\)"
+ (setq semantic-lex-end-point (match-end 0)))
+
+
+(define-lex semantic-c-lexer
+ "Lexical Analyzer for C code.
+Use semantic-cpp-lexer for parsing text inside a CPP macro."
+ ;; C preprocessor features
+ semantic-lex-cpp-define
+ semantic-lex-cpp-undef
+ semantic-lex-c-if
+ semantic-lex-c-macro-else
+ semantic-lex-c-macrobits
+ semantic-lex-c-include
+ semantic-lex-c-include-system
+ semantic-lex-c-ignore-ending-backslash
+ ;; Whitespace handling
+ semantic-lex-ignore-whitespace
+ semantic-c-lex-ignore-newline
+ ;; Non-preprocessor features
+ semantic-lex-number
+ ;; Must detect C strings before symbols because of possible L prefix!
+ semantic-lex-c-string
+ ;; Custom handlers for some macros come before the macro replacement
analyzer.
+ semantic-lex-c-namespace-begin-macro
+ semantic-lex-c-namespace-begin-nested-macro
+ semantic-lex-c-namespace-end-macro
+ semantic-lex-c-VC++-begin-std-namespace
+ semantic-lex-c-VC++-end-std-namespace
+ ;; Handle macros, symbols, and keywords
+ semantic-lex-spp-replace-or-symbol-or-keyword
+ semantic-lex-charquote
+ semantic-lex-paren-or-list
+ semantic-lex-close-paren
+ semantic-lex-ignore-comments
+ semantic-lex-punctuation
+ semantic-lex-default-action)
+
+(define-lex-simple-regex-analyzer semantic-lex-cpp-hashhash
+ "Match ## inside a CPP macro as special."
+ "##" 'spp-concat)
+
+(define-lex semantic-cpp-lexer
+ "Lexical Analyzer for CPP macros in C code."
+ ;; CPP special
+ semantic-lex-cpp-hashhash
+ ;; C preprocessor features
+ semantic-lex-cpp-define
+ semantic-lex-cpp-undef
+ semantic-lex-c-if
+ semantic-lex-c-macro-else
+ semantic-lex-c-macrobits
+ semantic-lex-c-include
+ semantic-lex-c-include-system
+ semantic-lex-c-ignore-ending-backslash
+ ;; Whitespace handling
+ semantic-lex-ignore-whitespace
+ semantic-c-lex-ignore-newline
+ ;; Non-preprocessor features
+ semantic-lex-number
+ ;; Must detect C strings before symbols because of possible L prefix!
+ semantic-lex-c-string
+ ;; Parsing inside a macro means that we don't do macro replacement.
+ ;; semantic-lex-spp-replace-or-symbol-or-keyword
+ semantic-lex-symbol-or-keyword
+ semantic-lex-charquote
+ semantic-lex-paren-or-list
+ semantic-lex-close-paren
+ semantic-lex-ignore-comments
+ semantic-lex-punctuation
+ semantic-lex-default-action)
+
+(define-mode-local-override semantic-parse-region c-mode
+ (start end &optional nonterminal depth returnonerror)
+ "Calls 'semantic-parse-region-default', except in a macro expansion.
+MACRO expansion mode is handled through the nature of Emacs's non-lexical
+binding of variables.
+START, END, NONTERMINAL, DEPTH, and RETURNONERRORS are the same
+as for the parent."
+ (if (and (boundp 'lse) (or (/= start 1) (/= end (point-max))))
+ (let* ((last-lexical-token lse)
+ (llt-class (semantic-lex-token-class last-lexical-token))
+ (llt-fakebits (car (cdr last-lexical-token)))
+ (macroexpand (stringp (car (cdr last-lexical-token)))))
+ (if macroexpand
+ (progn
+ ;; It is a macro expansion. Do something special.
+ ;;(message "MOOSE %S %S, %S : %S" start end nonterminal lse)
+ (semantic-c-parse-lexical-token
+ lse nonterminal depth returnonerror)
+ )
+ ;; Not a macro expansion, but perhaps a funny semantic-list
+ ;; is at the start? Remove the depth if our semantic list is not
+ ;; made of list tokens.
+ (if (and depth (= depth 1)
+ (eq llt-class 'semantic-list)
+ (not (null llt-fakebits))
+ (consp llt-fakebits)
+ (symbolp (car llt-fakebits))
+ )
+ (progn
+ (setq depth 0)
+
+ ;; This is a copy of semantic-parse-region-default where we
+ ;; are doing something special with the lexication of the
+ ;; contents of the semantic-list token. Stuff not used by C
+ ;; removed.
+ (let ((tokstream
+ (if (and (consp llt-fakebits)
+ (eq (car llt-fakebits) 'prefix-fake-plus))
+ ;; If our semantic-list is special, then only stick
in the
+ ;; fake tokens.
+ (cdr llt-fakebits)
+ ;; Lex up the region with a depth of 0
+ (semantic-lex start end 0))))
+
+ ;; Do the parse
+ (nreverse
+ (semantic-repeat-parse-whole-stream tokstream
+ nonterminal
+ returnonerror))
+
+ ))
+
+ ;; It was not a macro expansion, nor a special semantic-list.
+ ;; Do old thing.
+ (semantic-parse-region-default start end
+ nonterminal depth
+ returnonerror)
+ )))
+ ;; Do the parse
+ (semantic-parse-region-default start end nonterminal
+ depth returnonerror)
+ ))
+
+(defvar semantic-c-parse-token-hack-depth 0
+ "Current depth of recursive calls to `semantic-c-parse-lexical-token'")
+
+(defun semantic-c-parse-lexical-token (lexicaltoken nonterminal depth
+ returnonerror)
+ "Do a region parse on the contents of LEXICALTOKEN.
+Presumably, this token has a string in it from a macro.
+The text of the token is inserted into a different buffer, and
+parsed there.
+Argument NONTERMINAL, DEPTH, and RETURNONERROR are passed into
+the regular parser."
+ (let* ((semantic-c-parse-token-hack-depth (1+
semantic-c-parse-token-hack-depth))
+ (buf (get-buffer-create (format " *C parse hack %d*"
+ semantic-c-parse-token-hack-depth)))
+ (mode major-mode)
+ (spp-syms semantic-lex-spp-dynamic-macro-symbol-obarray)
+ (stream nil)
+ (start (semantic-lex-token-start lexicaltoken))
+ (end (semantic-lex-token-end lexicaltoken))
+ (symtext (semantic-lex-token-text lexicaltoken))
+ (macros (get-text-property 0 'macros symtext))
+ )
+ (save-excursion
+ (set-buffer buf)
+ (erase-buffer)
+ (when (not (eq major-mode mode))
+ (save-match-data
+
+ ;; Protect against user hooks throwing errors.
+ (condition-case nil
+ (funcall mode)
+ (error nil))
+
+ ;; Hack in mode-local
+ (activate-mode-local-bindings)
+ ;; CHEATER! The following 3 lines are from
+ ;; `semantic-new-buffer-fcn', but we don't want to turn
+ ;; on all the other annoying modes for this little task.
+ (setq semantic-new-buffer-fcn-was-run t)
+ (semantic-lex-init)
+ (semantic-clear-toplevel-cache)
+ (remove-hook 'semantic-lex-reset-hooks 'semantic-lex-spp-reset-hook
+ t)
+ ))
+ ;; Get the macro symbol table right.
+ (setq semantic-lex-spp-dynamic-macro-symbol-obarray spp-syms)
+ ;; (message "%S" macros)
+ (dolist (sym macros)
+ (semantic-lex-spp-symbol-set (car sym) (cdr sym)))
+
+ (insert symtext)
+
+ (setq stream
+ (semantic-parse-region-default
+ (point-min) (point-max) nonterminal depth returnonerror))
+
+ ;; Clean up macro symbols
+ (dolist (sym macros)
+ (semantic-lex-spp-symbol-remove (car sym)))
+
+ ;; Convert the text of the stream.
+ (dolist (tag stream)
+ ;; Only do two levels here 'cause I'm lazy.
+ (semantic--tag-set-overlay tag (list start end))
+ (dolist (stag (semantic-tag-components-with-overlays tag))
+ (semantic--tag-set-overlay stag (list start end))
+ ))
+ )
+ stream))
+
+(defun semantic-expand-c-tag (tag)
+ "Expand TAG into a list of equivalent tags, or nil."
+ (let ((return-list nil)
+ )
+ ;; Expand an EXTERN C first.
+ (when (eq (semantic-tag-class tag) 'extern)
+ (let* ((mb (semantic-tag-get-attribute tag :members))
+ (ret mb))
+ (while mb
+ (let ((mods (semantic-tag-get-attribute (car mb) :typemodifiers)))
+ (setq mods (cons "extern" (cons "\"C\"" mods)))
+ (semantic-tag-put-attribute (car mb) :typemodifiers mods))
+ (setq mb (cdr mb)))
+ (setq return-list ret)))
+
+ ;; Function or variables that have a :type that is some complex
+ ;; thing, extract it, and replace it with a reference.
+ ;;
+ ;; Thus, struct A { int a; } B;
+ ;;
+ ;; will create 2 toplevel tags, one is type A, and the other variable B
+ ;; where the :type of B is just a type tag A that is a prototype, and
+ ;; the actual struct info of A is it's own toplevel tag.
+ (when (or (semantic-tag-of-class-p tag 'function)
+ (semantic-tag-of-class-p tag 'variable))
+ (let* ((basetype (semantic-tag-type tag))
+ (typeref nil)
+ (tname (when (consp basetype)
+ (semantic-tag-name basetype))))
+ ;; Make tname be a string.
+ (when (consp tname) (setq tname (car (car tname))))
+ ;; Is the basetype a full type with a name of its own?
+ (when (and basetype (semantic-tag-p basetype)
+ (not (semantic-tag-prototype-p basetype))
+ tname
+ (not (string= tname "")))
+ ;; a type tag referencing the type we are extracting.
+ (setq typeref (semantic-tag-new-type
+ (semantic-tag-name basetype)
+ (semantic-tag-type basetype)
+ nil nil
+ :prototype t))
+ ;; Convert original tag to only have a reference.
+ (setq tag (semantic-tag-copy tag))
+ (semantic-tag-put-attribute tag :type typeref)
+ ;; Convert basetype to have the location information.
+ (semantic--tag-copy-properties tag basetype)
+ (semantic--tag-set-overlay basetype
+ (semantic-tag-overlay tag))
+ ;; Store the base tag as part of the return list.
+ (setq return-list (cons basetype return-list)))))
+
+ ;; Name of the tag is a list, so expand it. Tag lists occur
+ ;; for variables like this: int var1, var2, var3;
+ ;;
+ ;; This will expand that to 3 tags that happen to share the
+ ;; same overlay information.
+ (if (consp (semantic-tag-name tag))
+ (let ((rl (semantic-expand-c-tag-namelist tag)))
+ (cond
+ ;; If this returns nothing, then return nil overall
+ ;; because that will restore the old TAG input.
+ ((not rl) (setq return-list nil))
+ ;; If we have a return, append it to the existing list
+ ;; of returns.
+ ((consp rl)
+ (setq return-list (append rl return-list)))
+ ))
+ ;; If we didn't have a list, but the return-list is non-empty,
+ ;; that means we still need to take our existing tag, and glom
+ ;; it onto our extracted type.
+ (if (consp return-list)
+ (setq return-list (cons tag return-list)))
+ )
+
+ ;; Default, don't change the tag means returning nil.
+ return-list))
+
+(defun semantic-expand-c-tag-namelist (tag)
+ "Expand TAG whose name is a list into a list of tags, or nil."
+ (cond ((semantic-tag-of-class-p tag 'variable)
+ ;; The name part comes back in the form of:
+ ;; ( NAME NUMSTARS BITS ARRAY ASSIGN )
+ (let ((vl nil)
+ (basety (semantic-tag-type tag))
+ (ty "")
+ (mods (semantic-tag-get-attribute tag :typemodifiers))
+ (suffix "")
+ (lst (semantic-tag-name tag))
+ (default nil)
+ (cur nil))
+ ;; Open up each name in the name list.
+ (while lst
+ (setq suffix "" ty "")
+ (setq cur (car lst))
+ (if (nth 2 cur)
+ (setq suffix (concat ":" (nth 2 cur))))
+ (if (= (length basety) 1)
+ (setq ty (car basety))
+ (setq ty basety))
+ (setq default (nth 4 cur))
+ (setq vl (cons
+ (semantic-tag-new-variable
+ (car cur) ;name
+ ty ;type
+ (if default
+ (buffer-substring-no-properties
+ (car default) (car (cdr default))))
+ :constant-flag (semantic-tag-variable-constant-p tag)
+ :suffix suffix
+ :typemodifiers mods
+ :dereference (length (nth 3 cur))
+ :pointer (nth 1 cur)
+ :reference (semantic-tag-get-attribute tag :reference)
+ :documentation (semantic-tag-docstring tag) ;doc
+ )
+ vl))
+ (semantic--tag-copy-properties tag (car vl))
+ (semantic--tag-set-overlay (car vl)
+ (semantic-tag-overlay tag))
+ (setq lst (cdr lst)))
+ ;; Return the list
+ (nreverse vl)))
+ ((semantic-tag-of-class-p tag 'type)
+ ;; We may someday want to add an extra check for a type
+ ;; of type "typedef".
+ ;; Each elt of NAME is ( STARS NAME )
+ (let ((vl nil)
+ (names (semantic-tag-name tag)))
+ (while names
+ (setq vl (cons (semantic-tag-new-type
+ (nth 1 (car names)) ; name
+ "typedef"
+ (semantic-tag-type-members tag)
+ ;; parent is just tbe name of what
+ ;; is passed down as a tag.
+ (list
+ (semantic-tag-name
+ (semantic-tag-type-superclasses tag)))
+ :pointer
+ (let ((stars (car (car (car names)))))
+ (if (= stars 0) nil stars))
+ ;; This specifies what the typedef
+ ;; is expanded out as. Just the
+ ;; name shows up as a parent of this
+ ;; typedef.
+ :typedef
+ (semantic-tag-get-attribute tag :superclasses)
+ ;;(semantic-tag-type-superclasses tag)
+ :documentation
+ (semantic-tag-docstring tag))
+ vl))
+ (semantic--tag-copy-properties tag (car vl))
+ (semantic--tag-set-overlay (car vl)
+ (semantic-tag-overlay tag))
+ (setq names (cdr names)))
+ vl))
+ ((and (listp (car tag))
+ (semantic-tag-of-class-p (car tag) 'variable))
+ ;; Argument lists come in this way. Append all the expansions!
+ (let ((vl nil))
+ (while tag
+ (setq vl (append (semantic-tag-components (car vl))
+ vl)
+ tag (cdr tag)))
+ vl))
+ (t nil)))
+
+(defvar-mode-local c-mode semantic-tag-expand-function 'semantic-expand-c-tag
+ "Function used to expand tags generated in the C bovine parser.")
+
+(defvar semantic-c-classname nil
+ "At parse time, assign a class or struct name text here.
+It is picked up by `semantic-c-reconstitute-token' to determine
+if something is a constructor. Value should be:
+ ( TYPENAME . TYPEOFTYPE)
+where typename is the name of the type, and typeoftype is \"class\"
+or \"struct\".")
+
+(defun semantic-c-reconstitute-token (tokenpart declmods typedecl)
+ "Reconstitute a token TOKENPART with DECLMODS and TYPEDECL.
+This is so we don't have to match the same starting text several times.
+Optional argument STAR and REF indicate the number of * and & in the typedef."
+ (when (and (listp typedecl)
+ (= 1 (length typedecl))
+ (stringp (car typedecl)))
+ (setq typedecl (car typedecl)))
+ (cond ((eq (nth 1 tokenpart) 'variable)
+ (semantic-tag-new-variable
+ (car tokenpart)
+ (or typedecl "int") ;type
+ nil ;default value (filled with expand)
+ :constant-flag (if (member "const" declmods) t nil)
+ :typemodifiers (delete "const" declmods)
+ )
+ )
+ ((eq (nth 1 tokenpart) 'function)
+ ;; We should look at part 4 (the arglist) here, and throw an
+ ;; error of some sort if it contains parser errors so that we
+ ;; don't parser function calls, but that is a little beyond what
+ ;; is available for data here.
+ (let* ((constructor
+ (and (or (and semantic-c-classname
+ (string= (car semantic-c-classname)
+ (car tokenpart)))
+ (and (stringp (car (nth 2 tokenpart)))
+ (string= (car (nth 2 tokenpart)) (car
tokenpart)))
+ )
+ (not (car (nth 3 tokenpart)))))
+ (fcnpointer (string-match "^\\*" (car tokenpart)))
+ (fnname (if fcnpointer
+ (substring (car tokenpart) 1)
+ (car tokenpart)))
+ (operator (if (string-match "[a-zA-Z]" fnname)
+ nil
+ t))
+ )
+ (if fcnpointer
+ ;; Function pointers are really variables.
+ (semantic-tag-new-variable
+ fnname
+ typedecl
+ nil
+ ;; It is a function pointer
+ :functionpointer-flag t
+ )
+ ;; The function
+ (semantic-tag-new-function
+ fnname
+ (or typedecl ;type
+ (cond ((car (nth 3 tokenpart) )
+ "void") ; Destructors have no return?
+ (constructor
+ ;; Constructors return an object.
+ (semantic-tag-new-type
+ ;; name
+ (or (car semantic-c-classname)
+ (car (nth 2 tokenpart)))
+ ;; type
+ (or (cdr semantic-c-classname)
+ "class")
+ ;; members
+ nil
+ ;; parents
+ nil
+ ))
+ (t "int")))
+ (nth 4 tokenpart) ;arglist
+ :constant-flag (if (member "const" declmods) t nil)
+ :typemodifiers (delete "const" declmods)
+ :parent (car (nth 2 tokenpart))
+ :destructor-flag (if (car (nth 3 tokenpart) ) t)
+ :constructor-flag (if constructor t)
+ :pointer (nth 7 tokenpart)
+ :operator-flag operator
+ ;; Even though it is "throw" in C++, we use
+ ;; `throws' as a common name for things that toss
+ ;; exceptions about.
+ :throws (nth 5 tokenpart)
+ ;; Reemtrant is a C++ thingy. Add it here
+ :reentrant-flag (if (member "reentrant" (nth 6 tokenpart)) t)
+ ;; A function post-const is funky. Try stuff
+ :methodconst-flag (if (member "const" (nth 6 tokenpart)) t)
+ ;; prototypes are functions w/ no body
+ :prototype-flag (if (nth 8 tokenpart) t)
+ ;; Pure virtual
+ :pure-virtual-flag (if (eq (nth 8 tokenpart) :pure-virtual-flag)
t)
+ ;; Template specifier.
+ :template-specifier (nth 9 tokenpart)
+ )))
+ )
+ ))
+
+(defun semantic-c-reconstitute-template (tag specifier)
+ "Reconstitute the token TAG with the template SPECIFIER."
+ (semantic-tag-put-attribute tag :template (or specifier ""))
+ tag)
+
+
+;;; Override methods & Variables
+;;
+(define-mode-local-override semantic-format-tag-name
+ c-mode (tag &optional parent color)
+ "Convert TAG to a string that is the print name for TAG.
+Optional PARENT and COLOR are ignored."
+ (let ((name (semantic-format-tag-name-default tag parent color))
+ (fnptr (semantic-tag-get-attribute tag :functionpointer-flag))
+ )
+ (if (not fnptr)
+ name
+ (concat "(*" name ")"))
+ ))
+
+(define-mode-local-override semantic-format-tag-canonical-name
+ c-mode (tag &optional parent color)
+ "Create a cannonical name for TAG.
+PARENT specifies a parent class.
+COLOR indicates that the text should be type colorized.
+Enhances the base class to search for the entire parent
+tree to make the name accurate."
+ (semantic-format-tag-canonical-name-default tag parent color)
+ )
+
+(define-mode-local-override semantic-format-tag-type c-mode (tag color)
+ "Convert the data type of TAG to a string usable in tag formatting.
+Adds pointer and reference symbols to the default.
+Argument COLOR adds color to the text."
+ (let* ((type (semantic-tag-type tag))
+ (defaulttype nil)
+ (point (semantic-tag-get-attribute tag :pointer))
+ (ref (semantic-tag-get-attribute tag :reference))
+ )
+ (if (semantic-tag-p type)
+ (let ((typetype (semantic-tag-type type))
+ (typename (semantic-tag-name type)))
+ ;; Create the string that expresses the type
+ (if (string= typetype "class")
+ (setq defaulttype typename)
+ (setq defaulttype (concat typetype " " typename))))
+ (setq defaulttype (semantic-format-tag-type-default tag color)))
+
+ ;; Colorize
+ (when color
+ (setq defaulttype (semantic--format-colorize-text defaulttype 'type)))
+
+ ;; Add refs, ptrs, etc
+ (if ref (setq ref "&"))
+ (if point (setq point (make-string point ?*)) "")
+ (when type
+ (concat defaulttype ref point))
+ ))
+
+(define-mode-local-override semantic-find-tags-by-scope-protection
+ c-mode (scopeprotection parent &optional table)
+ "Override the usual search for protection.
+We can be more effective than the default by scanning through once,
+and collecting tags based on the labels we see along the way."
+ (if (not table) (setq table (semantic-tag-type-members parent)))
+ (if (null scopeprotection)
+ table
+ (let ((ans nil)
+ (curprot 1)
+ (targetprot (cond ((eq scopeprotection 'public)
+ 1)
+ ((eq scopeprotection 'protected)
+ 2)
+ (t 3)
+ ))
+ (alist '(("public" . 1)
+ ("protected" . 2)
+ ("private" . 3)))
+ )
+ (dolist (tag table)
+ (cond
+ ((semantic-tag-of-class-p tag 'label)
+ (setq curprot (cdr (assoc (semantic-tag-name tag) alist)))
+ )
+ ((>= targetprot curprot)
+ (setq ans (cons tag ans)))
+ ))
+ ans)))
+
+(define-mode-local-override semantic-tag-protection
+ c-mode (tag &optional parent)
+ "Return the protection of TAG in PARENT.
+Override function for `semantic-tag-protection'."
+ (let ((mods (semantic-tag-modifiers tag))
+ (prot nil))
+ ;; Check the modifiers for protection if we are not a child
+ ;; of some class type.
+ (when (or (not parent) (not (eq (semantic-tag-class parent) 'type)))
+ (while (and (not prot) mods)
+ (if (stringp (car mods))
+ (let ((s (car mods)))
+ ;; A few silly defaults to get things started.
+ (cond ((or (string= s "extern")
+ (string= s "export"))
+ 'public)
+ ((string= s "static")
+ 'private))))
+ (setq mods (cdr mods))))
+ ;; If we have a typed parent, look for :public style labels.
+ (when (and parent (eq (semantic-tag-class parent) 'type))
+ (let ((pp (semantic-tag-type-members parent)))
+ (while (and pp (not (semantic-equivalent-tag-p (car pp) tag)))
+ (when (eq (semantic-tag-class (car pp)) 'label)
+ (setq prot
+ (cond ((string= (semantic-tag-name (car pp)) "public")
+ 'public)
+ ((string= (semantic-tag-name (car pp)) "private")
+ 'private)
+ ((string= (semantic-tag-name (car pp)) "protected")
+ 'protected)))
+ )
+ (setq pp (cdr pp)))))
+ (when (and (not prot) (eq (semantic-tag-class parent) 'type))
+ (setq prot
+ (cond ((string= (semantic-tag-type parent) "class") 'private)
+ ((string= (semantic-tag-type parent) "struct") 'public)
+ (t 'unknown))))
+ (or prot
+ (if (and parent (semantic-tag-of-class-p parent 'type))
+ 'public
+ nil))))
+
+(define-mode-local-override semantic-tag-components c-mode (tag)
+ "Return components for TAG."
+ (if (and (eq (semantic-tag-class tag) 'type)
+ (string= (semantic-tag-type tag) "typedef"))
+ ;; A typedef can contain a parent who has positional children,
+ ;; but that parent will not have a position. Do this funny hack
+ ;; to make sure we can apply overlays properly.
+ (let ((sc (semantic-tag-get-attribute tag :typedef)))
+ (when (semantic-tag-p sc) (semantic-tag-components sc)))
+ (semantic-tag-components-default tag)))
+
+(defun semantic-c-tag-template (tag)
+ "Return the template specification for TAG, or nil."
+ (semantic-tag-get-attribute tag :template))
+
+(defun semantic-c-tag-template-specifier (tag)
+ "Return the template specifier specification for TAG, or nil."
+ (semantic-tag-get-attribute tag :template-specifier))
+
+(defun semantic-c-template-string-body (templatespec)
+ "Convert TEMPLATESPEC into a string.
+This might be a string, or a list of tokens."
+ (cond ((stringp templatespec)
+ templatespec)
+ ((semantic-tag-p templatespec)
+ (semantic-format-tag-abbreviate templatespec))
+ ((listp templatespec)
+ (mapconcat 'semantic-format-tag-abbreviate templatespec ", "))))
+
+(defun semantic-c-template-string (token &optional parent color)
+ "Return a string representing the TEMPLATE attribute of TOKEN.
+This string is prefixed with a space, or is the empty string.
+Argument PARENT specifies a parent type.
+Argument COLOR specifies that the string should be colorized."
+ (let ((t2 (semantic-c-tag-template-specifier token))
+ (t1 (semantic-c-tag-template token))
+ ;; @todo - Need to account for a parent that is a template
+ (pt1 (if parent (semantic-c-tag-template parent)))
+ (pt2 (if parent (semantic-c-tag-template-specifier parent)))
+ )
+ (cond (t2 ;; we have a template with specifier
+ (concat " <"
+ ;; Fill in the parts here
+ (semantic-c-template-string-body t2)
+ ">"))
+ (t1 ;; we have a template without specifier
+ " <>")
+ (t
+ ""))))
+
+(define-mode-local-override semantic-format-tag-concise-prototype
+ c-mode (token &optional parent color)
+ "Return an abbreviated string describing TOKEN for C and C++.
+Optional PARENT and COLOR as specified with
+`semantic-format-tag-abbreviate-default'."
+ ;; If we have special template things, append.
+ (concat (semantic-format-tag-concise-prototype-default token parent color)
+ (semantic-c-template-string token parent color)))
+
+(define-mode-local-override semantic-format-tag-uml-prototype
+ c-mode (token &optional parent color)
+ "Return an uml string describing TOKEN for C and C++.
+Optional PARENT and COLOR as specified with
+`semantic-abbreviate-tag-default'."
+ ;; If we have special template things, append.
+ (concat (semantic-format-tag-uml-prototype-default token parent color)
+ (semantic-c-template-string token parent color)))
+
+(define-mode-local-override semantic-tag-abstract-p
+ c-mode (tag &optional parent)
+ "Return non-nil if TAG is considered abstract.
+PARENT is tag's parent.
+In C, a method is abstract if it is `virtual', which is already
+handled. A class is abstract iff it's destructor is virtual."
+ (cond
+ ((eq (semantic-tag-class tag) 'type)
+ (require 'semantic/find)
+ (or (semantic-brute-find-tag-by-attribute :pure-virtual-flag
+ (semantic-tag-components tag)
+ )
+ (let* ((ds (semantic-brute-find-tag-by-attribute
+ :destructor-flag
+ (semantic-tag-components tag)
+ ))
+ (cs (semantic-brute-find-tag-by-attribute
+ :constructor-flag
+ (semantic-tag-components tag)
+ )))
+ (and ds (member "virtual" (semantic-tag-modifiers (car ds)))
+ cs (eq 'protected (semantic-tag-protection (car cs) tag))
+ )
+ )))
+ ((eq (semantic-tag-class tag) 'function)
+ (or (semantic-tag-get-attribute tag :pure-virtual-flag)
+ (member "virtual" (semantic-tag-modifiers tag))))
+ (t (semantic-tag-abstract-p-default tag parent))))
+
+(defun semantic-c-dereference-typedef (type scope &optional type-declaration)
+ "If TYPE is a typedef, get TYPE's type by name or tag, and return.
+SCOPE is not used, and TYPE-DECLARATION is used only if TYPE is not a typedef."
+ (if (and (eq (semantic-tag-class type) 'type)
+ (string= (semantic-tag-type type) "typedef"))
+ (let ((dt (semantic-tag-get-attribute type :typedef)))
+ (cond ((and (semantic-tag-p dt)
+ (not (semantic-analyze-tag-prototype-p dt)))
+ ;; In this case, DT was declared directly. We need
+ ;; to clone DT and apply a filename to it.
+ (let* ((fname (semantic-tag-file-name type))
+ (def (semantic-tag-copy dt nil fname)))
+ (list def def)))
+ ((stringp dt) (list dt (semantic-tag dt 'type)))
+ ((consp dt) (list (car dt) dt))))
+
+ (list type type-declaration)))
+
+(defun semantic-c--instantiate-template (tag def-list spec-list)
+ "Replace TAG name according to template specification.
+DEF-LIST is the template information.
+SPEC-LIST is the template specifier of the datatype instantiated."
+ (when (and (car def-list) (car spec-list))
+
+ (when (and (string= (semantic-tag-type (car def-list)) "class")
+ (string= (semantic-tag-name tag) (semantic-tag-name (car
def-list))))
+ (semantic-tag-set-name tag (semantic-tag-name (car spec-list))))
+
+ (semantic-c--instantiate-template tag (cdr def-list) (cdr spec-list))))
+
+(defun semantic-c--template-name-1 (spec-list)
+ "return a string used to compute template class name based on SPEC-LIST
+for ref<Foo,Bar> it will return 'Foo,Bar'."
+ (when (car spec-list)
+ (let* ((endpart (semantic-c--template-name-1 (cdr spec-list)))
+ (separator (and endpart ",")))
+ (concat (semantic-tag-name (car spec-list)) separator endpart))))
+
+(defun semantic-c--template-name (type spec-list)
+ "Return a template class name for TYPE based on SPEC-LIST.
+For a type `ref' with a template specifier of (Foo Bar) it will
+return 'ref<Foo,Bar>'."
+ (concat (semantic-tag-name type)
+ "<" (semantic-c--template-name-1 (cdr spec-list)) ">"))
+
+(defun semantic-c-dereference-template (type scope &optional type-declaration)
+ "Dereference any template specifieres in TYPE within SCOPE.
+If TYPE is a template, return a TYPE copy with the templates types
+instantiated as specified in TYPE-DECLARATION."
+ (when (semantic-tag-p type-declaration)
+ (let ((def-list (semantic-tag-get-attribute type :template))
+ (spec-list (semantic-tag-get-attribute type-declaration
:template-specifier)))
+ (when (and def-list spec-list)
+ (setq type (semantic-tag-deep-copy-one-tag
+ type
+ (lambda (tag)
+ (when (semantic-tag-of-class-p tag 'type)
+ (semantic-c--instantiate-template
+ tag def-list spec-list))
+ tag)
+ ))
+ (semantic-tag-set-name type (semantic-c--template-name type spec-list))
+ (semantic-tag-put-attribute type :template nil)
+ (semantic-tag-set-faux type))))
+ (list type type-declaration))
+
+;;; Patch here by "Raf" for instantiating templates.
+(defun semantic-c-dereference-member-of (type scope &optional type-declaration)
+ "Dereference through the `->' operator of TYPE.
+Uses the return type of the '->' operator if it is contained in TYPE.
+SCOPE is the current local scope to perform searches in.
+TYPE-DECLARATION is passed through."
+ (if semantic-c-member-of-autocast
+ (let ((operator (car (semantic-find-tags-by-name "->"
(semantic-analyze-scoped-type-parts type)))))
+ (if operator
+ (list (semantic-tag-get-attribute operator :type)
(semantic-tag-get-attribute operator :type))
+ (list type type-declaration)))
+ (list type type-declaration)))
+
+;; David Engster: The following three functions deal with namespace
+;; aliases and types which are member of a namespace through a using
+;; statement. For examples, see the file semantic/tests/testusing.cpp,
+;; tests 5 and following.
+
+(defun semantic-c-dereference-namespace (type scope &optional type-declaration)
+ "Dereference namespace which might hold an 'alias' for TYPE.
+Such an alias can be created through 'using' statements in a
+namespace declaration. This function checks the namespaces in
+SCOPE for such statements."
+ (let ((scopetypes (oref scope scopetypes))
+ typename currentns tmp usingname result namespaces)
+ (when (and (semantic-tag-p type-declaration)
+ (or (null type) (semantic-tag-prototype-p type)))
+ (setq typename (semantic-analyze-split-name (semantic-tag-name
type-declaration)))
+ ;; If we already have that TYPE in SCOPE, we do nothing
+ (unless (semantic-deep-find-tags-by-name (or (car-safe typename)
typename) scopetypes)
+ (if (stringp typename)
+ ;; The type isn't fully qualified, so we have to search in all
namespaces in SCOPE.
+ (setq namespaces (semantic-find-tags-by-type "namespace"
scopetypes))
+ ;; This is a fully qualified name, so we only have to search one
namespace.
+ (setq namespaces (semanticdb-typecache-find (car typename)))
+ ;; Make sure it's really a namespace.
+ (if (string= (semantic-tag-type namespaces) "namespace")
+ (setq namespaces (list namespaces))
+ (setq namespaces nil)))
+ (setq result nil)
+ ;; Iterate over all the namespaces we have to check.
+ (while (and namespaces
+ (null result))
+ (setq currentns (car namespaces))
+ ;; Check if this is namespace is an alias and dereference it if
necessary.
+ (setq result (semantic-c-dereference-namespace-alias type-declaration
currentns))
+ (unless result
+ ;; Otherwise, check if we can reach the type through 'using'
statements.
+ (setq result
+ (semantic-c-check-type-namespace-using type-declaration
currentns)))
+ (setq namespaces (cdr namespaces)))))
+ (if result
+ ;; we have found the original type
+ (list result result)
+ (list type type-declaration))))
+
+(defun semantic-c-dereference-namespace-alias (type namespace)
+ "Dereference TYPE in NAMESPACE, given that NAMESPACE is an alias.
+Checks if NAMESPACE is an alias and if so, returns a new type
+with a fully qualified name in the original namespace. Returns
+nil if NAMESPACE is not an alias."
+ (when (eq (semantic-tag-get-attribute namespace :kind) 'alias)
+ (let ((typename (semantic-analyze-split-name (semantic-tag-name type)))
+ ns nstype originaltype newtype)
+ ;; Make typename unqualified
+ (if (listp typename)
+ (setq typename (last typename))
+ (setq typename (list typename)))
+ (when
+ (and
+ ;; Get original namespace and make sure TYPE exists there.
+ (setq ns (semantic-tag-name
+ (car (semantic-tag-get-attribute namespace :members))))
+ (setq nstype (semanticdb-typecache-find ns))
+ (setq originaltype (semantic-find-tags-by-name
+ (car typename)
+ (semantic-tag-get-attribute nstype :members))))
+ ;; Construct new type with name in original namespace.
+ (setq ns (semantic-analyze-split-name ns))
+ (setq newtype
+ (semantic-tag-clone
+ (car originaltype)
+ (semantic-analyze-unsplit-name
+ (if (listp ns)
+ (append ns typename)
+ (append (list ns) typename)))))))))
+
+;; This searches a type in a namespace, following through all using
+;; statements.
+(defun semantic-c-check-type-namespace-using (type namespace)
+ "Check if TYPE is accessible in NAMESPACE through a using statement.
+Returns the original type from the namespace where it is defined,
+or nil if it cannot be found."
+ (let (usings result usingname usingtype unqualifiedname members shortname
tmp)
+ ;; Get all using statements from NAMESPACE.
+ (when (and (setq usings (semantic-tag-get-attribute namespace :members))
+ (setq usings (semantic-find-tags-by-class 'using usings)))
+ ;; Get unqualified typename.
+ (when (listp (setq unqualifiedname (semantic-analyze-split-name
+ (semantic-tag-name type))))
+ (setq unqualifiedname (car (last unqualifiedname))))
+ ;; Iterate over all using statements in NAMESPACE.
+ (while (and usings
+ (null result))
+ (setq usingname (semantic-analyze-split-name
+ (semantic-tag-name (car usings)))
+ usingtype (semantic-tag-type (semantic-tag-type (car usings))))
+ (cond
+ ((or (string= usingtype "namespace")
+ (stringp usingname))
+ ;; We are dealing with a 'using [namespace] NAMESPACE;'
+ ;; Search for TYPE in that namespace
+ (setq result
+ (semanticdb-typecache-find usingname))
+ (if (and result
+ (setq members (semantic-tag-get-attribute result :members))
+ (setq members (semantic-find-tags-by-name unqualifiedname
members)))
+ ;; TYPE is member of that namespace, so we are finished
+ (setq result (car members))
+ ;; otherwise recursively search in that namespace for an alias
+ (setq result (semantic-c-check-type-namespace-using type result))
+ (when result
+ (setq result (semantic-tag-type result)))))
+ ((and (string= usingtype "class")
+ (listp usingname))
+ ;; We are dealing with a 'using TYPE;'
+ (when (string= unqualifiedname (car (last usingname)))
+ ;; We have found the correct tag.
+ (setq result (semantic-tag-type (car usings))))))
+ (setq usings (cdr usings))))
+ result))
+
+
+(define-mode-local-override semantic-analyze-dereference-metatype
+ c-mode (type scope &optional type-declaration)
+ "Dereference TYPE as described in `semantic-analyze-dereference-metatype'.
+Handle typedef, template instantiation, and '->' operator."
+ (let* ((dereferencer-list '(semantic-c-dereference-typedef
+ semantic-c-dereference-template
+ semantic-c-dereference-member-of
+ semantic-c-dereference-namespace))
+ (dereferencer (pop dereferencer-list))
+ (type-tuple)
+ (original-type type))
+ (while dereferencer
+ (setq type-tuple (funcall dereferencer type scope type-declaration)
+ type (car type-tuple)
+ type-declaration (cadr type-tuple))
+ (if (not (eq type original-type))
+ ;; we found a new type so break the dereferencer loop now !
+ ;; (we will be recalled with the new type expanded by
+ ;; semantic-analyze-dereference-metatype-stack).
+ (setq dereferencer nil)
+ ;; no new type found try the next dereferencer :
+ (setq dereferencer (pop dereferencer-list)))))
+ (list type type-declaration))
+
+(define-mode-local-override semantic-analyze-type-constants c-mode (type)
+ "When TYPE is a tag for an enum, return it's parts.
+These are constants which are of type TYPE."
+ (if (and (eq (semantic-tag-class type) 'type)
+ (string= (semantic-tag-type type) "enum"))
+ (semantic-tag-type-members type)))
+
+(define-mode-local-override semantic-analyze-split-name c-mode (name)
+ "Split up tag names on colon (:) boundaries."
+ (let ((ans (split-string name ":")))
+ (if (= (length ans) 1)
+ name
+ (delete "" ans))))
+
+(define-mode-local-override semantic-analyze-unsplit-name c-mode (namelist)
+ "Assemble the list of names NAMELIST into a namespace name."
+ (mapconcat 'identity namelist "::"))
+
+(define-mode-local-override semantic-ctxt-scoped-types c++-mode (&optional
point)
+ "Return a list of tags of CLASS type based on POINT.
+DO NOT return the list of tags encompassing point."
+ (when point (goto-char (point)))
+ (let ((tagsaroundpoint (semantic-find-tag-by-overlay))
+ (tagreturn nil)
+ (tmp nil))
+ ;; In C++, we want to find all the namespaces declared
+ ;; locally and add them to the list.
+ (setq tmp (semantic-find-tags-by-class 'type (current-buffer)))
+ (setq tmp (semantic-find-tags-by-type "namespace" tmp))
+ (setq tmp (semantic-find-tags-by-name "unnamed" tmp))
+ (setq tagreturn tmp)
+ ;; We should also find all "using" type statements and
+ ;; accept those entities in as well.
+ (setq tmp (semanticdb-find-tags-by-class 'using))
+ (let ((idx 0)
+ (len (semanticdb-find-result-length tmp)))
+ (while (< idx len)
+ (setq tagreturn (cons (semantic-tag-type (car
(semanticdb-find-result-nth tmp idx))) tagreturn))
+ (setq idx (1+ idx)))
+ )
+ ;; Use the encompased types around point to also look for using statements.
+ ;;(setq tagreturn (cons "bread_name" tagreturn))
+ (while (cdr tagsaroundpoint) ; don't search the last one
+ (setq tmp (semantic-find-tags-by-class 'using (semantic-tag-components
(car tagsaroundpoint))))
+ (dolist (T tmp)
+ (setq tagreturn (cons (semantic-tag-type T) tagreturn))
+ )
+ (setq tagsaroundpoint (cdr tagsaroundpoint))
+ )
+ ;; If in a function...
+ (when (and (semantic-tag-of-class-p (car tagsaroundpoint) 'function)
+ ;; ...search for using statements in the local scope...
+ (setq tmp (semantic-find-tags-by-class
+ 'using
+ (semantic-get-local-variables))))
+ ;; ... and add them.
+ (setq tagreturn
+ (append tagreturn
+ (mapcar 'semantic-tag-type tmp))))
+ ;; Return the stuff
+ tagreturn
+ ))
+
+(define-mode-local-override semantic-get-local-variables c++-mode ()
+ "Do what `semantic-get-local-variables' does, plus add `this' if needed."
+ (let* ((origvar (semantic-get-local-variables-default))
+ (ct (semantic-current-tag))
+ (p (semantic-tag-function-parent ct)))
+ ;; If we have a function parent, then that implies we can
+ (if (and p (semantic-tag-of-class-p ct 'function))
+ ;; Append a new tag THIS into our space.
+ (cons (semantic-tag-new-variable "this" p nil)
+ origvar)
+ ;; No parent, just return the usual
+ origvar)
+ ))
+
+(define-mode-local-override semantic-idle-summary-current-symbol-info
+ c-mode ()
+ "Handle the SPP keywords, then use the default mechanism."
+ (let* ((sym (car (semantic-ctxt-current-thing)))
+ (spp-sym (semantic-lex-spp-symbol sym)))
+ (if spp-sym
+ (let* ((txt (concat "Macro: " sym))
+ (sv (symbol-value spp-sym))
+ (arg (semantic-lex-spp-macro-with-args sv))
+ )
+ (when arg
+ (setq txt (concat txt (format "%S" arg)))
+ (setq sv (cdr sv)))
+
+ ;; This is optional, and potentially fraught w/ errors.
+ (condition-case nil
+ (dolist (lt sv)
+ (setq txt (concat txt " " (semantic-lex-token-text lt))))
+ (error (setq txt (concat txt " #error in summary fcn"))))
+
+ txt)
+ (semantic-idle-summary-current-symbol-info-default))))
+
+(defvar-mode-local c-mode semantic-orphaned-member-metaparent-type "struct"
+ "When lost memberes are found in the class hierarchy generator, use a
struct.")
+
+(defvar-mode-local c-mode semantic-symbol->name-assoc-list
+ '((type . "Types")
+ (variable . "Variables")
+ (function . "Functions")
+ (include . "Includes")
+ )
+ "List of tag classes, and strings to describe them.")
+
+(defvar-mode-local c-mode semantic-symbol->name-assoc-list-for-type-parts
+ '((type . "Types")
+ (variable . "Attributes")
+ (function . "Methods")
+ (label . "Labels")
+ )
+ "List of tag classes in a datatype decl, and strings to describe them.")
+
+(defvar-mode-local c-mode imenu-create-index-function
'semantic-create-imenu-index
+ "Imenu index function for C.")
+
+(defvar-mode-local c-mode semantic-type-relation-separator-character
+ '("." "->" "::")
+ "Separator characters between something of a given type, and a field.")
+
+(defvar-mode-local c-mode semantic-command-separation-character ";"
+ "Commen separation character for C")
+
+(defvar-mode-local c-mode senator-step-at-tag-classes '(function variable)
+ "Tag classes where senator will stop at the end.")
+
+;;;###autoload
+(defun semantic-default-c-setup ()
+ "Set up a buffer for semantic parsing of the C language."
+ (semantic-c-by--install-parser)
+ (setq semantic-lex-syntax-modifications '((?> ".")
+ (?< ".")
+ )
+ )
+
+ (setq semantic-lex-analyzer #'semantic-c-lexer)
+ (add-hook 'semantic-lex-reset-hooks 'semantic-lex-spp-reset-hook nil t)
+ )
+
+;;;###autoload
+(defun semantic-c-add-preprocessor-symbol (sym replacement)
+ "Add a preprocessor symbol SYM with a REPLACEMENT value."
+ (interactive "sSymbol: \nsReplacement: ")
+ (let ((SA (assoc sym semantic-lex-c-preprocessor-symbol-map)))
+ (if SA
+ ;; Replace if there is one.
+ (setcdr SA replacement)
+ ;; Otherwise, append
+ (setq semantic-lex-c-preprocessor-symbol-map
+ (cons (cons sym replacement)
+ semantic-lex-c-preprocessor-symbol-map))))
+
+ (semantic-c-reset-preprocessor-symbol-map)
+ )
+
+;;; SETUP QUERY
+;;
+(defun semantic-c-describe-environment ()
+ "Describe the Semantic features of the current C environment."
+ (interactive)
+ (if (not (or (eq major-mode 'c-mode) (eq major-mode 'c++-mode)))
+ (error "Not useful to query C mode in %s mode" major-mode))
+ (let ((gcc (when (boundp 'semantic-gcc-setup-data)
+ semantic-gcc-setup-data))
+ )
+ (semantic-fetch-tags)
+
+ (with-output-to-temp-buffer "*Semantic C Environment*"
+ (when gcc
+ (princ "Calculated GCC Parameters:")
+ (dolist (P gcc)
+ (princ "\n ")
+ (princ (car P))
+ (princ " = ")
+ (princ (cdr P))
+ )
+ )
+
+ (princ "\n\nInclude Path Summary:\n")
+ (when (and (boundp 'ede-object) ede-object)
+ (princ "\n This file's project include is handled by:\n")
+ (princ " ")
+ (princ (object-print ede-object))
+ (princ "\n with the system path:\n")
+ (dolist (dir (ede-system-include-path ede-object))
+ (princ " ")
+ (princ dir)
+ (princ "\n"))
+ )
+
+ (when semantic-dependency-include-path
+ (princ "\n This file's generic include path is:\n")
+ (dolist (dir semantic-dependency-include-path)
+ (princ " ")
+ (princ dir)
+ (princ "\n")))
+
+ (when semantic-dependency-system-include-path
+ (princ "\n This file's system include path is:\n")
+ (dolist (dir semantic-dependency-system-include-path)
+ (princ " ")
+ (princ dir)
+ (princ "\n")))
+
+ (princ "\n\nMacro Summary:\n")
+ (when semantic-lex-c-preprocessor-symbol-file
+ (princ "\n Your CPP table is primed from these files:\n")
+ (dolist (file semantic-lex-c-preprocessor-symbol-file)
+ (princ " ")
+ (princ file)
+ (princ "\n")
+ (princ " in table: ")
+ (princ (object-print (semanticdb-file-table-object file)))
+ (princ "\n")
+ ))
+
+ (when semantic-lex-c-preprocessor-symbol-map-builtin
+ (princ "\n Built-in symbol map:\n")
+ (dolist (S semantic-lex-c-preprocessor-symbol-map-builtin)
+ (princ " ")
+ (princ (car S))
+ (princ " = ")
+ (princ (cdr S))
+ (princ "\n")
+ ))
+
+ (when semantic-lex-c-preprocessor-symbol-map
+ (princ "\n User symbol map:\n")
+ (dolist (S semantic-lex-c-preprocessor-symbol-map)
+ (princ " ")
+ (princ (car S))
+ (princ " = ")
+ (princ (cdr S))
+ (princ "\n")
+ ))
+
+ (princ "\n\n Use: M-x semantic-lex-spp-describe RET\n")
+ (princ "\n to see the complete macro table.\n")
+
+ )))
+
+(provide 'semantic/bovine/c)
+
+(semantic-c-reset-preprocessor-symbol-map)
+
+;; Local variables:
+;; generated-autoload-file: "../loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/bovine/c"
+;; End:
+
+;;; semantic/bovine/c.el ends here
Index: cedet/semantic/bovine/debug.el
===================================================================
RCS file: cedet/semantic/bovine/debug.el
diff -N cedet/semantic/bovine/debug.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/bovine/debug.el 28 Sep 2009 15:15:10 -0000 1.2
@@ -0,0 +1,147 @@
+;;; semantic/bovine/debug.el --- Debugger support for bovinator
+
+;;; Copyright (C) 2003 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Implementation of the semantic debug support framework for the
+;; bovine parser.
+;;
+
+(require 'semantic/debug)
+(require 'semantic/find)
+
+;;; Code:
+
+;;; Support a frame for the Bovinator
+;;
+(defclass semantic-bovine-debug-frame (semantic-debug-frame)
+ ((nonterm :initarg :nonterm
+ :type symbol
+ :documentation
+ "The name of the semantic nonterminal for this frame.")
+ (rule :initarg :rule
+ :type number
+ :documentation
+ "The index into NONTERM's rule list. 0 based.")
+ (match :initarg :match
+ :type number
+ :documentation
+ "The index into NONTERM's RULE's match. 0 based..")
+ (collection :initarg :collection
+ :type list
+ :documentation
+ "List of things matched so far.")
+ (lextoken :initarg :lextoken
+ :type list
+ :documentation
+ "A Token created by `semantic-lex-token'.
+This is the lexical token being matched by the parser.")
+ )
+ "Debugger frame representation for the bovinator.")
+
+(defun semantic-bovine-debug-create-frame (nonterm rule match collection
+ lextoken)
+ "Create one bovine frame.
+NONTERM is the name of a rule we are currently parsing.
+RULE is the index into the list of rules in NONTERM.
+MATCH is the index into the list of matches in RULE.
+For example:
+ this: that
+ | other thing
+ | here
+ ;
+The NONTERM is THIS.
+The RULE is for \"thing\" is 1.
+The MATCH for \"thing\" is 1.
+COLLECTION is a list of `things' that have been matched so far.
+LEXTOKEN, is a token returned by the lexer which is being matched."
+ (let ((frame (semantic-bovine-debug-frame "frame"
+ :nonterm nonterm
+ :rule rule
+ :match match
+ :collection collection
+ :lextoken lextoken)))
+ (semantic-debug-set-frame semantic-debug-current-interface
+ frame)
+ frame))
+
+(defmethod semantic-debug-frame-highlight ((frame semantic-debug-frame))
+ "Highlight one parser frame."
+ (let* ((nonterm (oref frame nonterm))
+ (pb (oref semantic-debug-current-interface parser-buffer))
+ (start (semantic-brute-find-tag-by-class 'start pb))
+ )
+ ;; Make sure we get a good rule name, and that it is a string
+ (if (and (eq nonterm 'bovine-toplevel) start)
+ (setq nonterm (semantic-tag-name (car start)))
+ (setq nonterm (symbol-name nonterm)))
+
+ (semantic-debug-highlight-rule semantic-debug-current-interface
+ nonterm
+ (oref frame rule)
+ (oref frame match))
+ (semantic-debug-highlight-lexical-token semantic-debug-current-interface
+ (oref frame lextoken))
+ ))
+
+(defmethod semantic-debug-frame-info ((frame semantic-debug-frame))
+ "Display info about this one parser frame."
+ (message "%S" (oref frame collection))
+ )
+
+;;; Lisp error thrown frame.
+;;
+(defclass semantic-bovine-debug-error-frame (semantic-debug-frame)
+ ((condition :initarg :condition
+ :documentation
+ "An error condition caught in an action.")
+ )
+ "Debugger frame representaion of a lisp error thrown during parsing.")
+
+(defun semantic-create-bovine-debug-error-frame (condition)
+ "Create an error frame for bovine debugger.
+Argument CONDITION is the thrown error condition."
+ (let ((frame (semantic-bovine-debug-error-frame "frame"
+ :condition condition)))
+ (semantic-debug-set-frame semantic-debug-current-interface
+ frame)
+ frame))
+
+(defmethod semantic-debug-frame-highlight ((frame
semantic-bovine-debug-error-frame))
+ "Highlight a frame from an action."
+ ;; How do I get the location of the action in the source buffer?
+ )
+
+(defmethod semantic-debug-frame-info ((frame
semantic-bovine-debug-error-frame))
+ "Display info about the error thrown."
+ (message "Error: %S" (oref frame condition)))
+
+;;; Parser support for the debugger
+;;
+(defclass semantic-bovine-debug-parser (semantic-debug-parser)
+ (
+ )
+ "Represents a parser and its state.")
+
+
+(provide 'semantic/bovine/debug)
+
+;;; semantic/bovine/debug.el ends here
Index: cedet/semantic/bovine/el.el
===================================================================
RCS file: cedet/semantic/bovine/el.el
diff -N cedet/semantic/bovine/el.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/bovine/el.el 28 Sep 2009 15:15:10 -0000 1.2
@@ -0,0 +1,966 @@
+;;; semantic/bovine/el.el --- Semantic details for Emacs Lisp
+
+;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
+;;; 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Use the Semantic Bovinator for Emacs Lisp
+
+(require 'semantic)
+(require 'semantic/bovine)
+(require 'find-func)
+
+(require 'semantic/ctxt)
+(require 'semantic/format)
+(require 'thingatpt)
+
+;;; Code:
+
+;;; Lexer
+;;
+(define-lex semantic-emacs-lisp-lexer
+ "A simple lexical analyzer for Emacs Lisp.
+This lexer ignores comments and whitespace, and will return
+syntax as specified by the syntax table."
+ semantic-lex-ignore-whitespace
+ semantic-lex-ignore-newline
+ semantic-lex-number
+ semantic-lex-symbol-or-keyword
+ semantic-lex-charquote
+ semantic-lex-paren-or-list
+ semantic-lex-close-paren
+ semantic-lex-string
+ semantic-lex-ignore-comments
+ semantic-lex-punctuation
+ semantic-lex-default-action)
+
+;;; Parser
+;;
+(defvar semantic--elisp-parse-table
+ `((bovine-toplevel
+ (semantic-list
+ ,(lambda (vals start end)
+ (let ((tag (semantic-elisp-use-read (car vals))))
+ (cond
+ ((and (listp tag) (semantic-tag-p (car tag)))
+ ;; We got a list of tags back. This list is
+ ;; returned here in the correct order, but this
+ ;; list gets reversed later, putting the correctly ordered
+ ;; items into reverse order later.
+ (nreverse tag))
+ ((semantic--tag-expanded-p tag)
+ ;; At this point, if `semantic-elisp-use-read' returned an
+ ;; already expanded tag (from definitions parsed inside an
+ ;; eval and compile wrapper), just pass it!
+ tag)
+ (t
+ ;; We got the basics of a single tag.
+ (append tag (list start end))))))))
+ )
+ "Top level bovination table for elisp.")
+
+(defun semantic-elisp-desymbolify (arglist)
+ "Convert symbols to strings for ARGLIST."
+ (let ((out nil))
+ (while arglist
+ (setq out
+ (cons
+ (if (symbolp (car arglist))
+ (symbol-name (car arglist))
+ (if (and (listp (car arglist))
+ (symbolp (car (car arglist))))
+ (symbol-name (car (car arglist)))
+ (format "%S" (car arglist))))
+ out)
+ arglist (cdr arglist)))
+ (nreverse out)))
+
+(defun semantic-elisp-desymbolify-args (arglist)
+ "Convert symbols to strings for ARGLIST."
+ (let ((in (semantic-elisp-desymbolify arglist))
+ (out nil))
+ (dolist (T in)
+ (when (not (string-match "^&" T))
+ (push T out)))
+ (nreverse out)))
+
+(defun semantic-elisp-clos-slot-property-string (slot property)
+ "For SLOT, a string representing PROPERTY."
+ (let ((p (member property slot)))
+ (if (not p)
+ nil
+ (setq p (cdr p))
+ (cond
+ ((stringp (car p))
+ (car p))
+ ((or (symbolp (car p))
+ (listp (car p))
+ (numberp (car p)))
+ (format "%S" (car p)))
+ (t nil)))))
+
+(defun semantic-elisp-clos-args-to-semantic (partlist)
+ "Convert a list of CLOS class slot PARTLIST to `variable' tags."
+ (let (vars part v)
+ (while partlist
+ (setq part (car partlist)
+ partlist (cdr partlist)
+ v (semantic-tag-new-variable
+ (symbol-name (car part))
+ (semantic-elisp-clos-slot-property-string part :type)
+ (semantic-elisp-clos-slot-property-string part :initform)
+ ;; Attributes
+ :protection (semantic-elisp-clos-slot-property-string
+ part :protection)
+ :static-flag (equal (semantic-elisp-clos-slot-property-string
+ part :allocation)
+ ":class")
+ :documentation (semantic-elisp-clos-slot-property-string
+ part :documentation))
+ vars (cons v vars)))
+ (nreverse vars)))
+
+(defun semantic-elisp-form-to-doc-string (form)
+ "After reading a form FORM, covert it to a doc string.
+For Emacs Lisp, sometimes that string is non-existant.
+Sometimes it is a form which is evaluated at compile time, permitting
+compound strings."
+ (cond ((stringp form) form)
+ ((and (listp form) (eq (car form) 'concat)
+ (stringp (nth 1 form)))
+ (nth 1 form))
+ (t nil)))
+
+(defvar semantic-elisp-store-documentation-in-tag nil
+ "*When non-nil, store documentation strings in the created tags.")
+
+(defun semantic-elisp-do-doc (str)
+ "Return STR as a documentation string IF they are enabled."
+ (when semantic-elisp-store-documentation-in-tag
+ (semantic-elisp-form-to-doc-string str)))
+
+(defmacro semantic-elisp-setup-form-parser (parser &rest symbols)
+ "Install the function PARSER as the form parser for SYMBOLS.
+SYMBOLS is a list of symbols identifying the forms to parse.
+PARSER is called on every forms whose first element (car FORM) is
+found in SYMBOLS. It is passed the parameters FORM, START, END,
+where:
+
+- FORM is an Elisp form read from the current buffer.
+- START and END are the beginning and end location of the
+ corresponding data in the current buffer."
+ (let ((sym (make-symbol "sym")))
+ `(dolist (,sym ',symbols)
+ (put ,sym 'semantic-elisp-form-parser #',parser))))
+(put 'semantic-elisp-setup-form-parser 'lisp-indent-function 1)
+
+(defmacro semantic-elisp-reuse-form-parser (symbol &rest symbols)
+ "Reuse the form parser of SYMBOL for forms identified by SYMBOLS.
+See also `semantic-elisp-setup-form-parser'."
+ (let ((parser (make-symbol "parser"))
+ (sym (make-symbol "sym")))
+ `(let ((,parser (get ',symbol 'semantic-elisp-form-parser)))
+ (or ,parser
+ (signal 'wrong-type-argument
+ '(semantic-elisp-form-parser ,symbol)))
+ (dolist (,sym ',symbols)
+ (put ,sym 'semantic-elisp-form-parser ,parser)))))
+
+(defun semantic-elisp-use-read (sl)
+ "Use `read' on the semantic list SL.
+Return a bovination list to use."
+ (let* ((start (car sl))
+ (end (cdr sl))
+ (form (read (buffer-substring-no-properties start end))))
+ (cond
+ ;; If the first elt is a list, then it is some arbitrary code.
+ ((listp (car form))
+ (semantic-tag-new-code "anonymous" nil)
+ )
+ ;; A special form parser is provided, use it.
+ ((and (car form) (symbolp (car form))
+ (get (car form) 'semantic-elisp-form-parser))
+ (funcall (get (car form) 'semantic-elisp-form-parser)
+ form start end))
+ ;; Produce a generic code tag by default.
+ (t
+ (semantic-tag-new-code (format "%S" (car form)) nil)
+ ))))
+
+;;; Form parsers
+;;
+(semantic-elisp-setup-form-parser
+ (lambda (form start end)
+ (semantic-tag-new-function
+ (symbol-name (nth 2 form))
+ nil
+ '("form" "start" "end")
+ :form-parser t
+ ))
+ semantic-elisp-setup-form-parser)
+
+(semantic-elisp-setup-form-parser
+ (lambda (form start end)
+ (let ((tags
+ (condition-case foo
+ (semantic-parse-region start end nil 1)
+ (error (message "MUNGE: %S" foo)
+ nil))))
+ (if (semantic-tag-p (car-safe tags))
+ tags
+ (semantic-tag-new-code (format "%S" (car form)) nil))))
+ eval-and-compile
+ eval-when-compile
+ )
+
+(semantic-elisp-setup-form-parser
+ (lambda (form start end)
+ (semantic-tag-new-function
+ (symbol-name (nth 1 form))
+ nil
+ (semantic-elisp-desymbolify-args (nth 2 form))
+ :user-visible-flag (eq (car-safe (nth 4 form)) 'interactive)
+ :documentation (semantic-elisp-do-doc (nth 3 form))
+ :overloadable (or (eq (car form) 'define-overload)
+ (eq (car form) 'define-overloadable-function))
+ ))
+ defun
+ defun*
+ defsubst
+ defmacro
+ define-overload ;; @todo - remove after cleaning up semantic.
+ define-overloadable-function
+ )
+
+(semantic-elisp-setup-form-parser
+ (lambda (form start end)
+ (let ((doc (semantic-elisp-form-to-doc-string (nth 3 form))))
+ (semantic-tag-new-variable
+ (symbol-name (nth 1 form))
+ nil
+ (nth 2 form)
+ :user-visible-flag (and doc
+ (> (length doc) 0)
+ (= (aref doc 0) ?*))
+ :constant-flag (eq (car form) 'defconst)
+ :documentation (semantic-elisp-do-doc doc)
+ )))
+ defvar
+ defconst
+ defcustom
+ )
+
+(semantic-elisp-setup-form-parser
+ (lambda (form start end)
+ (let ((doc (semantic-elisp-form-to-doc-string (nth 3 form))))
+ (semantic-tag-new-variable
+ (symbol-name (nth 1 form))
+ "face"
+ (nth 2 form)
+ :user-visible-flag (and doc
+ (> (length doc) 0)
+ (= (aref doc 0) ?*))
+ :documentation (semantic-elisp-do-doc doc)
+ )))
+ defface
+ )
+
+
+(semantic-elisp-setup-form-parser
+ (lambda (form start end)
+ (let ((doc (semantic-elisp-form-to-doc-string (nth 3 form))))
+ (semantic-tag-new-variable
+ (symbol-name (nth 1 form))
+ "image"
+ (nth 2 form)
+ :user-visible-flag (and doc
+ (> (length doc) 0)
+ (= (aref doc 0) ?*))
+ :documentation (semantic-elisp-do-doc doc)
+ )))
+ defimage
+ defezimage
+ )
+
+
+(semantic-elisp-setup-form-parser
+ (lambda (form start end)
+ (let ((doc (semantic-elisp-form-to-doc-string (nth 3 form))))
+ (semantic-tag
+ (symbol-name (nth 1 form))
+ 'customgroup
+ :value (nth 2 form)
+ :user-visible-flag t
+ :documentation (semantic-elisp-do-doc doc)
+ )))
+ defgroup
+ )
+
+
+(semantic-elisp-setup-form-parser
+ (lambda (form start end)
+ (semantic-tag-new-function
+ (symbol-name (cadr (cadr form)))
+ nil nil
+ :user-visible-flag (and (nth 4 form)
+ (not (eq (nth 4 form) 'nil)))
+ :prototype-flag t
+ :documentation (semantic-elisp-do-doc (nth 3 form))))
+ autoload
+ )
+
+(semantic-elisp-setup-form-parser
+ (lambda (form start end)
+ (let* ((a2 (nth 2 form))
+ (a3 (nth 3 form))
+ (args (if (listp a2) a2 a3))
+ (doc (nth (if (listp a2) 3 4) form)))
+ (semantic-tag-new-function
+ (symbol-name (nth 1 form))
+ nil
+ (if (listp (car args))
+ (cons (symbol-name (caar args))
+ (semantic-elisp-desymbolify-args (cdr args)))
+ (semantic-elisp-desymbolify-args (cdr args)))
+ :parent (if (listp (car args)) (symbol-name (cadr (car args))) nil)
+ :documentation (semantic-elisp-do-doc doc)
+ )))
+ defmethod
+ defgeneric
+ )
+
+(semantic-elisp-setup-form-parser
+ (lambda (form start end)
+ (semantic-tag-new-function
+ (symbol-name (nth 1 form))
+ nil
+ (semantic-elisp-desymbolify (nth 2 form))
+ ))
+ defadvice
+ )
+
+(semantic-elisp-setup-form-parser
+ (lambda (form start end)
+ (let ((docpart (nthcdr 4 form)))
+ (semantic-tag-new-type
+ (symbol-name (nth 1 form))
+ "class"
+ (semantic-elisp-clos-args-to-semantic (nth 3 form))
+ (semantic-elisp-desymbolify (nth 2 form))
+ :typemodifiers (semantic-elisp-desymbolify
+ (unless (stringp (car docpart)) docpart))
+ :documentation (semantic-elisp-do-doc
+ (if (stringp (car docpart))
+ (car docpart)
+ (cadr (member :documentation docpart))))
+ )))
+ defclass
+ )
+
+(semantic-elisp-setup-form-parser
+ (lambda (form start end)
+ (let ((slots (nthcdr 2 form)))
+ ;; Skip doc string if present.
+ (and (stringp (car slots))
+ (setq slots (cdr slots)))
+ (semantic-tag-new-type
+ (symbol-name (if (consp (nth 1 form))
+ (car (nth 1 form))
+ (nth 1 form)))
+ "struct"
+ (semantic-elisp-desymbolify slots)
+ (cons nil nil)
+ )))
+ defstruct
+ )
+
+(semantic-elisp-setup-form-parser
+ (lambda (form start end)
+ (semantic-tag-new-function
+ (symbol-name (nth 1 form))
+ nil nil
+ :lexical-analyzer-flag t
+ :documentation (semantic-elisp-do-doc (nth 2 form))
+ ))
+ define-lex
+ )
+
+(semantic-elisp-setup-form-parser
+ (lambda (form start end)
+ (let ((args (nth 3 form)))
+ (semantic-tag-new-function
+ (symbol-name (nth 1 form))
+ nil
+ (and (listp args) (semantic-elisp-desymbolify args))
+ :override-function-flag t
+ :parent (symbol-name (nth 2 form))
+ :documentation (semantic-elisp-do-doc (nth 4 form))
+ )))
+ define-mode-overload-implementation ;; obsoleted
+ define-mode-local-override
+ )
+
+(semantic-elisp-setup-form-parser
+ (lambda (form start end)
+ (semantic-tag-new-variable
+ (symbol-name (nth 2 form))
+ nil
+ (nth 3 form) ; default value
+ :override-variable-flag t
+ :parent (symbol-name (nth 1 form))
+ :documentation (semantic-elisp-do-doc (nth 4 form))
+ ))
+ defvar-mode-local
+ )
+
+(semantic-elisp-setup-form-parser
+ (lambda (form start end)
+ (let ((name (nth 1 form)))
+ (semantic-tag-new-include
+ (symbol-name (if (eq (car-safe name) 'quote)
+ (nth 1 name)
+ name))
+ nil
+ :directory (nth 2 form))))
+ require
+ )
+
+(semantic-elisp-setup-form-parser
+ (lambda (form start end)
+ (let ((name (nth 1 form)))
+ (semantic-tag-new-package
+ (symbol-name (if (eq (car-safe name) 'quote)
+ (nth 1 name)
+ name))
+ (nth 3 form))))
+ provide
+ )
+
+;;; Mode setup
+;;
+(define-mode-local-override semantic-dependency-tag-file
+ emacs-lisp-mode (tag)
+ "Find the file BUFFER depends on described by TAG."
+ (if (fboundp 'find-library-name)
+ (condition-case nil
+ ;; Try an Emacs 22 fcn. This throws errors.
+ (find-library-name (semantic-tag-name tag))
+ (error
+ (message "semantic: connot find source file %s"
+ (semantic-tag-name tag))))
+ ;; No handy function available. (Older Emacsen)
+ (let* ((lib (locate-library (semantic-tag-name tag)))
+ (name (if lib (file-name-sans-extension lib) nil))
+ (nameel (concat name ".el")))
+ (cond
+ ((and name (file-exists-p nameel)) nameel)
+ ((and name (file-exists-p (concat name ".el.gz")))
+ ;; This is the linux distro case.
+ (concat name ".el.gz"))
+ ;; source file does not exists
+ (name
+ (message "semantic: cannot find source file %s" (concat name ".el")))
+ (t
+ nil)))))
+
+;;; DOC Strings
+;;
+(defun semantic-emacs-lisp-overridable-doc (tag)
+ "Return the documentation string generated for overloadable functions.
+Fetch the item for TAG. Only returns info about what symbols can be
+used to perform the override."
+ (if (and (eq (semantic-tag-class tag) 'function)
+ (semantic-tag-get-attribute tag :overloadable))
+ ;; Calc the doc to use for the overloadable symbols.
+ (overload-docstring-extension (intern (semantic-tag-name tag)))
+ ""))
+
+(defun semantic-emacs-lisp-obsoleted-doc (tag)
+ "Indicate that TAG is a new name that has obsoleted some old name.
+Unfortunately, this requires that the tag in question has been loaded
+into Emacs Lisp's memory."
+ (let ((obsoletethis (intern-soft (semantic-tag-name tag)))
+ (obsoletor nil))
+ ;; This asks if our tag is available in the Emacs name space for querying.
+ (when obsoletethis
+ (mapatoms (lambda (a)
+ (let ((oi (get a 'byte-obsolete-info)))
+ (if (and oi (eq (car oi) obsoletethis))
+ (setq obsoletor a)))))
+ (if obsoletor
+ (format "address@hidden,%s}" obsoletor (semantic-tag-name tag))
+ ""))))
+
+(define-mode-local-override semantic-documentation-for-tag
+ emacs-lisp-mode (tag &optional nosnarf)
+ "Return the documentation string for TAG.
+Optional argument NOSNARF is ignored."
+ (let ((d (semantic-tag-docstring tag)))
+ (when (not d)
+ (cond ((semantic-tag-with-position-p tag)
+ ;; Doc isn't in the tag itself. Lets pull it out of the
+ ;; sources.
+ (let ((semantic-elisp-store-documentation-in-tag t))
+ (setq tag (with-current-buffer (semantic-tag-buffer tag)
+ (goto-char (semantic-tag-start tag))
+ (semantic-elisp-use-read
+ ;; concoct a lexical token.
+ (cons (semantic-tag-start tag)
+ (semantic-tag-end tag))))
+ d (semantic-tag-docstring tag))))
+ ;; The tag may be the result of a system search.
+ ((intern-soft (semantic-tag-name tag))
+ (let ((sym (intern-soft (semantic-tag-name tag))))
+ ;; Query into the global table o stuff.
+ (cond ((eq (semantic-tag-class tag) 'function)
+ (setq d (documentation sym)))
+ (t
+ (setq d (documentation-property
+ sym 'variable-documentation)))))
+ ;; Label it as system doc.. perhaps just for debugging
+ ;; purposes.
+ (if d (setq d (concat "Sytem Doc: \n" d)))
+ ))
+ )
+
+ (when d
+ (concat
+ (substitute-command-keys
+ (if (and (> (length d) 0) (= (aref d 0) ?*))
+ (substring d 1)
+ d))
+ (semantic-emacs-lisp-overridable-doc tag)
+ (semantic-emacs-lisp-obsoleted-doc tag)))))
+
+;;; Tag Features
+;;
+(define-mode-local-override semantic-tag-include-filename emacs-lisp-mode
+ (tag)
+ "Return the name of the tag with .el appended.
+If there is a detail, prepend that directory."
+ (let ((name (semantic-tag-name tag))
+ (detail (semantic-tag-get-attribute tag :directory)))
+ (concat (expand-file-name name detail) ".el")))
+
+(define-mode-local-override semantic-insert-foreign-tag
+ emacs-lisp-mode (tag)
+ "Insert TAG at point.
+Attempts a simple prototype for calling or using TAG."
+ (cond ((semantic-tag-of-class-p tag 'function)
+ (insert "(" (semantic-tag-name tag) " )")
+ (forward-char -1))
+ (t
+ (insert (semantic-tag-name tag)))))
+
+(define-mode-local-override semantic-tag-protection
+ emacs-lisp-mode (tag &optional parent)
+ "Return the protection of TAG in PARENT.
+Override function for `semantic-tag-protection'."
+ (let ((prot (semantic-tag-get-attribute tag :protection)))
+ (cond
+ ;; If a protection is not specified, AND there is a parent
+ ;; data type, then it is public.
+ ((and (not prot) parent) 'public)
+ ((string= prot ":public") 'public)
+ ((string= prot "public") 'public)
+ ((string= prot ":private") 'private)
+ ((string= prot "private") 'private)
+ ((string= prot ":protected") 'protected)
+ ((string= prot "protected") 'protected))))
+
+(define-mode-local-override semantic-tag-static-p
+ emacs-lisp-mode (tag &optional parent)
+ "Return non-nil if TAG is static in PARENT class.
+Overrides `semantic-nonterminal-static'."
+ ;; This can only be true (theoretically) in a class where it is assigned.
+ (semantic-tag-get-attribute tag :static-flag))
+
+;;; Context parsing
+;;
+;; Emacs lisp is very different from C,C++ which most context parsing
+;; functions are written. Support them here.
+(define-mode-local-override semantic-up-context emacs-lisp-mode
+ (&optional point bounds-type)
+ "Move up one context in an Emacs Lisp function.
+A Context in many languages is a block with it's own local variables.
+In Emacs, we will move up lists and stop when one starts with one of
+the following context specifiers:
+ `let', `let*', `defun', `with-slots'
+Returns non-nil it is not possible to go up a context."
+ (let ((last-up (semantic-up-context-default)))
+ (while
+ (and (not (looking-at
+ "(\\(let\\*?\\|def\\(un\\|method\\|generic\\|\
+define-mode-overload\\)\
+\\|with-slots\\)"))
+ (not last-up))
+ (setq last-up (semantic-up-context-default)))
+ last-up))
+
+
+(define-mode-local-override semantic-ctxt-current-function emacs-lisp-mode
+ (&optional point same-as-symbol-return)
+ "Return a string which is the current function being called."
+ (save-excursion
+ (if point (goto-char point) (setq point (point)))
+ ;; (semantic-beginning-of-command)
+ (if (condition-case nil
+ (and (save-excursion
+ (up-list -2)
+ (looking-at "(("))
+ (save-excursion
+ (up-list -3)
+ (looking-at "(let")))
+ (error nil))
+ ;; This is really a let statement, not a function.
+ nil
+ (let ((fun (condition-case nil
+ (save-excursion
+ (up-list -1)
+ (forward-char 1)
+ (buffer-substring-no-properties
+ (point) (progn (forward-sexp 1)
+ (point))))
+ (error nil))
+ ))
+ (when fun
+ ;; Do not return FUN IFF the cursor is on FUN.
+ ;; Huh? Thats because if cursor is on fun, it is
+ ;; the current symbol, and not the current function.
+ (if (save-excursion
+ (condition-case nil
+ (progn (forward-sexp -1)
+ (and
+ (looking-at (regexp-quote fun))
+ (<= point (+ (point) (length fun))))
+ )
+ (error t)))
+ ;; Go up and try again.
+ same-as-symbol-return
+ ;; We are ok, so get it.
+ (list fun))
+ ))
+ )))
+
+
+(define-mode-local-override semantic-get-local-variables emacs-lisp-mode
+ (&optional point)
+ "Return a list of local variables for POINT.
+Scan backwards from point at each successive function. For all occurances
+of `let' or `let*', grab those variable names."
+ (let* ((vars nil)
+ (fn nil))
+ (save-excursion
+ (while (setq fn (car (semantic-ctxt-current-function-emacs-lisp-mode
+ (point) (list t))))
+ (cond
+ ((eq fn t)
+ nil)
+ ((member fn '("let" "let*" "with-slots"))
+ ;; Snarf variables
+ (up-list -1)
+ (forward-char 1)
+ (forward-symbol 1)
+ (skip-chars-forward "* \t\n")
+ (let ((varlst (read (buffer-substring-no-properties
+ (point)
+ (save-excursion
+ (forward-sexp 1)
+ (point))))))
+ (while varlst
+ (let* ((oneelt (car varlst))
+ (name (if (symbolp oneelt)
+ oneelt
+ (car oneelt))))
+ (setq vars (cons (semantic-tag-new-variable
+ (symbol-name name)
+ nil nil)
+ vars)))
+ (setq varlst (cdr varlst)))
+ ))
+ ((string= fn "lambda")
+ ;; Snart args...
+ (up-list -1)
+ (forward-char 1)
+ (forward-word 1)
+ (skip-chars-forward "* \t\n")
+ (let ((arglst (read (buffer-substring-no-properties
+ (point)
+ (save-excursion
+ (forward-sexp 1)
+ (point))))))
+ (while arglst
+ (let* ((name (car arglst)))
+ (when (/= ?& (aref (symbol-name name) 0))
+ (setq vars (cons (semantic-tag-new-variable
+ (symbol-name name)
+ nil nil)
+ vars))))
+ (setq arglst (cdr arglst)))
+ ))
+ )
+ (up-list -1)))
+ (nreverse vars)))
+
+(define-mode-local-override semantic-end-of-command emacs-lisp-mode
+ ()
+ "Move cursor to the end of the current command.
+In emacs lisp this is easilly defined by parenthisis bounding."
+ (condition-case nil
+ (up-list 1)
+ (error nil)))
+
+(define-mode-local-override semantic-beginning-of-command emacs-lisp-mode
+ ()
+ "Move cursor to the beginning of the current command.
+In emacs lisp this is easilly defined by parenthisis bounding."
+ (condition-case nil
+ (progn
+ (up-list -1)
+ (forward-char 1))
+ (error nil)))
+
+(define-mode-local-override semantic-ctxt-current-symbol emacs-lisp-mode
+ (&optional point)
+ "List the symbol under point."
+ (save-excursion
+ (if point (goto-char point))
+ (require 'thingatpt)
+ (let ((sym (thing-at-point 'symbol)))
+ (if sym (list sym)))
+ ))
+
+
+(define-mode-local-override semantic-ctxt-current-assignment emacs-lisp-mode
+ (&optional point)
+ "What is the variable being assigned into at POINT?"
+ (save-excursion
+ (if point (goto-char point))
+ (let ((fn (semantic-ctxt-current-function point))
+ (point (point)))
+ ;; We should never get lists from here.
+ (if fn (setq fn (car fn)))
+ (cond
+ ;; SETQ
+ ((and fn (or (string= fn "setq") (string= fn "set")))
+ (save-excursion
+ (condition-case nil
+ (let ((count 0)
+ (lastodd nil)
+ (start nil))
+ (up-list -1)
+ (down-list 1)
+ (forward-sexp 1)
+ ;; Skip over sexp until we pass point.
+ (while (< (point) point)
+ (setq count (1+ count))
+ (forward-comment 1)
+ (setq start (point))
+ (forward-sexp 1)
+ (if (= (% count 2) 1)
+ (setq lastodd
+ (buffer-substring-no-properties start (point))))
+ )
+ (if lastodd (list lastodd))
+ )
+ (error nil))))
+ ;; This obscure thing finds let statements.
+ ((condition-case nil
+ (and
+ (save-excursion
+ (up-list -2)
+ (looking-at "(("))
+ (save-excursion
+ (up-list -3)
+ (looking-at "(let")))
+ (error nil))
+ (save-excursion
+ (semantic-beginning-of-command)
+ ;; Use func finding code, since it is the same format.
+ (semantic-ctxt-current-symbol)))
+ ;;
+ ;; DEFAULT- nothing
+ (t nil))
+ )))
+
+(define-mode-local-override semantic-ctxt-current-argument emacs-lisp-mode
+ (&optional point)
+ "Return the index into the argument the cursor is in, or nil."
+ (save-excursion
+ (if point (goto-char point))
+ (if (looking-at "\\<\\w")
+ (forward-char 1))
+ (let ((count 0))
+ (while (condition-case nil
+ (progn
+ (forward-sexp -1)
+ t)
+ (error nil))
+ (setq count (1+ count)))
+ (cond ((= count 0)
+ 0)
+ (t (1- count))))
+ ))
+
+(define-mode-local-override semantic-ctxt-current-class-list emacs-lisp-mode
+ (&optional point)
+ "Return a list of tag classes allowed at POINT.
+Emacs Lisp knows much more about the class of the tag needed to perform
+completion than some langauges. We distincly know if we are to be
+a function name, variable name, or any type of symbol. We could identify
+fields and such to, but that is for some other day."
+ (save-excursion
+ (if point (goto-char point))
+ (setq point (point))
+ (condition-case nil
+ (let ((count 0))
+ (up-list -1)
+ (forward-char 1)
+ (while (< (point) point)
+ (setq count (1+ count))
+ (forward-sexp 1))
+ (if (= count 1)
+ '(function)
+ '(variable))
+ )
+ (error '(variable)))
+ ))
+
+;;; Formatting
+;;
+(define-mode-local-override semantic-format-tag-abbreviate emacs-lisp-mode
+ (tag &optional parent color)
+ "Return an abbreviated string describing tag."
+ (let ((class (semantic-tag-class tag))
+ (name (semantic-format-tag-name tag parent color))
+ )
+ (cond
+ ((eq class 'function)
+ (concat "(" name ")"))
+ (t
+ (semantic-format-tag-abbreviate-default tag parent color)))))
+
+(define-mode-local-override semantic-format-tag-prototype emacs-lisp-mode
+ (tag &optional parent color)
+ "Return a prototype string describing tag.
+In Emacs Lisp, a prototype for something may start (autoload ...).
+This is certainly not expected if this is used to display a summary.
+Make up something else. When we go to write something that needs
+a real Emacs Lisp protype, we can fix it then."
+ (let ((class (semantic-tag-class tag))
+ (name (semantic-format-tag-name tag parent color))
+ )
+ (cond
+ ((eq class 'function)
+ (let* ((args (semantic-tag-function-arguments tag))
+ (argstr (semantic--format-tag-arguments args
+ #'identity
+ color)))
+ (concat "(" name (if args " " "")
+ argstr
+ ")")))
+ (t
+ (semantic-format-tag-prototype-default tag parent color)))))
+
+(define-mode-local-override semantic-format-tag-concise-prototype
emacs-lisp-mode
+ (tag &optional parent color)
+ "Return a concise prototype string describing tag.
+See `semantic-format-tag-prototype' for Emacs Lisp for more details."
+ (semantic-format-tag-prototype tag parent color))
+
+(define-mode-local-override semantic-format-tag-uml-prototype emacs-lisp-mode
+ (tag &optional parent color)
+ "Return a uml prototype string describing tag.
+See `semantic-format-tag-prototype' for Emacs Lisp for more details."
+ (semantic-format-tag-prototype tag parent color))
+
+;;; IA Commands
+;;
+(define-mode-local-override semantic-ia-insert-tag
+ emacs-lisp-mode (tag)
+ "Insert TAG into the current buffer based on completion."
+ ;; This function by David <address@hidden> is a tweaked version of the
original.
+ (insert (semantic-tag-name tag))
+ (let ((tt (semantic-tag-class tag))
+ (args (semantic-tag-function-arguments tag)))
+ (cond ((eq tt 'function)
+ (if args
+ (insert " ")
+ (insert ")")))
+ (t nil))))
+
+;;; Lexical features and setup
+;;
+(defvar-mode-local emacs-lisp-mode semantic-lex-analyzer
+ 'semantic-emacs-lisp-lexer)
+
+(defvar-mode-local emacs-lisp-mode semantic--parse-table
+ semantic--elisp-parse-table)
+
+(defvar-mode-local emacs-lisp-mode semantic-function-argument-separator
+ " ")
+
+(defvar-mode-local emacs-lisp-mode
semantic-function-argument-separation-character
+ " ")
+
+(defvar-mode-local emacs-lisp-mode semantic-symbol->name-assoc-list
+ '(
+ (type . "Types")
+ (variable . "Variables")
+ (function . "Defuns")
+ (include . "Requires")
+ (package . "Provides")
+ ))
+
+(defvar-mode-local emacs-lisp-mode imenu-create-index-function
+ 'semantic-create-imenu-index)
+
+(defvar-mode-local emacs-lisp-mode semantic-stickyfunc-sticky-classes
+ '(function type variable)
+ "Add variables.
+ELisp variables can be pretty long, so track this one too.")
+
+(define-child-mode lisp-mode emacs-lisp-mode
+ "Make `lisp-mode' inherits mode local behavior from `emacs-lisp-mode'.")
+
+(defun semantic-default-elisp-setup ()
+ "Setup hook function for Emacs Lisp files and Semantic."
+ )
+
+(add-hook 'emacs-lisp-mode-hook 'semantic-default-elisp-setup)
+
+;;; LISP MODE
+;;
+;; @TODO: Lisp supports syntaxes that Emacs Lisp does not.
+;; Write a Lisp only parser someday.
+;;
+;; See this syntax:
+;; (defun foo () /#A)
+;;
+(add-hook 'lisp-mode-hook 'semantic-default-elisp-setup)
+
+(eval-after-load "semanticdb"
+ '(require 'semanticdb-el)
+ )
+
+(provide 'semantic/bovine/el)
+
+;;; semantic/bovine/el.el ends here
Index: cedet/semantic/bovine/gcc.el
===================================================================
RCS file: cedet/semantic/bovine/gcc.el
diff -N cedet/semantic/bovine/gcc.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/bovine/gcc.el 28 Sep 2009 15:15:10 -0000 1.2
@@ -0,0 +1,224 @@
+;;; semantic/bovine/gcc.el --- gcc querying special code for the C parser
+
+;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; GCC stores things in special places. These functions will query
+;; GCC, and set up the preprocessor and include paths.
+
+(require 'semantic/dep)
+
+(defvar semantic-lex-c-preprocessor-symbol-file)
+(defvar semantic-lex-c-preprocessor-symbol-map)
+(declare-function semantic-c-reset-preprocessor-symbol-map
+ "semantic/bovine/gcc")
+
+;;; Code:
+
+(defun semantic-gcc-query (gcc-cmd &rest gcc-options)
+ "Return program output to both standard output and standard error.
+GCC-CMD is the program to execute and GCC-OPTIONS are the options
+to give to the program."
+ ;; $ gcc -v
+ ;;
+ (let ((buff (get-buffer-create " *gcc-query*"))
+ (old-lc-messages (getenv "LC_ALL")))
+ (save-excursion
+ (set-buffer buff)
+ (erase-buffer)
+ (setenv "LC_ALL" "C")
+ (condition-case nil
+ (apply 'call-process gcc-cmd nil (cons buff t) nil gcc-options)
+ (error ;; Some bogus directory for the first time perhaps?
+ (let ((default-directory (expand-file-name "~/")))
+ (condition-case nil
+ (apply 'call-process gcc-cmd nil (cons buff t) nil gcc-options)
+ (error ;; gcc doesn't exist???
+ nil)))))
+ (setenv "LC_ALL" old-lc-messages)
+ (prog1
+ (buffer-string)
+ (kill-buffer buff)
+ )
+ )))
+
+;;(semantic-gcc-get-include-paths "c")
+;;(semantic-gcc-get-include-paths "c++")
+(defun semantic-gcc-get-include-paths (lang)
+ "Return include paths as gcc use them for language LANG."
+ (let* ((gcc-cmd (cond
+ ((string= lang "c") "gcc")
+ ((string= lang "c++") "c++")
+ (t (if (stringp lang)
+ (error "Unknown lang: %s" lang)
+ (error "LANG=%S, should be a string" lang)))))
+ (gcc-output (semantic-gcc-query gcc-cmd "-v" "-E" "-x" lang
null-device))
+ (lines (split-string gcc-output "\n"))
+ (include-marks 0)
+ (inc-mark "#include ")
+ (inc-mark-len (length "#include "))
+ inc-path)
+ ;;(message "gcc-output=%s" gcc-output)
+ (dolist (line lines)
+ (when (> (length line) 1)
+ (if (= 0 include-marks)
+ (when (and (> (length line) inc-mark-len)
+ (string= inc-mark (substring line 0 inc-mark-len)))
+ (setq include-marks (1+ include-marks)))
+ (let ((chars (append line nil)))
+ (when (= 32 (nth 0 chars))
+ (let ((path (substring line 1)))
+ (when (file-accessible-directory-p path)
+ (when (if (memq system-type '(windows-nt))
+ (/= ?/ (nth 1 chars))
+ (= ?/ (nth 1 chars)))
+ (add-to-list 'inc-path
+ (expand-file-name (substring line 1))
+ t)))))))))
+ inc-path))
+
+
+(defun semantic-cpp-defs (str)
+ "Convert CPP output STR into a list of cons cells with defines for C++."
+ (let ((lines (split-string str "\n"))
+ (lst nil))
+ (dolist (L lines)
+ (let ((dat (split-string L)))
+ (when (= (length dat) 3)
+ (add-to-list 'lst (cons (nth 1 dat) (nth 2 dat))))))
+ lst))
+
+(defun semantic-gcc-fields (str)
+ "Convert GCC output STR into an alist of fields."
+ (let ((fields nil)
+ (lines (split-string str "\n"))
+ )
+ (dolist (L lines)
+ ;; For any line, what do we do with it?
+ (cond ((or (string-match "Configured with\\(:\\)" L)
+ (string-match "\\(:\\)\\s-*[^ ]*configure " L))
+ (let* ((parts (substring L (match-end 1)))
+ (opts (split-string parts " " t))
+ )
+ (dolist (O (cdr opts))
+ (let* ((data (split-string O "="))
+ (sym (intern (car data)))
+ (val (car (cdr data))))
+ (push (cons sym val) fields)
+ ))
+ ))
+ ((string-match "gcc[ -][vV]ersion" L)
+ (let* ((vline (substring L (match-end 0)))
+ (parts (split-string vline " ")))
+ (push (cons 'version (nth 1 parts)) fields)))
+ ((string-match "Target: " L)
+ (let ((parts (split-string L " ")))
+ (push (cons 'target (nth 1 parts)) fields)))
+ ))
+ fields))
+
+(defvar semantic-gcc-setup-data nil
+ "The GCC setup data.
+This is setup by `semantic-gcc-setup'.
+This is an alist, and should include keys of:
+ 'version - The version of gcc
+ '--host - The host symbol. (Used in include directories)
+ '--prefix - Where GCC was installed.
+It should also include other symbols GCC was compiled with.")
+
+;;;###autoload
+(defun semantic-gcc-setup ()
+ "Setup Semantic C/C++ parsing based on GCC output."
+ (interactive)
+ (let* ((fields (or semantic-gcc-setup-data
+ (semantic-gcc-fields (semantic-gcc-query "gcc" "-v"))))
+ (defines (semantic-cpp-defs (semantic-gcc-query "cpp" "-E" "-dM" "-x"
"c++" null-device)))
+ (ver (cdr (assoc 'version fields)))
+ (host (or (cdr (assoc 'target fields))
+ (cdr (assoc '--target fields))
+ (cdr (assoc '--host fields))))
+ (prefix (cdr (assoc '--prefix fields)))
+ ;; gcc output supplied paths
+ (c-include-path (semantic-gcc-get-include-paths "c"))
+ (c++-include-path (semantic-gcc-get-include-paths "c++")))
+ ;; Remember so we don't have to call GCC twice.
+ (setq semantic-gcc-setup-data fields)
+ (unless c-include-path
+ ;; Fallback to guesses
+ (let* ( ;; gcc include dirs
+ (gcc-exe (locate-file "gcc" exec-path exec-suffixes 'executable))
+ (gcc-root (expand-file-name ".." (file-name-directory gcc-exe)))
+ (gcc-include (expand-file-name "include" gcc-root))
+ (gcc-include-c++ (expand-file-name "c++" gcc-include))
+ (gcc-include-c++-ver (expand-file-name ver gcc-include-c++))
+ (gcc-include-c++-ver-host (expand-file-name host
gcc-include-c++-ver)))
+ (setq c-include-path
+ (remove-if-not 'file-accessible-directory-p
+ (list "/usr/include" gcc-include)))
+ (setq c++-include-path
+ (remove-if-not 'file-accessible-directory-p
+ (list "/usr/include"
+ gcc-include
+ gcc-include-c++
+ gcc-include-c++-ver
+ gcc-include-c++-ver-host)))))
+
+ ;;; Fix-me: I think this part might have been a misunderstanding, but I am
not sure.
+ ;; If this option is specified, try it both with and without prefix, and
with and without host
+ ;; (if (assoc '--with-gxx-include-dir fields)
+ ;; (let ((gxx-include-dir (cdr (assoc '--with-gxx-include-dir
fields))))
+ ;; (nconc try-paths (list gxx-include-dir
+ ;; (concat prefix gxx-include-dir)
+ ;; (concat gxx-include-dir "/" host)
+ ;; (concat prefix gxx-include-dir "/"
host)))))
+
+ ;; Now setup include paths etc
+ (dolist (D (semantic-gcc-get-include-paths "c"))
+ (semantic-add-system-include D 'c-mode))
+ (dolist (D (semantic-gcc-get-include-paths "c++"))
+ (semantic-add-system-include D 'c++-mode)
+ (let ((cppconfig (concat D "/bits/c++config.h")))
+ ;; Presumably there will be only one of these files in the try-paths
list...
+ (when (file-readable-p cppconfig)
+ ;; Add it to the symbol file
+ (if (boundp 'semantic-lex-c-preprocessor-symbol-file)
+ ;; Add to the core macro header list
+ (add-to-list 'semantic-lex-c-preprocessor-symbol-file cppconfig)
+ ;; Setup the core macro header
+ (setq semantic-lex-c-preprocessor-symbol-file (list cppconfig)))
+ )))
+ (if (not (boundp 'semantic-lex-c-preprocessor-symbol-map))
+ (setq semantic-lex-c-preprocessor-symbol-map nil))
+ (dolist (D defines)
+ (add-to-list 'semantic-lex-c-preprocessor-symbol-map D))
+ (when (featurep 'semantic/bovine/c)
+ (semantic-c-reset-preprocessor-symbol-map))
+ nil))
+
+(provide 'semantic/bovine/gcc)
+
+;; Local variables:
+;; generated-autoload-file: "../loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/bovine/gcc"
+;; End:
+
+;;; semantic/bovine/gcc.el ends here
Index: cedet/semantic/bovine/make-by.el
===================================================================
RCS file: cedet/semantic/bovine/make-by.el
diff -N cedet/semantic/bovine/make-by.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/bovine/make-by.el 28 Sep 2009 15:15:10 -0000 1.2
@@ -0,0 +1,387 @@
+;;; semantic/bovine/make-by.el --- Generated parser support file
+
+;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2008
+;;; Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; This file was generated from the grammar file
+;; semantic/bovine/make.by in the CEDET repository.
+
+;;; Code:
+
+(require 'semantic/lex)
+(eval-when-compile (require 'semantic/bovine))
+
+
+;;; Prologue
+;;
+
+;;; Declarations
+;;
+(defconst semantic-make-by--keyword-table
+ (semantic-lex-make-keyword-table
+ '(("if" . IF)
+ ("ifdef" . IFDEF)
+ ("ifndef" . IFNDEF)
+ ("ifeq" . IFEQ)
+ ("ifneq" . IFNEQ)
+ ("else" . ELSE)
+ ("endif" . ENDIF)
+ ("include" . INCLUDE))
+ '(("include" summary "Macro: include filename1 filename2 ...")
+ ("ifneq" summary "Conditional: ifneq (expression) ... else ... endif")
+ ("ifeq" summary "Conditional: ifeq (expression) ... else ... endif")
+ ("ifndef" summary "Conditional: ifndef (expression) ... else ... endif")
+ ("ifdef" summary "Conditional: ifdef (expression) ... else ... endif")
+ ("endif" summary "Conditional: if (expression) ... else ... endif")
+ ("else" summary "Conditional: if (expression) ... else ... endif")
+ ("if" summary "Conditional: if (expression) ... else ... endif")))
+ "Table of language keywords.")
+
+(defconst semantic-make-by--token-table
+ (semantic-lex-make-type-table
+ '(("punctuation"
+ (BACKSLASH . "\\`[\\]\\'")
+ (DOLLAR . "\\`[$]\\'")
+ (EQUAL . "\\`[=]\\'")
+ (PLUS . "\\`[+]\\'")
+ (COLON . "\\`[:]\\'")))
+ 'nil)
+ "Table of lexical tokens.")
+
+(defconst semantic-make-by--parse-table
+ `(
+ (bovine-toplevel
+ (Makefile)
+ ) ;; end bovine-toplevel
+
+ (Makefile
+ (bol
+ newline
+ ,(semantic-lambda
+ (list nil))
+ )
+ (bol
+ variable
+ ,(semantic-lambda
+ (nth 1 vals))
+ )
+ (bol
+ rule
+ ,(semantic-lambda
+ (nth 1 vals))
+ )
+ (bol
+ conditional
+ ,(semantic-lambda
+ (nth 1 vals))
+ )
+ (bol
+ include
+ ,(semantic-lambda
+ (nth 1 vals))
+ )
+ (whitespace
+ ,(semantic-lambda
+ (list nil))
+ )
+ (newline
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end Makefile
+
+ (variable
+ (symbol
+ opt-whitespace
+ equals
+ opt-whitespace
+ element-list
+ ,(semantic-lambda
+ (semantic-tag-new-variable
+ (nth 0 vals) nil
+ (nth 4 vals)))
+ )
+ ) ;; end variable
+
+ (rule
+ (targets
+ opt-whitespace
+ colons
+ opt-whitespace
+ element-list
+ commands
+ ,(semantic-lambda
+ (semantic-tag-new-function
+ (nth 0 vals) nil
+ (nth 4 vals)))
+ )
+ ) ;; end rule
+
+ (targets
+ (target
+ opt-whitespace
+ targets
+ ,(semantic-lambda
+ (list
+ (car
+ (nth 0 vals))
+ (car
+ (nth 2 vals))))
+ )
+ (target
+ ,(semantic-lambda
+ (list
+ (car
+ (nth 0 vals))))
+ )
+ ) ;; end targets
+
+ (target
+ (sub-target
+ target
+ ,(semantic-lambda
+ (list
+ (concat
+ (car
+ (nth 0 vals))
+ (car
+ (nth 2 vals)))))
+ )
+ (sub-target
+ ,(semantic-lambda
+ (list
+ (car
+ (nth 0 vals))))
+ )
+ ) ;; end target
+
+ (sub-target
+ (symbol)
+ (string)
+ (varref)
+ ) ;; end sub-target
+
+ (conditional
+ (IF
+ some-whitespace
+ symbol
+ newline
+ ,(semantic-lambda
+ (list nil))
+ )
+ (IFDEF
+ some-whitespace
+ symbol
+ newline
+ ,(semantic-lambda
+ (list nil))
+ )
+ (IFNDEF
+ some-whitespace
+ symbol
+ newline
+ ,(semantic-lambda
+ (list nil))
+ )
+ (IFEQ
+ some-whitespace
+ expression
+ newline
+ ,(semantic-lambda
+ (list nil))
+ )
+ (IFNEQ
+ some-whitespace
+ expression
+ newline
+ ,(semantic-lambda
+ (list nil))
+ )
+ (ELSE
+ newline
+ ,(semantic-lambda
+ (list nil))
+ )
+ (ENDIF
+ newline
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end conditional
+
+ (expression
+ (semantic-list)
+ ) ;; end expression
+
+ (include
+ (INCLUDE
+ some-whitespace
+ element-list
+ ,(semantic-lambda
+ (semantic-tag-new-include
+ (nth 2 vals) nil))
+ )
+ ) ;; end include
+
+ (equals
+ (punctuation
+ "\\`[:]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda)
+ )
+ (punctuation
+ "\\`[+]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda)
+ )
+ (punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda)
+ )
+ ) ;; end equals
+
+ (colons
+ (punctuation
+ "\\`[:]\\'"
+ punctuation
+ "\\`[:]\\'"
+ ,(semantic-lambda)
+ )
+ (punctuation
+ "\\`[:]\\'"
+ ,(semantic-lambda)
+ )
+ ) ;; end colons
+
+ (element-list
+ (elements
+ newline
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ ) ;; end element-list
+
+ (elements
+ (element
+ some-whitespace
+ elements
+ ,(semantic-lambda
+ (nth 0 vals)
+ (nth 2 vals))
+ )
+ (element
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ ( ;;EMPTY
+ )
+ ) ;; end elements
+
+ (element
+ (sub-element
+ element
+ ,(semantic-lambda
+ (list
+ (concat
+ (car
+ (nth 0 vals))
+ (car
+ (nth 1 vals)))))
+ )
+ ( ;;EMPTY
+ )
+ ) ;; end element
+
+ (sub-element
+ (symbol)
+ (string)
+ (punctuation)
+ (semantic-list
+ ,(semantic-lambda
+ (list
+ (buffer-substring-no-properties
+ (identity start)
+ (identity end))))
+ )
+ ) ;; end sub-element
+
+ (varref
+ (punctuation
+ "\\`[$]\\'"
+ semantic-list
+ ,(semantic-lambda
+ (list
+ (buffer-substring-no-properties
+ (identity start)
+ (identity end))))
+ )
+ ) ;; end varref
+
+ (commands
+ (bol
+ shell-command
+ newline
+ commands
+ ,(semantic-lambda
+ (list
+ (nth 0 vals))
+ (nth 1 vals))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda)
+ )
+ ) ;; end commands
+
+ (opt-whitespace
+ (some-whitespace
+ ,(semantic-lambda
+ (list nil))
+ )
+ ( ;;EMPTY
+ )
+ ) ;; end opt-whitespace
+
+ (some-whitespace
+ (whitespace
+ some-whitespace
+ ,(semantic-lambda
+ (list nil))
+ )
+ (whitespace
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end some-whitespace
+ )
+ "Parser table.")
+
+(defun semantic-make-by--install-parser ()
+ "Setup the Semantic Parser."
+ (setq semantic--parse-table semantic-make-by--parse-table
+ semantic-debug-parser-source "make.by"
+ semantic-debug-parser-class 'semantic-bovine-debug-parser
+ semantic-flex-keywords-obarray semantic-make-by--keyword-table
+ ))
+
+(provide 'semantic/bovine/make-by)
+
+;;; semantic/bovine/make-by.el ends here
Index: cedet/semantic/bovine/make.el
===================================================================
RCS file: cedet/semantic/bovine/make.el
diff -N cedet/semantic/bovine/make.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/bovine/make.el 28 Sep 2009 15:15:10 -0000 1.2
@@ -0,0 +1,242 @@
+;;; semantic/bovine/make.el --- Makefile parsing rules.
+
+;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2008
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Use the Semantic Bovinator to parse Makefiles.
+;; Concocted as an experiment for nonstandard languages.
+
+(require 'make-mode)
+
+(require 'semantic)
+(require 'semantic/bovine/make-by)
+(require 'semantic/analyze)
+(require 'semantic/dep)
+
+(declare-function semantic-analyze-possible-completions-default
+ "semantic/analyze/complete")
+
+;;; Code:
+(define-lex-analyzer semantic-lex-make-backslash-no-newline
+ "Detect and create a beginning of line token (BOL)."
+ (and (looking-at "\\(\\\\\n\\s-*\\)")
+ ;; We have a \ at eol. Push it as whitespace, but pretend
+ ;; it never happened so we can skip the BOL tokenizer.
+ (semantic-lex-push-token (semantic-lex-token 'whitespace
+ (match-beginning 1)
+ (match-end 1)))
+ (goto-char (match-end 1))
+ nil) ;; CONTINUE
+ ;; We want to skip BOL, so move to the next condition.
+ nil)
+
+(define-lex-regex-analyzer semantic-lex-make-command
+ "A command in a Makefile consists of a line starting with TAB, and ending at
the newline."
+ "^\\(\t\\)"
+ (let ((start (match-end 0)))
+ (while (progn (end-of-line)
+ (save-excursion (forward-char -1) (looking-at "\\\\")))
+ (forward-char 1))
+ (semantic-lex-push-token
+ (semantic-lex-token 'shell-command start (point)))))
+
+(define-lex-regex-analyzer semantic-lex-make-ignore-automake-conditional
+ "An automake conditional seems to really bog down the parser.
+Ignore them."
+ "address@hidden(\\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
Index: cedet/semantic/bovine/scm-by.el
===================================================================
RCS file: cedet/semantic/bovine/scm-by.el
diff -N cedet/semantic/bovine/scm-by.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/bovine/scm-by.el 28 Sep 2009 15:15:10 -0000 1.2
@@ -0,0 +1,191 @@
+;;; semantic-scm-by.el --- Generated parser support file
+
+;; Copyright (C) 2001, 2003, 2009 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; This file was generated from the grammar file
+;; semantic/bovine/scm.by in the CEDET repository.
+
+;;; Code:
+
+(require 'semantic/lex)
+
+(eval-when-compile (require 'semantic/bovine))
+
+;;; Prologue
+;;
+
+;;; Declarations
+;;
+(defconst semantic-scm-by--keyword-table
+ (semantic-lex-make-keyword-table
+ '(("define" . DEFINE)
+ ("define-module" . DEFINE-MODULE)
+ ("load" . LOAD))
+ '(("load" summary "Function: (load \"filename\")")
+ ("define-module" summary "Function: (define-module (name arg1 ...)) ")
+ ("define" summary "Function: (define symbol expression)")))
+ "Table of language keywords.")
+
+(defconst semantic-scm-by--token-table
+ (semantic-lex-make-type-table
+ '(("close-paren"
+ (CLOSEPAREN . ")"))
+ ("open-paren"
+ (OPENPAREN . "(")))
+ 'nil)
+ "Table of lexical tokens.")
+
+(defconst semantic-scm-by--parse-table
+ `(
+ (bovine-toplevel
+ (scheme)
+ ) ;; end bovine-toplevel
+
+ (scheme
+ (semantic-list
+ ,(lambda (vals start end)
+ (semantic-bovinate-from-nonterminal
+ (car
+ (nth 0 vals))
+ (cdr
+ (nth 0 vals))
+ 'scheme-list))
+ )
+ ) ;; end scheme
+
+ (scheme-list
+ (open-paren
+ "("
+ scheme-in-list
+ close-paren
+ ")"
+ ,(semantic-lambda
+ (nth 1 vals))
+ )
+ ) ;; end scheme-list
+
+ (scheme-in-list
+ (DEFINE
+ symbol
+ expression
+ ,(semantic-lambda
+ (semantic-tag-new-variable
+ (nth 1 vals) nil
+ (nth 2 vals)))
+ )
+ (DEFINE
+ name-args
+ opt-doc
+ sequence
+ ,(semantic-lambda
+ (semantic-tag-new-function
+ (car
+ (nth 1 vals)) nil
+ (cdr
+ (nth 1 vals))))
+ )
+ (DEFINE-MODULE
+ name-args
+ ,(semantic-lambda
+ (semantic-tag-new-package
+ (nth
+ (length
+ (nth 1 vals))
+ (nth 1 vals)) nil))
+ )
+ (LOAD
+ string
+ ,(semantic-lambda
+ (semantic-tag-new-include
+ (file-name-nondirectory
+ (read
+ (nth 1 vals)))
+ (read
+ (nth 1 vals))))
+ )
+ (symbol
+ ,(semantic-lambda
+ (semantic-tag-new-code
+ (nth 0 vals) nil))
+ )
+ ) ;; end scheme-in-list
+
+ (name-args
+ (semantic-list
+ ,(lambda (vals start end)
+ (semantic-bovinate-from-nonterminal
+ (car
+ (nth 0 vals))
+ (cdr
+ (nth 0 vals))
+ 'name-arg-expand))
+ )
+ ) ;; end name-args
+
+ (name-arg-expand
+ (open-paren
+ name-arg-expand
+ ,(semantic-lambda
+ (nth 1 vals))
+ )
+ (symbol
+ name-arg-expand
+ ,(semantic-lambda
+ (cons
+ (nth 0 vals)
+ (nth 1 vals)))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda)
+ )
+ ) ;; end name-arg-expand
+
+ (opt-doc
+ (string)
+ ( ;;EMPTY
+ )
+ ) ;; end opt-doc
+
+ (sequence
+ (expression
+ sequence)
+ (expression)
+ ) ;; end sequence
+
+ (expression
+ (symbol)
+ (semantic-list)
+ (string)
+ (number)
+ ) ;; end expression
+ )
+ "Parser table.")
+
+(defun semantic-scm-by--install-parser ()
+ "Setup the Semantic Parser."
+ (setq semantic--parse-table semantic-scm-by--parse-table
+ semantic-debug-parser-source "scheme.by"
+ semantic-debug-parser-class 'semantic-bovine-debug-parser
+ semantic-flex-keywords-obarray semantic-scm-by--keyword-table
+ ))
+
+(provide 'semantic/bovine/scm-by)
+
+;;; semantic/bovine/scm-by.el ends here
Index: cedet/semantic/bovine/scm.el
===================================================================
RCS file: cedet/semantic/bovine/scm.el
diff -N cedet/semantic/bovine/scm.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/bovine/scm.el 28 Sep 2009 15:15:10 -0000 1.2
@@ -0,0 +1,119 @@
+;;; semantic/bovine/scm.el --- Semantic details for Scheme (guile)
+
+;;; Copyright (C) 2001, 2002, 2003, 2004, 2008, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Use the Semantic Bovinator for Scheme (guile)
+
+(require 'semantic)
+(require 'semantic/bovine/scm-by)
+(require 'semantic/format)
+(require 'semantic/dep)
+
+;;; Code:
+
+(defcustom-mode-local-semantic-dependency-system-include-path
+ scheme-mode semantic-default-scheme-path
+ '("/usr/share/guile/")
+ "Default set of include paths for scheme (guile) code.
+This should probably do some sort of search to see what is
+actually on the local machine.")
+
+(define-mode-local-override semantic-format-tag-prototype scheme-mode (tag)
+ "Return a prototype for the Emacs Lisp nonterminal TAG."
+ (let* ((tok (semantic-tag-class tag))
+ (args (semantic-tag-components tag))
+ )
+ (if (eq tok 'function)
+ (concat (semantic-tag-name tag) " ("
+ (mapconcat (lambda (a) a) args " ")
+ ")")
+ (semantic-format-tag-prototype-default tag))))
+
+(define-mode-local-override semantic-documentation-for-tag scheme-mode (tag
&optional nosnarf)
+ "Return the documentation string for TAG.
+Optional argument NOSNARF is ignored."
+ (let ((d (semantic-tag-docstring tag)))
+ (if (and d (> (length d) 0) (= (aref d 0) ?*))
+ (substring d 1)
+ d)))
+
+(define-mode-local-override semantic-insert-foreign-tag scheme-mode (tag
tagfile)
+ "Insert TAG from TAGFILE at point.
+Attempts a simple prototype for calling or using TAG."
+ (cond ((eq (semantic-tag-class tag) 'function)
+ (insert "(" (semantic-tag-name tag) " )")
+ (forward-char -1))
+ (t
+ (insert (semantic-tag-name tag)))))
+
+;; Note: Analyzer from Henry S. Thompson
+(define-lex-regex-analyzer semantic-lex-scheme-symbol
+ "Detect and create symbol and keyword tokens."
+ "\\(\\sw\\([:]\\|\\sw\\|\\s_\\)+\\)"
+ ;; (message (format "symbol: %s" (match-string 0)))
+ (semantic-lex-push-token
+ (semantic-lex-token
+ (or (semantic-lex-keyword-p (match-string 0)) 'symbol)
+ (match-beginning 0) (match-end 0))))
+
+
+(define-lex semantic-scheme-lexer
+ "A simple lexical analyzer that handles simple buffers.
+This lexer ignores comments and whitespace, and will return
+syntax as specified by the syntax table."
+ semantic-lex-ignore-whitespace
+ semantic-lex-ignore-newline
+ semantic-lex-scheme-symbol
+ semantic-lex-charquote
+ semantic-lex-paren-or-list
+ semantic-lex-close-paren
+ semantic-lex-string
+ semantic-lex-ignore-comments
+ semantic-lex-punctuation
+ semantic-lex-number
+ semantic-lex-default-action)
+
+;;;###autoload
+(defun semantic-default-scheme-setup ()
+ "Setup hook function for Emacs Lisp files and Semantic."
+ (semantic-scm-by--install-parser)
+ (setq semantic-symbol->name-assoc-list '( (variable . "Variables")
+ ;;(type . "Types")
+ (function . "Functions")
+ (include . "Loads")
+ (package . "DefineModule"))
+ imenu-create-index-function 'semantic-create-imenu-index
+ imenu-create-index-function 'semantic-create-imenu-index
+ )
+ (setq semantic-lex-analyzer #'semantic-scheme-lexer)
+ )
+
+(provide 'semantic/bovine/scm)
+
+;; Local variables:
+;; generated-autoload-file: "../loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/bovine/scm"
+;; End:
+
+;;; semantic/bovine/scm.el ends here
Index: cedet/semantic/decorate/include.el
===================================================================
RCS file: cedet/semantic/decorate/include.el
diff -N cedet/semantic/decorate/include.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/decorate/include.el 28 Sep 2009 15:15:10 -0000 1.2
@@ -0,0 +1,774 @@
+;;; semantic/decorate/include.el --- Decoration modes for include statements
+
+;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Highlight any include that is in a state the user may care about.
+;; The basic idea is to have the state be highly visible so users will
+;; as 'what is this?" and get the info they need to fix problems that
+;; are otherwises transparent when trying to get smart completion
+;; working.
+
+(require 'semantic/decorate/mode)
+(require 'semantic/db)
+(require 'semantic/db-ref)
+(require 'semantic/db-find)
+
+(eval-when-compile
+ (require 'semantic/find))
+
+(defvar semantic-dependency-system-include-path)
+(declare-function ede-get-locator-object "ede/files")
+(declare-function ede-system-include-path "ede/cpp-root")
+
+;;; Code:
+
+;;; FACES AND KEYMAPS
+(defvar semantic-decoratiton-mouse-3 (if (featurep 'xemacs) [ button3 ] [
mouse-3 ])
+ "The keybinding lisp object to use for binding the right mouse button.")
+
+;;; Includes that that are in a happy state!
+;;
+(defface semantic-decoration-on-includes
+ nil
+ "*Overlay Face used on includes that are not in some other state.
+Used by the decoration style: `semantic-decoration-on-includes'."
+ :group 'semantic-faces)
+
+(defvar semantic-decoration-on-include-map
+ (let ((km (make-sparse-keymap)))
+ (define-key km semantic-decoratiton-mouse-3
'semantic-decoration-include-menu)
+ km)
+ "Keymap used on includes.")
+
+
+(defvar semantic-decoration-on-include-menu nil
+ "Menu used for include headers.")
+
+(easy-menu-define
+ semantic-decoration-on-include-menu
+ semantic-decoration-on-include-map
+ "Include Menu"
+ (list
+ "Include"
+ (semantic-menu-item
+ ["What Is This?" semantic-decoration-include-describe
+ :active t
+ :help "Describe why this include has been marked this way." ])
+ (semantic-menu-item
+ ["Visit This Include" semantic-decoration-include-visit
+ :active t
+ :help "Visit this include file." ])
+ "---"
+ (semantic-menu-item
+ ["Summarize includes current buffer"
semantic-decoration-all-include-summary
+ :active t
+ :help "Show a summary for the current buffer containing this include." ])
+ (semantic-menu-item
+ ["List found includes (load unparsed)" semanticdb-find-test-translate-path
+ :active t
+ :help "List all includes found for this file, and parse unparsed files."
])
+ (semantic-menu-item
+ ["List found includes (no loading)"
semanticdb-find-test-translate-path-no-loading
+ :active t
+ :help "List all includes found for this file, do not parse unparsed
files." ])
+ (semantic-menu-item
+ ["List all unknown includes" semanticdb-find-adebug-lost-includes
+ :active t
+ :help "Show a list of all includes semantic cannot find for this file." ])
+ "---"
+ (semantic-menu-item
+ ["Customize System Include Path" semantic-customize-system-include-path
+ :active (get 'semantic-dependency-system-include-path major-mode)
+ :help "Run customize for the system include path for this major mode." ])
+ (semantic-menu-item
+ ["Add a System Include Path" semantic-add-system-include
+ :active t
+ :help "Add an include path for this session." ])
+ (semantic-menu-item
+ ["Remove a System Include Path" semantic-remove-system-include
+ :active t
+ :help "Add an include path for this session." ])
+ ;;["" semantic-decoration-include-
+ ;; :active t
+ ;; :help "" ]
+ ))
+
+;;; Unknown Includes!
+;;
+(defface semantic-decoration-on-unknown-includes
+ '((((class color) (background dark))
+ (:background "#900000"))
+ (((class color) (background light))
+ (:background "#ff5050")))
+ "*Face used to show includes that cannot be found.
+Used by the decoration style: `semantic-decoration-on-unknown-includes'."
+ :group 'semantic-faces)
+
+(defvar semantic-decoration-on-unknown-include-map
+ (let ((km (make-sparse-keymap)))
+ ;(define-key km [ mouse-2 ] 'semantic-decoration-unknown-include-describe)
+ (define-key km semantic-decoratiton-mouse-3
'semantic-decoration-unknown-include-menu)
+ km)
+ "Keymap used on unparsed includes.")
+
+(defvar semantic-decoration-on-unknown-include-menu nil
+ "Menu used for unparsed include headers.")
+
+(easy-menu-define
+ semantic-decoration-on-unknown-include-menu
+ semantic-decoration-on-unknown-include-map
+ "Unknown Include Menu"
+ (list
+ "Unknown Include"
+ (semantic-menu-item
+ ["What Is This?" semantic-decoration-unknown-include-describe
+ :active t
+ :help "Describe why this include has been marked this way." ])
+ (semantic-menu-item
+ ["List all unknown includes" semanticdb-find-adebug-lost-includes
+ :active t
+ :help "Show a list of all includes semantic cannot find for this file." ])
+ "---"
+ (semantic-menu-item
+ ["Summarize includes current buffer"
semantic-decoration-all-include-summary
+ :active t
+ :help "Show a summary for the current buffer containing this include." ])
+ (semantic-menu-item
+ ["List found includes (load unparsed)" semanticdb-find-test-translate-path
+ :active t
+ :help "List all includes found for this file, and parse unparsed files."
])
+ (semantic-menu-item
+ ["List found includes (no loading)"
semanticdb-find-test-translate-path-no-loading
+ :active t
+ :help "List all includes found for this file, do not parse unparsed
files." ])
+ "---"
+ (semantic-menu-item
+ ["Customize System Include Path" semantic-customize-system-include-path
+ :active (get 'semantic-dependency-system-include-path major-mode)
+ :help "Run customize for the system include path for this major mode." ])
+ (semantic-menu-item
+ ["Add a System Include Path" semantic-add-system-include
+ :active t
+ :help "Add an include path for this session." ])
+ (semantic-menu-item
+ ["Remove a System Include Path" semantic-remove-system-include
+ :active t
+ :help "Add an include path for this session." ])
+ ))
+
+;;; Includes that need to be parsed.
+;;
+(defface semantic-decoration-on-unparsed-includes
+ '((((class color) (background dark))
+ (:background "#555500"))
+ (((class color) (background light))
+ (:background "#ffff55")))
+ "*Face used to show includes that have not yet been parsed.
+Used by the decoration style: `semantic-decoration-on-unparsed-includes'."
+ :group 'semantic-faces)
+
+(defvar semantic-decoration-on-unparsed-include-map
+ (let ((km (make-sparse-keymap)))
+ (define-key km semantic-decoratiton-mouse-3
'semantic-decoration-unparsed-include-menu)
+ km)
+ "Keymap used on unparsed includes.")
+
+
+(defvar semantic-decoration-on-unparsed-include-menu nil
+ "Menu used for unparsed include headers.")
+
+(easy-menu-define
+ semantic-decoration-on-unparsed-include-menu
+ semantic-decoration-on-unparsed-include-map
+ "Unparsed Include Menu"
+ (list
+ "Unparsed Include"
+ (semantic-menu-item
+ ["What Is This?" semantic-decoration-unparsed-include-describe
+ :active t
+ :help "Describe why this include has been marked this way." ])
+ (semantic-menu-item
+ ["Visit This Include" semantic-decoration-include-visit
+ :active t
+ :help "Visit this include file so that header file's tags can be used." ])
+ (semantic-menu-item
+ ["Parse This Include" semantic-decoration-unparsed-include-parse-include
+ :active t
+ :help "Parse this include file so that header file's tags can be used." ])
+ (semantic-menu-item
+ ["Parse All Includes"
semantic-decoration-unparsed-include-parse-all-includes
+ :active t
+ :help "Parse all the includes so the contents can be used." ])
+ "---"
+ (semantic-menu-item
+ ["Summarize includes current buffer"
semantic-decoration-all-include-summary
+ :active t
+ :help "Show a summary for the current buffer containing this include." ])
+ (semantic-menu-item
+ ["List found includes (load unparsed)" semanticdb-find-test-translate-path
+ :active t
+ :help "List all includes found for this file, and parse unparsed files."
])
+ (semantic-menu-item
+ ["List found includes (no loading)"
semanticdb-find-test-translate-path-no-loading
+ :active t
+ :help "List all includes found for this file, do not parse unparsed
files." ])
+ (semantic-menu-item
+ ["List all unknown includes" semanticdb-find-adebug-lost-includes
+ :active t
+ :help "Show a list of all includes semantic cannot find for this file." ])
+ "---"
+ (semantic-menu-item
+ ["Customize System Include Path" semantic-customize-system-include-path
+ :active (get 'semantic-dependency-system-include-path major-mode)
+ :help "Run customize for the system include path for this major mode." ])
+ (semantic-menu-item
+ ["Add a System Include Path" semantic-add-system-include
+ :active t
+ :help "Add an include path for this session." ])
+ (semantic-menu-item
+ ["Remove a System Include Path" semantic-remove-system-include
+ :active t
+ :help "Add an include path for this session." ])
+ ;;["" semantic-decoration-unparsed-include-
+ ;; :active t
+ ;; :help "" ]
+ ))
+
+
+;;; MODES
+
+;;; Include statement Decorate Mode
+;;
+;; This mode handles the three states of an include statements
+;;
+(define-semantic-decoration-style semantic-decoration-on-includes
+ "Highlight class members that are includes.
+This mode provides a nice context menu on the include statements."
+ :enabled t)
+
+(defun semantic-decoration-on-includes-p-default (tag)
+ "Return non-nil if TAG has is an includes that can't be found."
+ (semantic-tag-of-class-p tag 'include))
+
+(defun semantic-decoration-on-includes-highlight-default (tag)
+ "Highlight the include TAG to show that semantic can't find it."
+ (let* ((file (semantic-dependency-tag-file tag))
+ (table (when file
+ (semanticdb-file-table-object file t)))
+ (face nil)
+ (map nil)
+ )
+ (cond
+ ((not file)
+ ;; Cannot find this header.
+ (setq face 'semantic-decoration-on-unknown-includes
+ map semantic-decoration-on-unknown-include-map)
+ )
+ ((and table (number-or-marker-p (oref table pointmax)))
+ ;; A found and parsed file.
+ (setq face 'semantic-decoration-on-includes
+ map semantic-decoration-on-include-map)
+ )
+ (t
+ ;; An unparsed file.
+ (setq face 'semantic-decoration-on-unparsed-includes
+ map semantic-decoration-on-unparsed-include-map)
+ (when table
+ ;; Set ourselves up for synchronization
+ (semanticdb-cache-get
+ table 'semantic-decoration-unparsed-include-cache)
+ ;; Add a dependancy.
+ (let ((table semanticdb-current-table))
+ (semanticdb-add-reference table tag))
+ )
+ ))
+
+ (let ((ol (semantic-decorate-tag tag
+ (semantic-tag-start tag)
+ (semantic-tag-end tag)
+ face))
+ )
+ (semantic-overlay-put ol 'mouse-face 'highlight)
+ (semantic-overlay-put ol 'keymap map)
+ (semantic-overlay-put ol 'help-echo
+ "Header File : mouse-3 - Context menu")
+ )))
+
+;;; Regular Include Functions
+;;
+(defun semantic-decoration-include-describe ()
+ "Describe what unparsed includes are in the current buffer.
+Argument EVENT is the mouse clicked event."
+ (interactive)
+ (let* ((tag (or (semantic-current-tag)
+ (error "No tag under point")))
+ (file (semantic-dependency-tag-file tag))
+ (table (when file
+ (semanticdb-file-table-object file t))))
+ (with-output-to-temp-buffer (help-buffer) ; "*Help*"
+ (help-setup-xref (list #'semantic-decoration-include-describe)
+ (interactive-p))
+ (princ "Include File: ")
+ (princ (semantic-format-tag-name tag nil t))
+ (princ "\n")
+ (princ "This include file was found at:\n ")
+ (princ (semantic-dependency-tag-file tag))
+ (princ "\n\n")
+ (princ "Semantic knows where this include file is, and has parsed
+its contents.
+
+")
+ (let ((inc (semantic-find-tags-by-class 'include table))
+ (ok 0)
+ (unknown 0)
+ (unparsed 0)
+ (all 0))
+ (dolist (i inc)
+ (let* ((fileinner (semantic-dependency-tag-file i))
+ )
+ (cond ((not fileinner)
+ (setq unknown (1+ unknown)))
+ ((number-or-marker-p (oref table pointmax))
+ (setq ok (1+ ok)))
+ (t
+ (setq unparsed (1+ unparsed))))))
+ (setq all (+ ok unknown unparsed))
+ (if (= 0 all)
+ (princ "There are no other includes in this file.\n")
+ (princ (format "There are %d more includes in this file.\n"
+ all))
+ (princ (format " Unknown Includes: %d\n" unknown))
+ (princ (format " Unparsed Includes: %d\n" unparsed))
+ (princ (format " Parsed Includes: %d\n" ok)))
+ )
+ ;; Get the semanticdb statement, and display it's contents.
+ (princ "\nDetails for header file...\n")
+ (princ "\nMajor Mode: ")
+ (princ (oref table :major-mode))
+ (princ "\nTags: ")
+ (princ (format "%s entries" (length (oref table :tags))))
+ (princ "\nFile Size: ")
+ (princ (format "%s chars" (oref table :pointmax)))
+ (princ "\nSave State: ")
+ (cond ((oref table dirty)
+ (princ "Table needs to be saved."))
+ (t
+ (princ "Table is saved on disk."))
+ )
+ (princ "\nExternal References:")
+ (dolist (r (oref table db-refs))
+ (princ "\n ")
+ (princ (oref r file)))
+ )))
+
+;;;###autoload
+(defun semantic-decoration-include-visit ()
+ "Visit the included file at point."
+ (interactive)
+ (let ((tag (semantic-current-tag)))
+ (unless (eq (semantic-tag-class tag) 'include)
+ (error "Point is not on an include tag"))
+ (let ((file (semantic-dependency-tag-file tag)))
+ (cond
+ ((or (not file) (not (file-exists-p file)))
+ (error "Could not location include %s"
+ (semantic-tag-name tag)))
+ ((get-file-buffer file)
+ (switch-to-buffer (get-file-buffer file)))
+ ((stringp file)
+ (find-file file))
+ ))))
+
+(defun semantic-decoration-include-menu (event)
+ "Popup a menu that can help a user understand unparsed includes.
+Argument EVENT describes the event that caused this function to be called."
+ (interactive "e")
+ (let* ((startwin (selected-window))
+ (win (semantic-event-window event))
+ )
+ (select-window win t)
+ (save-excursion
+ ;(goto-char (window-start win))
+ (mouse-set-point event)
+ (sit-for 0)
+ (semantic-popup-menu semantic-decoration-on-include-menu)
+ )
+ (select-window startwin)))
+
+
+;;; Unknown Include functions
+;;
+(defun semantic-decoration-unknown-include-describe ()
+ "Describe what unknown includes are in the current buffer.
+Argument EVENT is the mouse clicked event."
+ (interactive)
+ (let ((tag (semantic-current-tag))
+ (mm major-mode))
+ (with-output-to-temp-buffer (help-buffer) ; "*Help*"
+ (help-setup-xref (list #'semantic-decoration-unknown-include-describe)
+ (interactive-p))
+ (princ "Include File: ")
+ (princ (semantic-format-tag-name tag nil t))
+ (princ "\n\n")
+ (princ "This header file has been marked \"Unknown\".
+This means that Semantic has not been able to locate this file on disk.
+
+When Semantic cannot find an include file, this means that the
+idle summary mode and idle completion modes cannot use the contents of
+that file to provide coding assistance.
+
+If this is a system header and you want it excluded from Semantic's
+searches (which may be desirable for speed reasons) then you can
+safely ignore this state.
+
+If this is a system header, and you want to include it in Semantic's
+searches, then you will need to use:
+
+M-x semantic-add-system-include RET /path/to/includes RET
+
+or, in your .emacs file do:
+
+ (semantic-add-system-include \"/path/to/include\" '")
+ (princ (symbol-name mm))
+ (princ ")
+
+to add the path to Semantic's search.
+
+If this is an include file that belongs to your project, then you may
+need to update `semanticdb-project-roots' or better yet, use `ede'
+to manage your project. See the ede manual for projects that will
+wrap existing project code for Semantic's benifit.
+")
+
+ (when (or (eq mm 'c++-mode) (eq mm 'c-mode))
+ (princ "
+For C/C++ includes located within a a project, you can use a special
+EDE project that will wrap an existing build system. You can do that
+like this in your .emacs file:
+
+ (ede-cpp-root-project \"NAME\" :file \"FILENAME\" :locate-fcn 'MYFCN)
+
+See the CEDET manual, the EDE manual, or the commentary in
+ede-cpp-root.el for more.
+
+If you think this header tag is marked in error, you may need to do:
+
+C-u M-x bovinate RET
+
+to refresh the tags in this buffer, and recalculate the state."))
+
+ (princ "
+See the Semantic manual node on SemanticDB for more about search paths.")
+ )))
+
+(defun semantic-decoration-unknown-include-menu (event)
+ "Popup a menu that can help a user understand unparsed includes.
+Argument EVENT describes the event that caused this function to be called."
+ (interactive "e")
+ (let* ((startwin (selected-window))
+ ;; This line has an issue in XEmacs.
+ (win (semantic-event-window event))
+ )
+ (select-window win t)
+ (save-excursion
+ ;(goto-char (window-start win))
+ (mouse-set-point event)
+ (sit-for 0)
+ (semantic-popup-menu semantic-decoration-on-unknown-include-menu)
+ )
+ (select-window startwin)))
+
+
+;;; Interactive parts of unparsed includes
+;;
+(defun semantic-decoration-unparsed-include-describe ()
+ "Describe what unparsed includes are in the current buffer.
+Argument EVENT is the mouse clicked event."
+ (interactive)
+ (let ((tag (semantic-current-tag)))
+ (with-output-to-temp-buffer (help-buffer); "*Help*"
+ (help-setup-xref (list #'semantic-decoration-unparsed-include-describe)
+ (interactive-p))
+
+ (princ "Include File: ")
+ (princ (semantic-format-tag-name tag nil t))
+ (princ "\n")
+ (princ "This include file was found at:\n ")
+ (princ (semantic-dependency-tag-file tag))
+ (princ "\n\n")
+ (princ "This header file has been marked \"Unparsed\".
+This means that Semantic has located this header file on disk
+but has not yet opened and parsed this file.
+
+So long as this header file is unparsed, idle summary and
+idle completion will not be able to reference the details in this
+header.
+
+To resolve this, use the context menu to parse this include file,
+or all include files referred to in ")
+ (princ (buffer-name))
+ (princ ".
+This can take a while in large projects.
+
+Alternately, you can call:
+
+M-x semanticdb-find-test-translate-path RET
+
+to search path Semantic uses to perform completion.
+
+
+If you think this header tag is marked in error, you may need to do:
+
+C-u M-x bovinate RET
+
+to refresh the tags in this buffer, and recalculate the state.
+If you find a repeatable case where a header is marked in error,
+report it to address@hidden") )))
+
+
+(defun semantic-decoration-unparsed-include-menu (event)
+ "Popup a menu that can help a user understand unparsed includes.
+Argument EVENT describes the event that caused this function to be called."
+ (interactive "e")
+ (let* ((startwin (selected-window))
+ (win (semantic-event-window event))
+ )
+ (select-window win t)
+ (save-excursion
+ ;(goto-char (window-start win))
+ (mouse-set-point event)
+ (sit-for 0)
+ (semantic-popup-menu semantic-decoration-on-unparsed-include-menu)
+ )
+ (select-window startwin)))
+
+(defun semantic-decoration-unparsed-include-parse-include ()
+ "Parse the include file the user menu-selected from."
+ (interactive)
+ (let* ((file (semantic-dependency-tag-file (semantic-current-tag))))
+ (semanticdb-file-table-object file)
+ (semantic-decoration-unparsed-include-do-reset)))
+
+
+(defun semantic-decoration-unparsed-include-parse-all-includes ()
+ "Parse the include file the user menu-selected from."
+ (interactive)
+ (semanticdb-find-translate-path nil nil)
+ )
+
+
+;;; General Includes Information
+;;
+(defun semantic-decoration-all-include-summary ()
+ "Provide a general summary for the state of all includes."
+ (interactive)
+ (require 'semantic/dep)
+ (let* ((table semanticdb-current-table)
+ (tags (semantic-fetch-tags))
+ (inc (semantic-find-tags-by-class 'include table))
+ )
+ (with-output-to-temp-buffer (help-buffer) ;"*Help*"
+ (help-setup-xref (list #'semantic-decoration-all-include-summary)
+ (interactive-p))
+
+ (princ "Include Summary for File: ")
+ (princ (file-truename (buffer-file-name)))
+ (princ "\n")
+
+ (when (oref table db-refs)
+ (princ "\nExternal Database References to this buffer:")
+ (dolist (r (oref table db-refs))
+ (princ "\n ")
+ (princ (oref r file)))
+ )
+
+ (princ (format "\nThis file contains %d tags, %d of which are
includes.\n"
+ (length tags) (length inc)))
+ (let ((ok 0)
+ (unknown 0)
+ (unparsed 0)
+ (all 0))
+ (dolist (i inc)
+ (let* ((fileinner (semantic-dependency-tag-file i))
+ (tableinner (when fileinner
+ (semanticdb-file-table-object fileinner t))))
+ (cond ((not fileinner)
+ (setq unknown (1+ unknown)))
+ ((number-or-marker-p (oref tableinner pointmax))
+ (setq ok (1+ ok)))
+ (t
+ (setq unparsed (1+ unparsed))))))
+ (setq all (+ ok unknown unparsed))
+ (when (not (= 0 all))
+ (princ (format " Unknown Includes: %d\n" unknown))
+ (princ (format " Unparsed Includes: %d\n" unparsed))
+ (princ (format " Parsed Includes: %d\n" ok)))
+ )
+
+ (princ "\nInclude Path Summary:\n\n")
+ (when (and (boundp 'ede-object)
+ (boundp 'ede-object-project)
+ ede-object)
+ (princ " This file's project include search is handled by the EDE
object:\n")
+ (princ " Buffer Target: ")
+ (princ (object-print ede-object))
+ (princ "\n")
+ (when (not (eq ede-object ede-object-project))
+ (princ " Buffer Project: ")
+ (princ (object-print ede-object-project))
+ (princ "\n")
+ )
+ (when ede-object-project
+ (let ((loc (ede-get-locator-object ede-object-project)))
+ (princ " Backup in-project Locator: ")
+ (princ (object-print loc))
+ (princ "\n")))
+ (let ((syspath (ede-system-include-path ede-object-project)))
+ (if (not syspath)
+ (princ " EDE Project system include path: Empty\n")
+ (princ " EDE Project system include path:\n")
+ (dolist (dir syspath)
+ (princ " ")
+ (princ dir)
+ (princ "\n"))
+ )))
+
+ (princ "\n This file's system include path is:\n")
+ (dolist (dir semantic-dependency-system-include-path)
+ (princ " ")
+ (princ dir)
+ (princ "\n"))
+
+ (let ((unk semanticdb-find-lost-includes))
+ (when unk
+ (princ "\nAll unknown includes:\n")
+ (dolist (tag unk)
+ (princ " ")
+ (princ (semantic-tag-name tag))
+ (princ "\n"))
+ ))
+
+ (let* ((semanticdb-find-default-throttle
+ (if (featurep 'semantic/db-find)
+ (remq 'unloaded semanticdb-find-default-throttle)
+ nil))
+ (path (semanticdb-find-translate-path nil nil)))
+ (if (<= (length path) (length inc))
+ (princ "\nThere are currently no includes found recursively.\n")
+ ;; List the full include list.
+ (princ "\nSummary of all includes needed by ")
+ (princ (buffer-name))
+ (dolist (p path)
+ (if (slot-boundp p 'tags)
+ (princ (format "\n %s :\t%d tags, %d are includes. %s"
+ (object-name-string p)
+ (length (oref p tags))
+ (length (semantic-find-tags-by-class
+ 'include p))
+ (cond
+ ((condition-case nil
+ (oref p dirty)
+ (error nil))
+ " dirty.")
+ ((not (number-or-marker-p (oref table
pointmax)))
+ " Needs to be parsed.")
+ (t ""))))
+ (princ (format "\n %s :\tUnparsed"
+ (object-name-string p))))
+ )))
+ )))
+
+
+;;; Unparsed Include Features
+;;
+;; This section handles changing states of unparsed include
+;; decorations base on what happens in other files.
+;;
+
+(defclass semantic-decoration-unparsed-include-cache
(semanticdb-abstract-cache)
+ ()
+ "Class used to reset decorated includes.
+When an include's referring file is parsed, we need to undecorate
+any decorated referring includes.")
+
+
+(defmethod semantic-reset ((obj semantic-decoration-unparsed-include-cache))
+ "Reset OBJ back to it's empty settings."
+ (let ((table (oref obj table)))
+ ;; This is a hack. Add in something better?
+ (semanticdb-notify-references
+ table (lambda (tab me)
+ (semantic-decoration-unparsed-include-refrence-reset tab)
+ ))
+ ))
+
+(defmethod semanticdb-partial-synchronize ((cache
semantic-decoration-unparsed-include-cache)
+ new-tags)
+ "Synchronize CACHE with some NEW-TAGS."
+ (if (semantic-find-tags-by-class 'include new-tags)
+ (semantic-reset cache)))
+
+(defmethod semanticdb-synchronize ((cache
semantic-decoration-unparsed-include-cache)
+ new-tags)
+ "Synchronize a CACHE with some NEW-TAGS."
+ (semantic-reset cache))
+
+(defun semantic-decoration-unparsed-include-refrence-reset (table)
+ "Refresh any highlighting in buffers referred to by TABLE.
+If TABLE is not in a buffer, do nothing."
+ ;; This cache removal may seem odd in that we are "creating one", but
+ ;; since we cant get in the fcn unless one exists, this ought to be
+ ;; ok.
+ (let ((c (semanticdb-cache-get
+ table 'semantic-decoration-unparsed-include-cache)))
+ (semanticdb-cache-remove table c))
+
+ (let ((buf (semanticdb-in-buffer-p table)))
+ (when buf
+ (semantic-decorate-add-pending-decoration
+ 'semantic-decoration-unparsed-include-do-reset
+ buf)
+ )))
+
+;;;###autoload
+(defun semantic-decoration-unparsed-include-do-reset ()
+ "Do a reset of unparsed includes in the current buffer."
+ (let* ((style (assoc "semantic-decoration-on-includes"
+ semantic-decoration-styles)))
+ (when (cdr style)
+ (let ((allinc (semantic-find-tags-included
+ (semantic-fetch-tags-fast))))
+ ;; This will do everything, but it should be speedy since it
+ ;; would have been done once already.
+ (semantic-decorate-add-decorations allinc)
+ ))))
+
+
+(provide 'semantic/decorate/include)
+
+;; Local variables:
+;; generated-autoload-file: "../loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/decorate/include"
+;; End:
+
+;;; semantic/decorate/include.el ends here
Index: cedet/semantic/decorate/mode.el
===================================================================
RCS file: cedet/semantic/decorate/mode.el
diff -N cedet/semantic/decorate/mode.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/decorate/mode.el 28 Sep 2009 15:15:10 -0000 1.2
@@ -0,0 +1,567 @@
+;;; semantic/decorate/mode.el --- Minor mode for decorating tags
+
+;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; A minor mode for use in decorating tags.
+;;
+;; There are two types of decorations that can be performed on a tag.
+;; You can either highlight the full tag, or you can add an
+;; independent decoration on some part of the tag body.
+;;
+;; For independent decoration in particular, managing them so that they
+;; do not get corrupted is challenging. This major mode and
+;; corresponding macros will make handling those types of decorations
+;; easier.
+;;
+
+;;; Code:
+(require 'semantic)
+(require 'semantic/decorate)
+(require 'semantic/tag-ls)
+(require 'semantic/util-modes)
+
+;;; Styles List
+;;
+(defcustom semantic-decoration-styles nil
+ "List of active decoration styles.
+It is an alist of \(NAME . FLAG) elements, where NAME is a style name
+and FLAG is non-nil if the style is enabled.
+See also `define-semantic-decoration-style' which will automatically
+add items to this list."
+ :group 'semantic
+ :type '(repeat (cons (string :tag "Decoration Name")
+ (boolean :tag "Enabled")))
+ )
+
+;;; Misc.
+;;
+(defsubst semantic-decorate-style-predicate (style)
+ "Return the STYLE's predicate function."
+ (intern (format "%s-p" style)))
+
+(defsubst semantic-decorate-style-highlighter (style)
+ "Return the STYLE's highlighter function."
+ (intern (format "%s-highlight" style)))
+
+;;; Base decoration API
+;;
+(defsubst semantic-decoration-p (object)
+ "Return non-nil if OBJECT is a tag decoration."
+ (and (semantic-overlay-p object)
+ (semantic-overlay-get object 'semantic-decoration)))
+
+(defsubst semantic-decoration-set-property (deco property value)
+ "Set the DECO decoration's PROPERTY to VALUE.
+Return DECO."
+ (assert (semantic-decoration-p deco))
+ (semantic-overlay-put deco property value)
+ deco)
+
+(defsubst semantic-decoration-get-property (deco property)
+ "Return the DECO decoration's PROPERTY value."
+ (assert (semantic-decoration-p deco))
+ (semantic-overlay-get deco property))
+
+(defsubst semantic-decoration-set-face (deco face)
+ "Set the face of the decoration DECO to FACE.
+Return DECO."
+ (semantic-decoration-set-property deco 'face face))
+
+(defsubst semantic-decoration-face (deco)
+ "Return the face of the decoration DECO."
+ (semantic-decoration-get-property deco 'face))
+
+(defsubst semantic-decoration-set-priority (deco priority)
+ "Set the priority of the decoration DECO to PRIORITY.
+Return DECO."
+ (assert (natnump priority))
+ (semantic-decoration-set-property deco 'priority priority))
+
+(defsubst semantic-decoration-priority (deco)
+ "Return the priority of the decoration DECO."
+ (semantic-decoration-get-property deco 'priority))
+
+(defsubst semantic-decoration-move (deco begin end)
+ "Move the decoration DECO on the region between BEGIN and END.
+Return DECO."
+ (assert (semantic-decoration-p deco))
+ (semantic-overlay-move deco begin end)
+ deco)
+
+;;; Tag decoration
+;;
+(defun semantic-decorate-tag (tag begin end &optional face)
+ "Add a new decoration on TAG on the region between BEGIN and END.
+If optional argument FACE is non-nil, set the decoration's face to
+FACE.
+Return the overlay that makes up the new decoration."
+ (let ((deco (semantic-tag-create-secondary-overlay tag)))
+ ;; We do not use the unlink property because we do not want to
+ ;; save the highlighting information in the DB.
+ (semantic-overlay-put deco 'semantic-decoration t)
+ (semantic-decoration-move deco begin end)
+ (semantic-decoration-set-face deco face)
+ deco))
+
+(defun semantic-decorate-clear-tag (tag &optional deco)
+ "Remove decorations from TAG.
+If optional argument DECO is non-nil, remove only that decoration."
+ (assert (or (null deco) (semantic-decoration-p deco)))
+ ;; Clear primary decorations.
+ ;; For now, just unhighlight the tag. How to deal with other
+ ;; primary decorations like invisibility, etc. ? Maybe just
+ ;; restoring default values will suffice?
+ (semantic-unhighlight-tag tag)
+ (semantic-tag-delete-secondary-overlay
+ tag (or deco 'semantic-decoration)))
+
+(defun semantic-decorate-tag-decoration (tag)
+ "Return decoration found on TAG."
+ (semantic-tag-get-secondary-overlay tag 'semantic-decoration))
+
+;;; Global setup of active decorations
+;;
+(defun semantic-decorate-flush-decorations (&optional buffer)
+ "Flush decorations found in BUFFER.
+BUFFER defaults to the current buffer.
+Should be used to flush decorations that might remain in BUFFER, for
+example, after tags have been refreshed."
+ (with-current-buffer (or buffer (current-buffer))
+ (dolist (o (semantic-overlays-in (point-min) (point-max)))
+ (and (semantic-decoration-p o)
+ (semantic-overlay-delete o)))))
+
+(defun semantic-decorate-clear-decorations (tag-list)
+ "Remove decorations found in tags in TAG-LIST."
+ (dolist (tag tag-list)
+ (semantic-decorate-clear-tag tag)
+ ;; recurse over children
+ (semantic-decorate-clear-decorations
+ (semantic-tag-components-with-overlays tag))))
+
+(defun semantic-decorate-add-decorations (tag-list)
+ "Add decorations to tags in TAG-LIST.
+Also make sure old decorations in the area are completely flushed."
+ (dolist (tag tag-list)
+ ;; Cleanup old decorations.
+ (when (semantic-decorate-tag-decoration tag)
+ ;; Note on below comment. This happens more as decorations are
refreshed
+ ;; mid-way through their use. Remove the message.
+
+ ;; It would be nice if this never happened, but it still does
+ ;; once in a while. Print a message to help flush these
+ ;; situations
+ ;;(message "Decorations still on %s" (semantic-format-tag-name tag))
+ (semantic-decorate-clear-tag tag))
+ ;; Add new decorations.
+ (dolist (style semantic-decoration-styles)
+ (let ((pred (semantic-decorate-style-predicate (car style)))
+ (high (semantic-decorate-style-highlighter (car style))))
+ (and (cdr style)
+ (fboundp pred)
+ (funcall pred tag)
+ (fboundp high)
+ (funcall high tag))))
+ ;; Recurse on the children of all tags
+ (semantic-decorate-add-decorations
+ (semantic-tag-components-with-overlays tag))))
+
+;;; PENDING DECORATIONS
+;;
+;; Activities in Emacs may cause a decoration to change state. Any
+;; such identified change ought to be setup as PENDING. This means
+;; that the next idle step will do the decoration change, but at the
+;; time of the state change, minimal work would be done.
+(defvar semantic-decorate-pending-decoration-hook nil
+ "Normal hook run to perform pending decoration changes.")
+
+(semantic-varalias-obsolete 'semantic-decorate-pending-decoration-hooks
+ 'semantic-decorate-pending-decoration-hook)
+
+(defun semantic-decorate-add-pending-decoration (fcn &optional buffer)
+ "Add a pending decoration change represented by FCN.
+Applies only to the current BUFFER.
+The setting of FCN will be removed after it is run."
+ (save-excursion
+ (when buffer (set-buffer buffer))
+ (semantic-make-local-hook 'semantic-decorate-flush-pending-decorations)
+ (add-hook 'semantic-decorate-pending-decoration-hook fcn nil t)))
+
+(defun semantic-decorate-flush-pending-decorations (&optional buffer)
+ "Flush any pending decorations for BUFFER.
+Flush functions from `semantic-decorate-pending-decoration-hook'."
+ (save-excursion
+ (when buffer (set-buffer buffer))
+ (run-hooks 'semantic-decorate-pending-decoration-hook)
+ ;; Always reset the hooks
+ (setq semantic-decorate-pending-decoration-hook nil)))
+
+
+;;; DECORATION MODE
+;;
+;; Generic mode for handling basic highlighting and decorations.
+;;
+
+(defcustom global-semantic-decoration-mode nil
+ "*If non-nil, enable global use of command `semantic-decoration-mode'.
+When this mode is activated, decorations specified by
+`semantic-decoration-styles'."
+ :group 'semantic
+ :group 'semantic-modes
+ :type 'boolean
+ :require 'semantic/decorate/mode
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (global-semantic-decoration-mode (if val 1 -1))))
+
+;;;###autoload
+(defun global-semantic-decoration-mode (&optional arg)
+ "Toggle global use of option `semantic-decoration-mode'.
+Decoration mode turns on all active decorations as specified
+by `semantic-decoration-styles'.
+If ARG is positive, enable, if it is negative, disable.
+If ARG is nil, then toggle."
+ (interactive "P")
+ (setq global-semantic-decoration-mode
+ (semantic-toggle-minor-mode-globally
+ 'semantic-decoration-mode arg)))
+
+(defcustom semantic-decoration-mode-hook nil
+ "Hook run at the end of function `semantic-decoration-mode'."
+ :group 'semantic
+ :type 'hook)
+
+;;;;###autoload
+(defvar semantic-decoration-mode nil
+ "Non-nil if command `semantic-decoration-mode' is enabled.
+Use the command `semantic-decoration-mode' to change this variable.")
+(make-variable-buffer-local 'semantic-decoration-mode)
+
+(defun semantic-decoration-mode-setup ()
+ "Setup the `semantic-decoration-mode' minor mode.
+The minor mode can be turned on only if the semantic feature is available
+and the current buffer was set up for parsing. Return non-nil if the
+minor mode is enabled."
+ (if semantic-decoration-mode
+ (if (not (and (featurep 'semantic) (semantic-active-p)))
+ (progn
+ ;; Disable minor mode if semantic stuff not available
+ (setq semantic-decoration-mode nil)
+ (error "Buffer %s was not set up for parsing"
+ (buffer-name)))
+ ;; Add hooks
+ (semantic-make-local-hook 'semantic-after-partial-cache-change-hook)
+ (add-hook 'semantic-after-partial-cache-change-hook
+ 'semantic-decorate-tags-after-partial-reparse nil t)
+ (semantic-make-local-hook 'semantic-after-toplevel-cache-change-hook)
+ (add-hook 'semantic-after-toplevel-cache-change-hook
+ 'semantic-decorate-tags-after-full-reparse nil t)
+ ;; Add decorations to available tags. The above hooks ensure
+ ;; that new tags will be decorated when they become available.
+ (semantic-decorate-add-decorations (semantic-fetch-available-tags))
+ )
+ ;; Remove decorations from available tags.
+ (semantic-decorate-clear-decorations (semantic-fetch-available-tags))
+ ;; Cleanup any leftover crap too.
+ (semantic-decorate-flush-decorations)
+ ;; Remove hooks
+ (remove-hook 'semantic-after-partial-cache-change-hook
+ 'semantic-decorate-tags-after-partial-reparse t)
+ (remove-hook 'semantic-after-toplevel-cache-change-hook
+ 'semantic-decorate-tags-after-full-reparse t)
+ )
+ semantic-decoration-mode)
+
+(defun semantic-decoration-mode (&optional arg)
+ "Minor mode for decorating tags.
+Decorations are specified in `semantic-decoration-styles'.
+You can define new decoration styles with
+`define-semantic-decoration-style'.
+With prefix argument ARG, turn on if positive, otherwise off. The
+minor mode can be turned on only if semantic feature is available and
+the current buffer was set up for parsing. Return non-nil if the
+minor mode is enabled."
+;;
+;;\\{semantic-decoration-map}"
+ (interactive
+ (list (or current-prefix-arg
+ (if semantic-decoration-mode 0 1))))
+ (setq semantic-decoration-mode
+ (if arg
+ (>
+ (prefix-numeric-value arg)
+ 0)
+ (not semantic-decoration-mode)))
+ (semantic-decoration-mode-setup)
+ (run-hooks 'semantic-decoration-mode-hook)
+ (if (interactive-p)
+ (message "decoration-mode minor mode %sabled"
+ (if semantic-decoration-mode "en" "dis")))
+ (semantic-mode-line-update)
+ semantic-decoration-mode)
+
+(semantic-add-minor-mode 'semantic-decoration-mode
+ ""
+ nil)
+
+(defun semantic-decorate-tags-after-full-reparse (tag-list)
+ "Add decorations after a complete reparse of the current buffer.
+TAG-LIST is the list of tags recently parsed.
+Flush all existing decorations and call `semantic-decorate-add-decorations' to
+add decorations.
+Called from `semantic-after-toplevel-cache-change-hook'."
+ ;; Flush everything
+ (semantic-decorate-flush-decorations)
+ ;; Add it back on
+ (semantic-decorate-add-decorations tag-list))
+
+(defun semantic-decorate-tags-after-partial-reparse (tag-list)
+ "Add decorations when new tags are created in the current buffer.
+TAG-LIST is the list of newly created tags.
+Call `semantic-decorate-add-decorations' to add decorations.
+Called from `semantic-after-partial-cache-change-hook'."
+ (semantic-decorate-add-decorations tag-list))
+
+
+;;; Enable/Disable toggling
+;;
+(defun semantic-decoration-style-enabled-p (style)
+ "Return non-nil if STYLE is currently enabled.
+Return nil if the style is disabled, or does not exist."
+ (let ((pair (assoc style semantic-decoration-styles)))
+ (and pair (cdr pair))))
+
+(defun semantic-toggle-decoration-style (name &optional arg)
+ "Turn on/off the decoration style with NAME.
+Decorations are specified in `semantic-decoration-styles'.
+With prefix argument ARG, turn on if positive, otherwise off.
+Return non-nil if the decoration style is enabled."
+ (interactive
+ (list (completing-read "Decoration style: "
+ semantic-decoration-styles nil t)
+ current-prefix-arg))
+ (setq name (format "%s" name)) ;; Ensure NAME is a string.
+ (unless (equal name "")
+ (let* ((style (assoc name semantic-decoration-styles))
+ (flag (if arg
+ (> (prefix-numeric-value arg) 0)
+ (not (cdr style)))))
+ (unless (eq (cdr style) flag)
+ ;; Store the new flag.
+ (setcdr style flag)
+ ;; Refresh decorations is `semantic-decoration-mode' is on.
+ (when semantic-decoration-mode
+ (semantic-decoration-mode -1)
+ (semantic-decoration-mode 1))
+ (when (interactive-p)
+ (message "Decoration style %s turned %s" (car style)
+ (if flag "on" "off"))))
+ flag)))
+
+(defvar semantic-decoration-menu-cache nil
+ "Cache of the decoration menu.")
+
+(defun semantic-decoration-build-style-menu (style)
+ "Build a menu item for controlling a specific decoration STYLE."
+ (vector (car style)
+ `(lambda () (interactive)
+ (semantic-toggle-decoration-style
+ ,(car style)))
+ :style 'toggle
+ :selected `(semantic-decoration-style-enabled-p ,(car style))
+ ))
+
+(defun semantic-build-decoration-mode-menu (&rest ignore)
+ "Create a menu listing all the known decorations for toggling.
+IGNORE any input arguments."
+ (or semantic-decoration-menu-cache
+ (setq semantic-decoration-menu-cache
+ (mapcar 'semantic-decoration-build-style-menu
+ (reverse semantic-decoration-styles))
+ )))
+
+
+;;; Defining decoration styles
+;;
+(defmacro define-semantic-decoration-style (name doc &rest flags)
+ "Define a new decoration style with NAME.
+DOC is a documentation string describing the decoration style NAME.
+It is appended to auto-generated doc strings.
+An Optional list of FLAGS can also be specified. Flags are:
+ :enabled <value> - specify the default enabled value for NAME.
+
+
+This defines two new overload functions respectively called `NAME-p'
+and `NAME-highlight', for which you must provide a default
+implementation in respectively the functions `NAME-p-default' and
+`NAME-highlight-default'. Those functions are passed a tag. `NAME-p'
+must return non-nil to indicate that the tag should be decorated by
+`NAME-highlight'.
+
+To put primary decorations on a tag `NAME-highlight' must use
+functions like `semantic-set-tag-face', `semantic-set-tag-intangible',
+etc., found in the semantic-decorate library.
+
+To add other kind of decorations on a tag, `NAME-highlight' must use
+`semantic-decorate-tag', and other functions of the semantic
+decoration API found in this library."
+ (let ((predicate (semantic-decorate-style-predicate name))
+ (highlighter (semantic-decorate-style-highlighter name))
+ (defaultenable (if (plist-member flags :enabled)
+ (plist-get flags :enabled)
+ t))
+ )
+ `(progn
+ ;; Clear the menu cache so that new items are added when
+ ;; needed.
+ (setq semantic-decoration-menu-cache nil)
+ ;; Create an override method to specify if a given tag belongs
+ ;; to this type of decoration
+ (define-overloadable-function ,predicate (tag)
+ ,(format "Return non-nil to decorate TAG with `%s' style.\n%s"
+ name doc))
+ ;; Create an override method that will perform the highlight
+ ;; operation if the -p method returns non-nil.
+ (define-overloadable-function ,highlighter (tag)
+ ,(format "Decorate TAG with `%s' style.\n%s"
+ name doc))
+ ;; Add this to the list of primary decoration modes.
+ (add-to-list 'semantic-decoration-styles
+ (cons ',(symbol-name name)
+ ,defaultenable))
+ )))
+
+;;; Predefined decoration styles
+;;
+
+;;; Tag boundaries highlighting
+;;
+(define-semantic-decoration-style semantic-tag-boundary
+ "Place an overline in front of each long tag.
+Does not provide overlines for prototypes.")
+
+(defface semantic-tag-boundary-face
+ '((((class color) (background dark))
+ (:overline "cyan"))
+ (((class color) (background light))
+ (:overline "blue")))
+ "*Face used to show long tags in.
+Used by decoration style: `semantic-tag-boundary'."
+ :group 'semantic-faces)
+
+(defun semantic-tag-boundary-p-default (tag)
+ "Return non-nil if TAG is a type, or a non-prototype function."
+ (let ((c (semantic-tag-class tag)))
+ (and
+ (or
+ ;; All types get a line?
+ (eq c 'type)
+ ;; Functions which aren't prototypes get a line.
+ (and (eq c 'function)
+ (not (semantic-tag-get-attribute tag :prototype-flag)))
+ )
+ ;; Note: The below restriction confused users.
+ ;;
+ ;; Nothing smaller than a few lines
+ ;;(> (- (semantic-tag-end tag) (semantic-tag-start tag)) 150)
+ ;; Random truth
+ t)
+ ))
+
+(defun semantic-tag-boundary-highlight-default (tag)
+ "Highlight the first line of TAG as a boundary."
+ (when (bufferp (semantic-tag-buffer tag))
+ (with-current-buffer (semantic-tag-buffer tag)
+ (semantic-decorate-tag
+ tag
+ (semantic-tag-start tag)
+ (save-excursion
+ (goto-char (semantic-tag-start tag))
+ (end-of-line)
+ (forward-char 1)
+ (point))
+ 'semantic-tag-boundary-face))
+ ))
+
+;;; Private member highlighting
+;;
+(define-semantic-decoration-style semantic-decoration-on-private-members
+ "Highlight class members that are designated as PRIVATE access."
+ :enabled nil)
+
+(defface semantic-decoration-on-private-members-face
+ '((((class color) (background dark))
+ (:background "#200000"))
+ (((class color) (background light))
+ (:background "#8fffff")))
+ "*Face used to show privately scoped tags in.
+Used by the decoration style: `semantic-decoration-on-private-members'."
+ :group 'semantic-faces)
+
+(defun semantic-decoration-on-private-members-highlight-default (tag)
+ "Highlight TAG as designated to have PRIVATE access.
+Use a primary decoration."
+ (semantic-set-tag-face
+ tag 'semantic-decoration-on-private-members-face))
+
+(defun semantic-decoration-on-private-members-p-default (tag)
+ "Return non-nil if TAG has PRIVATE access."
+ (and (member (semantic-tag-class tag) '(function variable))
+ (eq (semantic-tag-protection tag) 'private)))
+
+;;; Protected member highlighting
+;;
+(defface semantic-decoration-on-protected-members-face
+ '((((class color) (background dark))
+ (:background "#000020"))
+ (((class color) (background light))
+ (:background "#fffff8")))
+ "*Face used to show protected scoped tags in.
+Used by the decoration style: `semantic-decoration-on-protected-members'."
+ :group 'semantic-faces)
+
+(define-semantic-decoration-style semantic-decoration-on-protected-members
+ "Highlight class members that are designated as PROTECTED access."
+ :enabled nil)
+
+(defun semantic-decoration-on-protected-members-p-default (tag)
+ "Return non-nil if TAG has PROTECTED access."
+ (and (member (semantic-tag-class tag) '(function variable))
+ (eq (semantic-tag-protection tag) 'protected)))
+
+(defun semantic-decoration-on-protected-members-highlight-default (tag)
+ "Highlight TAG as designated to have PROTECTED access.
+Use a primary decoration."
+ (semantic-set-tag-face
+ tag 'semantic-decoration-on-protected-members-face))
+
+(provide 'semantic/decorate/mode)
+
+;; Local variables:
+;; generated-autoload-file: "../loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/decorate/mode"
+;; End:
+
+;;; semantic/decorate/mode.el ends here
Index: cedet/semantic/symref/cscope.el
===================================================================
RCS file: cedet/semantic/symref/cscope.el
diff -N cedet/semantic/symref/cscope.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/symref/cscope.el 28 Sep 2009 15:15:10 -0000 1.2
@@ -0,0 +1,95 @@
+;;; semantic/symref/cscope.el --- Semantic-symref support via cscope.
+
+;;; Copyright (C) 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Semantic symref support via cscope.
+
+(require 'cedet-cscope)
+(require 'semantic/symref)
+
+(defvar ede-minor-mode)
+(declare-function ede-toplevel "ede/files")
+(declare-function ede-project-root-directory "ede/files")
+
+;;; Code:
+;;;###autoload
+(defclass semantic-symref-tool-cscope (semantic-symref-tool-baseclass)
+ (
+ )
+ "A symref tool implementation using CScope.
+The CScope command can be used to generate lists of tags in a way
+similar to that of `grep'. This tool will parse the output to generate
+the hit list.
+
+See the function `cedet-cscope-search' for more details.")
+
+(defmethod semantic-symref-perform-search ((tool semantic-symref-tool-cscope))
+ "Perform a search with GNU Global."
+ (let* ((rootproj (when (and (featurep 'ede) ede-minor-mode)
+ (ede-toplevel)))
+ (default-directory (if rootproj
+ (ede-project-root-directory rootproj)
+ default-directory))
+ ;; CScope has to be run from the project root where
+ ;; cscope.out is.
+ (b (cedet-cscope-search (oref tool :searchfor)
+ (oref tool :searchtype)
+ (oref tool :resulttype)
+ (oref tool :searchscope)
+ ))
+ )
+ (semantic-symref-parse-tool-output tool b)
+ ))
+
+(defmethod semantic-symref-parse-tool-output-one-line ((tool
semantic-symref-tool-cscope))
+ "Parse one line of grep output, and return it as a match list.
+Moves cursor to end of the match."
+ (cond ((eq (oref tool :resulttype) 'file)
+ ;; Search for files
+ (when (re-search-forward "^\\([^\n]+\\)$" nil t)
+ (match-string 1)))
+ ((eq (oref tool :searchtype) 'tagcompletions)
+ ;; Search for files
+ (when (re-search-forward "^[^ ]+ [^ ]+ [^ ]+ \\(.*\\)$" nil t)
+ (let ((subtxt (match-string 1))
+ (searchtxt (oref tool :searchfor)))
+ (if (string-match (concat "\\<" searchtxt "\\(\\w\\|\\s_\\)*\\>")
+ subtxt)
+ (match-string 0 subtxt)
+ ;; We have to return something at this point.
+ subtxt)))
+ )
+ (t
+ (when (re-search-forward "^\\([^ ]+\\) [^ ]+ \\([0-9]+\\) " nil t)
+ (cons (string-to-number (match-string 2))
+ (expand-file-name (match-string 1)))
+ ))))
+
+(provide 'semantic/symref/cscope)
+
+;; Local variables:
+;; generated-autoload-file: "../loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/symref/cscope"
+;; End:
+
+;;; semantic/symref/cscope.el ends here
Index: cedet/semantic/symref/filter.el
===================================================================
RCS file: cedet/semantic/symref/filter.el
diff -N cedet/semantic/symref/filter.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/symref/filter.el 28 Sep 2009 15:15:10 -0000 1.2
@@ -0,0 +1,140 @@
+;;; semantic/symref/filter.el --- Filter symbol reference hits for accuracy.
+
+;;; Copyright (C) 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Filter symbol reference hits for accuracy.
+;;
+;; Most symbol referencing tools, such as find/grep only find matching
+;; strings, but cannot determine the difference between an actual use,
+;; and something else with a similar name, or even a string in a comment.
+;;
+;; This file provides utilities for filtering down to accurate matches
+;; starting at a basic filter level that doesn't use symref, up to filters
+;; across symref results.
+
+;;; Code:
+
+(require 'semantic)
+(require 'semantic/analyze)
+(declare-function srecode-active-template-region "srecode/fields")
+(declare-function srecode-delete "srecode/fields")
+(declare-function srecode-field "srecode/fields")
+(declare-function srecode-template-inserted-region "srecode/fields")
+(declare-function srecode-overlaid-activate "srecode/fields")
+(declare-function semantic-idle-summary-useful-context-p "semantic/idle")
+
+;;; FILTERS
+;;
+(defun semantic-symref-filter-hit (target &optional position)
+ "Determine if the tag TARGET is used at POSITION in the current buffer.
+Return non-nil for a match."
+ (semantic-analyze-current-symbol
+ (lambda (start end prefix)
+ (let ((tag (car (nreverse prefix))))
+ (and (semantic-tag-p tag)
+ (semantic-equivalent-tag-p target tag))))
+ position))
+
+;;; IN-BUFFER FILTERING
+
+;; The following does filtering in-buffer only, and not against
+;; a symref results object.
+
+(defun semantic-symref-hits-in-region (target hookfcn start end)
+ "Find all occurances of the symbol TARGET that match TARGET the tag.
+For each match, call HOOKFCN.
+HOOKFCN takes three arguments that match
+`semantic-analyze-current-symbol's use of HOOKfCN.
+ ( START END PREFIX )
+
+Search occurs in the current buffer between START and END."
+ (require 'semantic/idle)
+ (save-excursion
+ (goto-char start)
+ (let* ((str (semantic-tag-name target))
+ (case-fold-search semantic-case-fold)
+ (regexp (concat "\\<" (regexp-quote str) "\\>")))
+ (while (re-search-forward regexp end t)
+ (when (semantic-idle-summary-useful-context-p)
+ (semantic-analyze-current-symbol
+ (lambda (start end prefix)
+ (let ((tag (car (nreverse prefix))))
+ ;; check for semantic match on the text match.
+ (when (and (semantic-tag-p tag)
+ (semantic-equivalent-tag-p target tag))
+ (save-excursion
+ (funcall hookfcn start end prefix)))))
+ (point)))))))
+
+(defun semantic-symref-rename-local-variable ()
+ "Fancy way to rename the local variable under point.
+Depends on the SRecode Field editing API."
+ (interactive)
+ ;; Do the replacement as needed.
+ (let* ((ctxt (semantic-analyze-current-context))
+ (target (car (reverse (oref ctxt prefix))))
+ (tag (semantic-current-tag))
+ )
+
+ (when (or (not target)
+ (not (semantic-tag-with-position-p target)))
+ (error "Cannot identify symbol under point"))
+
+ (when (not (semantic-tag-of-class-p target 'variable))
+ (error "Can only rename variables"))
+
+ (when (or (< (semantic-tag-start target) (semantic-tag-start tag))
+ (> (semantic-tag-end target) (semantic-tag-end tag)))
+ (error "Can only rename variables declared in %s"
+ (semantic-tag-name tag)))
+
+ ;; I think we're good for this example. Give it a go through
+ ;; our fancy interface from SRecode.
+ (require 'srecode/fields)
+
+ ;; Make sure there is nothing active.
+ (let ((ar (srecode-active-template-region)))
+ (when ar (srecode-delete ar)))
+
+ (let ((srecode-field-archive nil)
+ (region nil)
+ )
+ (semantic-symref-hits-in-region
+ target (lambda (start end prefix)
+ ;; For every valid hit, create one field.
+ (srecode-field "LOCAL" :name "LOCAL" :start start :end end))
+ (semantic-tag-start tag) (semantic-tag-end tag))
+
+ ;; Now that the fields are setup, create the region.
+ (setq region (srecode-template-inserted-region
+ "REGION" :start (semantic-tag-start tag)
+ :end (semantic-tag-end tag)))
+
+ ;; Activate the region.
+ (srecode-overlaid-activate region)
+
+ )
+ ))
+
+(provide 'semantic/symref/filter)
+
+;;; semantic/symref/filter.el ends here
Index: cedet/semantic/symref/global.el
===================================================================
RCS file: cedet/semantic/symref/global.el
diff -N cedet/semantic/symref/global.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/symref/global.el 28 Sep 2009 15:15:11 -0000 1.2
@@ -0,0 +1,76 @@
+;;; semantic/symref/global.el --- Use GNU Global for symbol references
+
+;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric Ludlam <address@hidden>
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; GNU Global use with the semantic-symref system.
+
+(require 'cedet-global)
+(require 'semantic/symref)
+
+;;; Code:
+;;;###autoload
+(defclass semantic-symref-tool-global (semantic-symref-tool-baseclass)
+ (
+ )
+ "A symref tool implementation using GNU Global.
+The GNU Global command can be used to generate lists of tags in a way
+similar to that of `grep'. This tool will parse the output to generate
+the hit list.
+
+See the function `cedet-gnu-global-search' for more details.")
+
+(defmethod semantic-symref-perform-search ((tool semantic-symref-tool-global))
+ "Perform a search with GNU Global."
+ (let ((b (cedet-gnu-global-search (oref tool :searchfor)
+ (oref tool :searchtype)
+ (oref tool :resulttype)
+ (oref tool :searchscope)
+ ))
+ )
+ (semantic-symref-parse-tool-output tool b)
+ ))
+
+(defmethod semantic-symref-parse-tool-output-one-line ((tool
semantic-symref-tool-global))
+ "Parse one line of grep output, and return it as a match list.
+Moves cursor to end of the match."
+ (cond ((or (eq (oref tool :resulttype) 'file)
+ (eq (oref tool :searchtype) 'tagcompletions))
+ ;; Search for files
+ (when (re-search-forward "^\\([^\n]+\\)$" nil t)
+ (match-string 1)))
+ (t
+ (when (re-search-forward "^\\([^ ]+\\) +\\([0-9]+\\) \\([^ ]+\\) " nil
t)
+ (cons (string-to-number (match-string 2))
+ (match-string 3))
+ ))))
+
+(provide 'semantic/symref/global)
+
+;; Local variables:
+;; generated-autoload-file: "../loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/symref/global"
+;; End:
+
+;;; semantic/symref/global.el ends here
Index: cedet/semantic/symref/grep.el
===================================================================
RCS file: cedet/semantic/symref/grep.el
diff -N cedet/semantic/symref/grep.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/symref/grep.el 28 Sep 2009 15:15:11 -0000 1.2
@@ -0,0 +1,202 @@
+;;; semantic/symref/grep.el --- Symref implementation using find/grep
+
+;;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Implement the symref tool API using the external tools find/grep.
+;;
+;; The symref GREP tool uses grep in a project to find symbol references.
+;; This is a lowest-common-denominator tool with sucky performance that
+;; can be used in small projects to find symbol references.
+
+(require 'semantic/symref)
+(require 'grep)
+
+(defvar ede-minor-mode)
+(declare-function ede-toplevel "ede/files")
+(declare-function ede-project-root-directory "ede/files")
+
+;;; Code:
+
+;;; GREP
+;;;###autoload
+(defclass semantic-symref-tool-grep (semantic-symref-tool-baseclass)
+ (
+ )
+ "A symref tool implementation using grep.
+This tool uses EDE to find he root of the project, then executes
+find-grep in the project. The output is parsed for hits
+and those hits returned.")
+
+(defvar semantic-symref-filepattern-alist
+ '((c-mode "*.[ch]")
+ (c++-mode "*.[chCH]" "*.[ch]pp" "*.cc" "*.hh")
+ (html-mode "*.s?html" "*.php")
+ )
+ "List of major modes and file extension pattern regexp.
+See find -regex man page for format.")
+
+(defun semantic-symref-derive-find-filepatterns (&optional mode)
+ "Derive a list of file patterns for the current buffer.
+Looks first in `semantic-symref-filepattern-alist'. If it is not
+there, it then looks in `auto-mode-alist', and attempts to derive something
+from that.
+Optional argument MODE specifies the `major-mode' to test."
+ ;; First, try the filepattern alist.
+ (let* ((mode (or mode major-mode))
+ (pat (cdr (assoc mode semantic-symref-filepattern-alist))))
+ (when (not pat)
+ ;; No hit, try auto-mode-alist.
+ (dolist (X auto-mode-alist)
+ (when (eq (cdr X) mode)
+ ;; Only take in simple patterns, so try to convert this one.
+ (let ((Xp
+ (cond ((string-match "\\\\\\.\\([^\\'>]+\\)\\\\'" (car X))
+ (concat "*." (match-string 1 (car X))))
+ (t nil))))
+ (when Xp
+ (setq pat (cons Xp pat))))
+ )))
+ ;; Convert the list into some find-flags.
+ (cond ((= (length pat) 1)
+ (concat "-name \"" (car pat) "\""))
+ ((consp pat)
+ (concat "\\( "
+ (mapconcat (lambda (s)
+ (concat "-name \"" s "\""))
+ pat
+ " -o ")
+ " \\)"))
+ (t
+ (error "Configuration for `semantic-symref-tool-grep' needed for %s"
major-mode))
+ )))
+
+(defvar semantic-symref-grep-expand-keywords
+ (condition-case nil
+ (let* ((kw (copy-alist grep-expand-keywords))
+ (C (assoc "<C>" kw))
+ (R (assoc "<R>" kw)))
+ (setcdr C 'grepflags)
+ (setcdr R 'greppattern)
+ kw)
+ (error nil))
+ "Grep expand keywords used when expanding templates for symref.")
+
+(defun semantic-symref-grep-use-template (rootdir filepattern grepflags
greppattern)
+ "Use the grep template expand feature to create a grep command.
+ROOTDIR is the root location to run the `find' from.
+FILEPATTERN is a string represeting find flags for searching file patterns.
+GREPFLAGS are flags passed to grep, such as -n or -l.
+GREPPATTERN is the pattren used by grep."
+ ;; We have grep-compute-defaults. Lets use it.
+ (grep-compute-defaults)
+ (let* ((grep-expand-keywords semantic-symref-grep-expand-keywords)
+ (cmd (grep-expand-template grep-find-template
+ greppattern
+ filepattern
+ rootdir)))
+ ;; For some reason, my default has no <D> in it.
+ (when (string-match "find \\(\\.\\)" cmd)
+ (setq cmd (replace-match rootdir t t cmd 1)))
+ ;;(message "New command: %s" cmd)
+ cmd))
+
+(defmethod semantic-symref-perform-search ((tool semantic-symref-tool-grep))
+ "Perform a search with Grep."
+ ;; Grep doesn't support some types of searches.
+ (let ((st (oref tool :searchtype)))
+ (when (not (eq st 'symbol))
+ (error "Symref impl GREP does not support searchtype of %s" st))
+ )
+ ;; Find the root of the project, and do a find-grep...
+ (let* (;; Find the file patterns to use.
+ (pat (cdr (assoc major-mode semantic-symref-filepattern-alist)))
+ (rootdir (cond
+ ;; Project root via EDE.
+ ((eq (oref tool :searchscope) 'project)
+ (let ((rootproj (when (and (featurep 'ede) ede-minor-mode)
+ (ede-toplevel))))
+ (if rootproj
+ (ede-project-root-directory rootproj)
+ default-directory)))
+ ;; Calculate the target files as just in
+ ;; this directory... cause I'm lazy.
+ ((eq (oref tool :searchscope) 'target)
+ default-directory)
+ ))
+ (filepattern (semantic-symref-derive-find-filepatterns))
+ ;; Grep based flags.
+ (grepflags (cond ((eq (oref tool :resulttype) 'file)
+ "-l ")
+ (t "-n ")))
+ (greppat (cond ((eq (oref tool :searchtype) 'regexp)
+ (oref tool searchfor))
+ (t
+ (concat "'\\<" (oref tool searchfor) "\\>'"))))
+ ;; Misc
+ (b (get-buffer-create "*Semantic SymRef*"))
+ (ans nil)
+ )
+
+ (save-excursion
+ (set-buffer b)
+ (erase-buffer)
+ (setq default-directory rootdir)
+
+ (if (not (fboundp 'grep-compute-defaults))
+
+ ;; find . -type f -print0 | xargs -0 -e grep -nH -e
+ ;; Note : I removed -e as it is not posix, nor necessary it seems.
+
+ (let ((cmd (concat "find " default-directory " -type f " filepattern
" -print0 "
+ "| xargs -0 grep -H " grepflags "-e " greppat)))
+ ;;(message "Old command: %s" cmd)
+ (call-process "sh" nil b nil "-c" cmd)
+ )
+ (let ((cmd (semantic-symref-grep-use-template rootdir filepattern
grepflags greppat)))
+ (call-process "sh" nil b nil "-c" cmd))
+ ))
+ (setq ans (semantic-symref-parse-tool-output tool b))
+ ;; Return the answer
+ ans))
+
+(defmethod semantic-symref-parse-tool-output-one-line ((tool
semantic-symref-tool-grep))
+ "Parse one line of grep output, and return it as a match list.
+Moves cursor to end of the match."
+ (cond ((eq (oref tool :resulttype) 'file)
+ ;; Search for files
+ (when (re-search-forward "^\\([^\n]+\\)$" nil t)
+ (match-string 1)))
+ (t
+ (when (re-search-forward
"^\\(\\(?:[a-zA-Z]:\\)?[^:\n]+\\):\\([0-9]+\\):" nil t)
+ (cons (string-to-number (match-string 2))
+ (match-string 1))
+ ))))
+
+(provide 'semantic/symref/grep)
+
+;; Local variables:
+;; generated-autoload-file: "../loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/symref/grep"
+;; End:
+
+;;; semantic/symref/grep.el ends here
Index: cedet/semantic/symref/idutils.el
===================================================================
RCS file: cedet/semantic/symref/idutils.el
diff -N cedet/semantic/symref/idutils.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/symref/idutils.el 28 Sep 2009 15:15:11 -0000 1.2
@@ -0,0 +1,78 @@
+;;; semantic/symref/idutils.el --- Symref implementation for idutils
+
+;;; Copyright (C) 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or (at
+;; your option) any later version.
+
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+;;
+;; Support IDUtils use in the Semantic Symref tool.
+
+(require 'cedet-idutils)
+(require 'semantic/symref)
+
+;;; Code:
+;;;###autoload
+(defclass semantic-symref-tool-idutils (semantic-symref-tool-baseclass)
+ (
+ )
+ "A symref tool implementation using ID Utils.
+The udutils command set can be used to generate lists of tags in a way
+similar to that of `grep'. This tool will parse the output to generate
+the hit list.
+
+See the function `cedet-idutils-search' for more details.")
+
+(defmethod semantic-symref-perform-search ((tool semantic-symref-tool-idutils))
+ "Perform a search with IDUtils."
+ (let ((b (cedet-idutils-search (oref tool :searchfor)
+ (oref tool :searchtype)
+ (oref tool :resulttype)
+ (oref tool :searchscope)
+ ))
+ )
+ (semantic-symref-parse-tool-output tool b)
+ ))
+
+(defmethod semantic-symref-parse-tool-output-one-line ((tool
semantic-symref-tool-idutils))
+ "Parse one line of grep output, and return it as a match list.
+Moves cursor to end of the match."
+ (cond ((eq (oref tool :resulttype) 'file)
+ ;; Search for files
+ (when (re-search-forward "^\\([^\n]+\\)$" nil t)
+ (match-string 1)))
+ ((eq (oref tool :searchtype) 'tagcompletions)
+ (when (re-search-forward "^\\([^ ]+\\) " nil t)
+ (match-string 1)))
+ (t
+ (when (re-search-forward "^\\([^ :]+\\):+\\([0-9]+\\):" nil t)
+ (cons (string-to-number (match-string 2))
+ (expand-file-name (match-string 1) default-directory))
+ ))))
+
+(provide 'semantic/symref/idutils)
+
+;; Local variables:
+;; generated-autoload-file: "../loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/symref/idutils"
+;; End:
+
+;;; semantic/symref/idutils.el ends here
Index: cedet/semantic/symref/list.el
===================================================================
RCS file: cedet/semantic/symref/list.el
diff -N cedet/semantic/symref/list.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/symref/list.el 28 Sep 2009 15:15:11 -0000 1.2
@@ -0,0 +1,337 @@
+;;; semantic/symref/list.el --- Symref Output List UI.
+
+;;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or (at
+;; your option) any later version.
+
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+;;
+;; Provide a simple user facing API to finding symbol references.
+;;
+;; This UI will is the base of some refactoring tools. For any
+;; refactor, the user will execture `semantic-symref' in a tag. Once
+;; that data is collected, the output will be listed in a buffer. In
+;; the output buffer, the user can then initiate different refactoring
+;; operations.
+;;
+;; NOTE: Need to add some refactoring tools.
+
+(require 'semantic/symref)
+(require 'semantic/complete)
+(require 'pulse)
+
+;;; Code:
+
+;;;###autoload
+(defun semantic-symref ()
+ "Find references to the current tag.
+This command uses the currently configured references tool within the
+current project to find references to the current tag. The
+references are the organized by file and the name of the function
+they are used in.
+Display the references in`semantic-symref-results-mode'"
+ (interactive)
+ (semantic-fetch-tags)
+ (let ((ct (semantic-current-tag))
+ (res nil)
+ )
+ ;; Must have a tag...
+ (when (not ct) (error "Place cursor inside tag to be searched for"))
+ ;; Check w/ user.
+ (when (not (y-or-n-p (format "Find references for %s? " (semantic-tag-name
ct))))
+ (error "Quit"))
+ ;; Gather results and tags
+ (message "Gathering References...")
+ (setq res (semantic-symref-find-references-by-name (semantic-tag-name ct)))
+ (semantic-symref-produce-list-on-results res (semantic-tag-name ct))))
+
+;;;###autoload
+(defun semantic-symref-symbol (sym)
+ "Find references to the symbol SYM.
+This command uses the currently configured references tool within the
+current project to find references to the input SYM. The
+references are the organized by file and the name of the function
+they are used in.
+Display the references in`semantic-symref-results-mode'"
+ (interactive (list (semantic-tag-name (semantic-complete-read-tag-buffer-deep
+ "Symrefs for: "))))
+ (semantic-fetch-tags)
+ (let ((res nil)
+ )
+ ;; Gather results and tags
+ (message "Gathering References...")
+ (setq res (semantic-symref-find-references-by-name sym))
+ (semantic-symref-produce-list-on-results res sym)))
+
+
+(defun semantic-symref-produce-list-on-results (res str)
+ "Produce a symref list mode buffer on the results RES."
+ (when (not res) (error "No references found"))
+ (semantic-symref-result-get-tags res t)
+ (message "Gathering References...done")
+ ;; Build a refrences buffer.
+ (let ((buff (get-buffer-create
+ (format "*Symref %s" str)))
+ )
+ (switch-to-buffer-other-window buff)
+ (set-buffer buff)
+ (semantic-symref-results-mode res))
+ )
+
+;;; RESULTS MODE
+;;
+(defgroup semantic-symref-results-mode nil
+ "Symref Results group."
+ :group 'semantic)
+
+(defvar semantic-symref-results-mode-map
+ (let ((km (make-sparse-keymap)))
+ (define-key km "\C-i" 'forward-button)
+ (define-key km "\M-C-i" 'backward-button)
+ (define-key km " " 'push-button)
+ (define-key km "-" 'semantic-symref-list-toggle-showing)
+ (define-key km "=" 'semantic-symref-list-toggle-showing)
+ (define-key km "+" 'semantic-symref-list-toggle-showing)
+ (define-key km "n" 'semantic-symref-list-next-line)
+ (define-key km "p" 'semantic-symref-list-prev-line)
+ (define-key km "q" 'semantic-symref-hide-buffer)
+ km)
+ "Keymap used in `semantic-symref-results-mode'.")
+
+(defcustom semantic-symref-results-mode-hook nil
+ "*Hook run when `semantic-symref-results-mode' starts."
+ :group 'semantic-symref
+ :type 'hook)
+
+(defvar semantic-symref-current-results nil
+ "The current results in a results mode buffer.")
+
+(defun semantic-symref-results-mode (results)
+ "Major-mode for displaying Semantic Symbol Reference RESULTS.
+RESULTS is an object of class `semantic-symref-results'."
+ (interactive)
+ (kill-all-local-variables)
+ (setq major-mode 'semantic-symref-results-mode
+ mode-name "Symref"
+ )
+ (use-local-map semantic-symref-results-mode-map)
+ (set (make-local-variable 'semantic-symref-current-results)
+ results)
+ (semantic-symref-results-dump results)
+ (goto-char (point-min))
+ (buffer-disable-undo)
+ (set (make-local-variable 'font-lock-global-modes) nil)
+ (font-lock-mode -1)
+ (run-hooks 'semantic-symref-results-mode-hook)
+ )
+
+(defun semantic-symref-hide-buffer ()
+ "Hide buffer with sematinc-symref results"
+ (interactive)
+ (bury-buffer))
+
+(defcustom semantic-symref-results-summary-function
'semantic-format-tag-prototype
+ "*Function to use when creating items in Imenu.
+Some useful functions are found in `semantic-format-tag-functions'."
+ :group 'semantic-symref
+ :type semantic-format-tag-custom-list)
+
+(defun semantic-symref-results-dump (results)
+ "Dump the RESULTS into the current buffer."
+ ;; Get ready for the insert.
+ (toggle-read-only -1)
+ (erase-buffer)
+
+ ;; Insert the contents.
+ (let ((lastfile nil)
+ )
+ (dolist (T (oref results :hit-tags))
+
+ (when (not (equal lastfile (semantic-tag-file-name T)))
+ (setq lastfile (semantic-tag-file-name T))
+ (insert-button lastfile
+ 'mouse-face 'custom-button-pressed-face
+ 'action 'semantic-symref-rb-goto-file
+ 'tag T
+ )
+ (insert "\n"))
+
+ (insert " ")
+ (insert-button "[+]"
+ 'mouse-face 'highlight
+ 'face nil
+ 'action 'semantic-symref-rb-toggle-expand-tag
+ 'tag T
+ 'state 'closed)
+ (insert " ")
+ (insert-button (funcall semantic-symref-results-summary-function
+ T nil t)
+ 'mouse-face 'custom-button-pressed-face
+ 'face nil
+ 'action 'semantic-symref-rb-goto-tag
+ 'tag T)
+ (insert "\n")
+
+ ))
+
+ ;; Clean up the mess
+ (toggle-read-only 1)
+ (set-buffer-modified-p nil)
+ )
+
+;;; Commands for semantic-symref-results
+;;
+(defun semantic-symref-list-toggle-showing ()
+ "Toggle showing the contents below the current line."
+ (interactive)
+ (beginning-of-line)
+ (when (re-search-forward "\\[[-+]\\]" (point-at-eol) t)
+ (forward-char -1)
+ (push-button)))
+
+(defun semantic-symref-rb-toggle-expand-tag (&optional button)
+ "Go to the file specified in the symref results buffer.
+BUTTON is the button that was clicked."
+ (interactive)
+ (let* ((tag (button-get button 'tag))
+ (buff (semantic-tag-buffer tag))
+ (hits (semantic--tag-get-property tag :hit))
+ (state (button-get button 'state))
+ (text nil)
+ )
+ (cond
+ ((eq state 'closed)
+ (toggle-read-only -1)
+ (save-excursion
+ (set-buffer buff)
+ (dolist (H hits)
+ (goto-char (point-min))
+ (forward-line (1- H))
+ (beginning-of-line)
+ (back-to-indentation)
+ (setq text (cons (buffer-substring (point) (point-at-eol)) text)))
+ (setq text (nreverse text))
+ )
+ (goto-char (button-start button))
+ (forward-char 1)
+ (delete-char 1)
+ (insert "-")
+ (button-put button 'state 'open)
+ (save-excursion
+ (end-of-line)
+ (while text
+ (insert "\n")
+ (insert " ")
+ (insert-button (car text)
+ 'mouse-face 'highlight
+ 'face nil
+ 'action 'semantic-symref-rb-goto-match
+ 'tag tag
+ 'line (car hits))
+ (setq text (cdr text)
+ hits (cdr hits))))
+ (toggle-read-only 1)
+ )
+ ((eq state 'open)
+ (toggle-read-only -1)
+ (button-put button 'state 'closed)
+ ;; Delete the various bits.
+ (goto-char (button-start button))
+ (forward-char 1)
+ (delete-char 1)
+ (insert "+")
+ (save-excursion
+ (end-of-line)
+ (forward-char 1)
+ (delete-region (point)
+ (save-excursion
+ (forward-char 1)
+ (forward-line (length hits))
+ (point))))
+ (toggle-read-only 1)
+ )
+ ))
+ )
+
+(defun semantic-symref-rb-goto-file (&optional button)
+ "Go to the file specified in the symref results buffer.
+BUTTON is the button that was clicked."
+ (let* ((tag (button-get button 'tag))
+ (buff (semantic-tag-buffer tag))
+ (win (selected-window))
+ )
+ (switch-to-buffer-other-window buff)
+ (pulse-momentary-highlight-one-line (point))
+ (when (eq last-command-event ?\s) (select-window win))
+ ))
+
+
+(defun semantic-symref-rb-goto-tag (&optional button)
+ "Go to the file specified in the symref results buffer.
+BUTTON is the button that was clicked."
+ (interactive)
+ (let* ((tag (button-get button 'tag))
+ (buff (semantic-tag-buffer tag))
+ (win (selected-window))
+ )
+ (switch-to-buffer-other-window buff)
+ (semantic-go-to-tag tag)
+ (pulse-momentary-highlight-one-line (point))
+ (when (eq last-command-event ?\s) (select-window win))
+ )
+ )
+
+(defun semantic-symref-rb-goto-match (&optional button)
+ "Go to the file specified in the symref results buffer.
+BUTTON is the button that was clicked."
+ (interactive)
+ (let* ((tag (button-get button 'tag))
+ (line (button-get button 'line))
+ (buff (semantic-tag-buffer tag))
+ (win (selected-window))
+ )
+ (switch-to-buffer-other-window buff)
+ (with-no-warnings (goto-line line))
+ (pulse-momentary-highlight-one-line (point))
+ (when (eq last-command-event ?\s) (select-window win))
+ )
+ )
+
+(defun semantic-symref-list-next-line ()
+ "Next line in `semantic-symref-results-mode'."
+ (interactive)
+ (forward-line 1)
+ (back-to-indentation))
+
+(defun semantic-symref-list-prev-line ()
+ "Next line in `semantic-symref-results-mode'."
+ (interactive)
+ (forward-line -1)
+ (back-to-indentation))
+
+(provide 'semantic/symref/list)
+
+;; Local variables:
+;; generated-autoload-file: "../loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/symref/list"
+;; End:
+
+;;; semantic/symref/list.el ends here
Index: cedet/semantic/wisent/comp.el
===================================================================
RCS file: cedet/semantic/wisent/comp.el
diff -N cedet/semantic/wisent/comp.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/wisent/comp.el 28 Sep 2009 15:15:11 -0000 1.2
@@ -0,0 +1,3539 @@
+;;; semantic/wisent/comp.el --- GNU Bison for Emacs - Grammar compiler
+
+;; Copyright (C) 1984, 1986, 1989, 1992, 1995, 2000, 2001, 2002, 2003,
+;; 2004, 2005, 2006, 2007, 2009 Free Software Foundation, Inc.
+
+;; Author: David Ponce <address@hidden>
+;; Maintainer: David Ponce <address@hidden>
+;; Created: 30 January 2002
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Grammar compiler that produces Wisent's LALR automatons.
+;;
+;; Wisent (the European Bison ;-) is an Elisp implementation of the
+;; GNU Compiler Compiler Bison. The Elisp code is a port of the C
+;; code of GNU Bison 1.28 & 1.31.
+;;
+;; For more details on the basic concepts for understanding Wisent,
+;; read the Bison manual ;)
+;;
+;; For more details on Wisent itself read the Wisent manual.
+
+;;; History:
+;;
+
+;;; Code:
+(require 'semantic/wisent)
+
+;;;; -------------------
+;;;; Misc. useful things
+;;;; -------------------
+
+;; As much as possible I would like to keep the name of global
+;; variables used in Bison without polluting too much the Elisp global
+;; name space. Elisp dynamic binding allows that ;-)
+
+;; Here are simple macros to easily define and use set of variables
+;; binded locally, without all these "reference to free variable"
+;; compiler warnings!
+
+(defmacro wisent-context-name (name)
+ "Return the context name from NAME."
+ `(if (and ,name (symbolp ,name))
+ (intern (format "wisent-context-%s" ,name))
+ (error "Invalid context name: %S" ,name)))
+
+(defmacro wisent-context-bindings (name)
+ "Return the variables in context NAME."
+ `(symbol-value (wisent-context-name ,name)))
+
+(defmacro wisent-defcontext (name &rest vars)
+ "Define a context NAME that will bind variables VARS."
+ (let* ((context (wisent-context-name name))
+ (bindings (mapcar #'(lambda (v) (list 'defvar v)) vars)))
+ `(eval-when-compile
+ ,@bindings
+ (defvar ,context ',vars))))
+(put 'wisent-defcontext 'lisp-indent-function 1)
+
+(defmacro wisent-with-context (name &rest body)
+ "Bind variables in context NAME then eval BODY."
+ `(let* ,(wisent-context-bindings name)
+ ,@body))
+(put 'wisent-with-context 'lisp-indent-function 1)
+
+;; A naive implementation of data structures! But it suffice here ;-)
+
+(defmacro wisent-struct (name &rest fields)
+ "Define a simple data structure called NAME.
+Which contains data stored in FIELDS. FIELDS is a list of symbols
+which are field names or pairs (FIELD INITIAL-VALUE) where
+INITIAL-VALUE is a constant used as the initial value of FIELD when
+the data structure is created. INITIAL-VALUE defaults to nil.
+
+This defines a `make-NAME' constructor, get-able `NAME-FIELD' and
+set-able `set-NAME-FIELD' accessors."
+ (let ((size (length fields))
+ (i 0)
+ accors field sufx fun ivals)
+ (while (< i size)
+ (setq field (car fields)
+ fields (cdr fields))
+ (if (consp field)
+ (setq ivals (cons (cadr field) ivals)
+ field (car field))
+ (setq ivals (cons nil ivals)))
+ (setq sufx (format "%s-%s" name field)
+ fun (intern (format "%s" sufx))
+ accors (cons `(defmacro ,fun (s)
+ (list 'aref s ,i))
+ accors)
+ fun (intern (format "set-%s" sufx))
+ accors (cons `(defmacro ,fun (s v)
+ (list 'aset s ,i v))
+ accors)
+ i (1+ i)))
+ `(progn
+ (defmacro ,(intern (format "make-%s" name)) ()
+ (cons 'vector ',(nreverse ivals)))
+ ,@accors)))
+(put 'wisent-struct 'lisp-indent-function 1)
+
+;; Other utilities
+
+(defsubst wisent-pad-string (s n &optional left)
+ "Fill string S with spaces.
+Return a new string of at least N characters. Insert spaces on right.
+If optional LEFT is non-nil insert spaces on left."
+ (let ((i (length s)))
+ (if (< i n)
+ (if left
+ (concat (make-string (- n i) ?\ ) s)
+ (concat s (make-string (- n i) ?\ )))
+ s)))
+
+;;;; ------------------------
+;;;; Environment dependencies
+;;;; ------------------------
+
+(defconst wisent-BITS-PER-WORD
+ (let ((i 1))
+ (while (not (zerop (lsh 1 i)))
+ (setq i (1+ i)))
+ i))
+
+(defsubst wisent-WORDSIZE (n)
+ "(N + BITS-PER-WORD - 1) / BITS-PER-WORD."
+ (/ (1- (+ n wisent-BITS-PER-WORD)) wisent-BITS-PER-WORD))
+
+(defsubst wisent-SETBIT (x i)
+ "X[I/BITS-PER-WORD] |= 1 << (I % BITS-PER-WORD)."
+ (let ((k (/ i wisent-BITS-PER-WORD)))
+ (aset x k (logior (aref x k)
+ (lsh 1 (% i wisent-BITS-PER-WORD))))))
+
+(defsubst wisent-RESETBIT (x i)
+ "X[I/BITS-PER-WORD] &= ~(1 << (I % BITS-PER-WORD))."
+ (let ((k (/ i wisent-BITS-PER-WORD)))
+ (aset x k (logand (aref x k)
+ (lognot (lsh 1 (% i wisent-BITS-PER-WORD)))))))
+
+(defsubst wisent-BITISSET (x i)
+ "(X[I/BITS-PER-WORD] & (1 << (I % BITS-PER-WORD))) != 0."
+ (not (zerop (logand (aref x (/ i wisent-BITS-PER-WORD))
+ (lsh 1 (% i wisent-BITS-PER-WORD))))))
+
+(eval-when-compile
+ (or (fboundp 'noninteractive)
+ ;; Silence the Emacs byte compiler
+ (defun noninteractive nil))
+ )
+
+(defsubst wisent-noninteractive ()
+ "Return non-nil if running without interactive terminal."
+ (if (featurep 'xemacs)
+ (noninteractive)
+ noninteractive))
+
+(defvar wisent-debug-flag nil
+ "Non-nil means enable some debug stuff.")
+
+;;;; --------------
+;;;; Logging/Output
+;;;; --------------
+(defconst wisent-log-buffer-name "*wisent-log*"
+ "Name of the log buffer.")
+
+(defvar wisent-new-log-flag nil
+ "Non-nil means to start a new report.")
+
+(defvar wisent-verbose-flag nil
+ "*Non-nil means to report verbose information on generated parser.")
+
+(defun wisent-toggle-verbose-flag ()
+ "Toggle whether to report verbose information on generated parser."
+ (interactive)
+ (setq wisent-verbose-flag (not wisent-verbose-flag))
+ (when (interactive-p)
+ (message "Verbose report %sabled"
+ (if wisent-verbose-flag "en" "dis"))))
+
+(defmacro wisent-log-buffer ()
+ "Return the log buffer.
+Its name is defined in constant `wisent-log-buffer-name'."
+ `(get-buffer-create wisent-log-buffer-name))
+
+(defmacro wisent-clear-log ()
+ "Delete the entire contents of the log buffer."
+ `(with-current-buffer (wisent-log-buffer)
+ (erase-buffer)))
+
+(eval-when-compile (defvar byte-compile-current-file))
+
+(defun wisent-source ()
+ "Return the current source file name or nil."
+ (let ((source (or (and (boundp 'byte-compile-current-file)
+ byte-compile-current-file)
+ load-file-name (buffer-file-name))))
+ (if source
+ (file-relative-name source))))
+
+(defun wisent-new-log ()
+ "Start a new entry into the log buffer."
+ (setq wisent-new-log-flag nil)
+ (let ((text (format "\n\n*** Wisent %s - %s\n\n"
+ (or (wisent-source) (buffer-name))
+ (format-time-string "%Y-%m-%d %R"))))
+ (with-current-buffer (wisent-log-buffer)
+ (goto-char (point-max))
+ (insert text))))
+
+(defsubst wisent-log (&rest args)
+ "Insert text into the log buffer.
+`format' is applied to ARGS and the result string is inserted into the
+log buffer returned by the function `wisent-log-buffer'."
+ (and wisent-new-log-flag (wisent-new-log))
+ (with-current-buffer (wisent-log-buffer)
+ (insert (apply 'format args))))
+
+(defconst wisent-log-file "wisent.output"
+ "The log file.
+Used when running without interactive terminal.")
+
+(defun wisent-append-to-log-file ()
+ "Append contents of logging buffer to `wisent-log-file'."
+ (if (get-buffer wisent-log-buffer-name)
+ (condition-case err
+ (with-current-buffer (wisent-log-buffer)
+ (widen)
+ (if (> (point-max) (point-min))
+ (write-region (point-min) (point-max)
+ wisent-log-file t)))
+ (error
+ (message "*** %s" (error-message-string err))))))
+
+;;;; -----------------------------------
+;;;; Representation of the grammar rules
+;;;; -----------------------------------
+
+;; ntokens is the number of tokens, and nvars is the number of
+;; variables (nonterminals). nsyms is the total number, ntokens +
+;; nvars.
+
+;; Each symbol (either token or variable) receives a symbol number.
+;; Numbers 0 to ntokens-1 are for tokens, and ntokens to nsyms-1 are
+;; for variables. Symbol number zero is the end-of-input token. This
+;; token is counted in ntokens.
+
+;; The rules receive rule numbers 1 to nrules in the order they are
+;; written. Actions and guards are accessed via the rule number.
+
+;; The rules themselves are described by three arrays: rrhs, rlhs and
+;; ritem. rlhs[R] is the symbol number of the left hand side of rule
+;; R. The right hand side is stored as symbol numbers in a portion of
+;; ritem. rrhs[R] contains the index in ritem of the beginning of the
+;; portion for rule R.
+
+;; The length of the portion is one greater than the number of symbols
+;; in the rule's right hand side. The last element in the portion
+;; contains minus R, which identifies it as the end of a portion and
+;; says which rule it is for.
+
+;; The portions of ritem come in order of increasing rule number and
+;; are followed by an element which is nil to mark the end. nitems is
+;; the total length of ritem, not counting the final nil. Each
+;; element of ritem is called an "item" and its index in ritem is an
+;; item number.
+
+;; Item numbers are used in the finite state machine to represent
+;; places that parsing can get to.
+
+;; The vector rprec contains for each rule, the item number of the
+;; symbol giving its precedence level to this rule. The precedence
+;; level and associativity of each symbol is recorded in respectively
+;; the properties 'wisent--prec and 'wisent--assoc.
+
+;; Precedence levels are assigned in increasing order starting with 1
+;; so that numerically higher precedence values mean tighter binding
+;; as they ought to. nil as a symbol or rule's precedence means none
+;; is assigned.
+
+(defcustom wisent-state-table-size 1009
+ "The size of the state table."
+ :type 'integer
+ :group 'wisent)
+
+;; These variables only exist locally in the function
+;; `wisent-compile-grammar' and are shared by all other nested
+;; callees.
+(wisent-defcontext compile-grammar
+ F LA LAruleno accessing-symbol conflicts consistent default-prec
+ derives err-table fderives final-state first-reduction first-shift
+ first-state firsts from-state goto-map includes itemset nitemset
+ kernel-base kernel-end kernel-items last-reduction last-shift
+ last-state lookaheads lookaheadset lookback maxrhs ngotos nitems
+ nrules nshifts nstates nsyms ntokens nullable nvars rassoc redset
+ reduction-table ritem rlhs rprec rrc-count rrc-total rrhs ruseful
+ rcode ruleset rulesetsize shift-symbol shift-table shiftset
+ src-count src-total start-table state-table tags this-state to-state
+ tokensetsize ;; nb of words req. to hold a bit for each rule
+ varsetsize ;; nb of words req. to hold a bit for each variable
+ error-token-number start-symbol token-list var-list
+ N P V V1 nuseless-nonterminals nuseless-productions
+ ptable ;; symbols & characters properties
+ )
+
+(defmacro wisent-ISTOKEN (s)
+ "Return non-nil if item number S defines a token (terminal).
+That is if S < `ntokens'."
+ `(< ,s ntokens))
+
+(defmacro wisent-ISVAR(s)
+ "Return non-nil if item number S defines a nonterminal.
+That is if S >= `ntokens'."
+ `(>= ,s ntokens))
+
+(defsubst wisent-tag (s)
+ "Return printable form of item number S."
+ (wisent-item-to-string (aref tags s)))
+
+;; Symbol and character properties
+
+(defsubst wisent-put (object propname value)
+ "Store OBJECT's PROPNAME property with value VALUE.
+Use `eq' to locate OBJECT."
+ (let ((entry (assq object ptable)))
+ (or entry (setq entry (list object) ptable (cons entry ptable)))
+ (setcdr entry (plist-put (cdr entry) propname value))))
+
+(defsubst wisent-get (object propname)
+ "Return the value of OBJECT's PROPNAME property.
+Use `eq' to locate OBJECT."
+ (plist-get (cdr (assq object ptable)) propname))
+
+(defsubst wisent-item-number (x)
+ "Return the item number of symbol X."
+ (wisent-get x 'wisent--item-no))
+
+(defsubst wisent-set-item-number (x n)
+ "Set the item number of symbol X to N."
+ (wisent-put x 'wisent--item-no n))
+
+(defsubst wisent-assoc (x)
+ "Return the associativity of symbol X."
+ (wisent-get x 'wisent--assoc))
+
+(defsubst wisent-set-assoc (x a)
+ "Set the associativity of symbol X to A."
+ (wisent-put x 'wisent--assoc a))
+
+(defsubst wisent-prec (x)
+ "Return the precedence level of symbol X."
+ (wisent-get x 'wisent--prec))
+
+(defsubst wisent-set-prec (x p)
+ "Set the precedence level of symbol X to P."
+ (wisent-put x 'wisent--prec p))
+
+;;;; ----------------------------------------------------------
+;;;; Type definitions for nondeterministic finite state machine
+;;;; ----------------------------------------------------------
+
+;; These type definitions are used to represent a nondeterministic
+;; finite state machine that parses the specified grammar. This
+;; information is generated by the function `wisent-generate-states'.
+
+;; Each state of the machine is described by a set of items --
+;; particular positions in particular rules -- that are the possible
+;; places where parsing could continue when the machine is in this
+;; state. These symbols at these items are the allowable inputs that
+;; can follow now.
+
+;; A core represents one state. States are numbered in the number
+;; field. When `wisent-generate-states' is finished, the starting
+;; state is state 0 and `nstates' is the number of states. (A
+;; transition to a state whose state number is `nstates' indicates
+;; termination.) All the cores are chained together and `first-state'
+;; points to the first one (state 0).
+
+;; For each state there is a particular symbol which must have been
+;; the last thing accepted to reach that state. It is the
+;; accessing-symbol of the core.
+
+;; Each core contains a vector of `nitems' items which are the indices
+;; in the `ritems' vector of the items that are selected in this
+;; state.
+
+;; The link field is used for chaining buckets that hash states by
+;; their itemsets. This is for recognizing equivalent states and
+;; combining them when the states are generated.
+
+;; The two types of transitions are shifts (push the lookahead token
+;; and read another) and reductions (combine the last n things on the
+;; stack via a rule, replace them with the symbol that the rule
+;; derives, and leave the lookahead token alone). When the states are
+;; generated, these transitions are represented in two other lists.
+
+;; Each shifts structure describes the possible shift transitions out
+;; of one state, the state whose number is in the number field. The
+;; shifts structures are linked through next and first-shift points to
+;; them. Each contains a vector of numbers of the states that shift
+;; transitions can go to. The accessing-symbol fields of those
+;; states' cores say what kind of input leads to them.
+
+;; A shift to state zero should be ignored. Conflict resolution
+;; deletes shifts by changing them to zero.
+
+;; Each reductions structure describes the possible reductions at the
+;; state whose number is in the number field. The data is a list of
+;; nreds rules, represented by their rule numbers. `first-reduction'
+;; points to the list of these structures.
+
+;; Conflict resolution can decide that certain tokens in certain
+;; states should explicitly be errors (for implementing %nonassoc).
+;; For each state, the tokens that are errors for this reason are
+;; recorded in an errs structure, which has the state number in its
+;; number field. The rest of the errs structure is full of token
+;; numbers.
+
+;; There is at least one shift transition present in state zero. It
+;; leads to a next-to-final state whose accessing-symbol is the
+;; grammar's start symbol. The next-to-final state has one shift to
+;; the final state, whose accessing-symbol is zero (end of input).
+;; The final state has one shift, which goes to the termination state
+;; (whose number is `nstates'-1).
+;; The reason for the extra state at the end is to placate the
+;; parser's strategy of making all decisions one token ahead of its
+;; actions.
+
+(wisent-struct core
+ next ; -> core
+ link ; -> core
+ (number 0)
+ (accessing-symbol 0)
+ (nitems 0)
+ (items [0]))
+
+(wisent-struct shifts
+ next ; -> shifts
+ (number 0)
+ (nshifts 0)
+ (shifts [0]))
+
+(wisent-struct reductions
+ next ; -> reductions
+ (number 0)
+ (nreds 0)
+ (rules [0]))
+
+(wisent-struct errs
+ (nerrs 0)
+ (errs [0]))
+
+;;;; --------------------------------------------------------
+;;;; Find unreachable terminals, nonterminals and productions
+;;;; --------------------------------------------------------
+
+(defun wisent-bits-equal (L R n)
+ "Visit L and R and return non-nil if their first N elements are `='.
+L and R must be vectors of integers."
+ (let* ((i (1- n))
+ (iseq t))
+ (while (and iseq (natnump i))
+ (setq iseq (= (aref L i) (aref R i))
+ i (1- i)))
+ iseq))
+
+(defun wisent-nbits (i)
+ "Return number of bits set in integer I."
+ (let ((count 0))
+ (while (not (zerop i))
+ ;; i ^= (i & ((unsigned) (-(int) i)))
+ (setq i (logxor i (logand i (- i)))
+ count (1+ count)))
+ count))
+
+(defun wisent-bits-size (S n)
+ "In vector S count the total of bits set in first N elements.
+S must be a vector of integers."
+ (let* ((i (1- n))
+ (count 0))
+ (while (natnump i)
+ (setq count (+ count (wisent-nbits (aref S i)))
+ i (1- i)))
+ count))
+
+(defun wisent-useful-production (i N0)
+ "Return non-nil if production I is in useful set N0."
+ (let* ((useful t)
+ (r (aref rrhs i))
+ n)
+ (while (and useful (> (setq n (aref ritem r)) 0))
+ (if (wisent-ISVAR n)
+ (setq useful (wisent-BITISSET N0 (- n ntokens))))
+ (setq r (1+ r)))
+ useful))
+
+(defun wisent-useless-nonterminals ()
+ "Find out which nonterminals are used."
+ (let (Np Ns i n break)
+ ;; N is set as built. Np is set being built this iteration. P is
+ ;; set of all productions which have a RHS all in N.
+ (setq n (wisent-WORDSIZE nvars)
+ Np (make-vector n 0))
+
+ ;; The set being computed is a set of nonterminals which can
+ ;; derive the empty string or strings consisting of all
+ ;; terminals. At each iteration a nonterminal is added to the set
+ ;; if there is a production with that nonterminal as its LHS for
+ ;; which all the nonterminals in its RHS are already in the set.
+ ;; Iterate until the set being computed remains unchanged. Any
+ ;; nonterminals not in the set at that point are useless in that
+ ;; they will never be used in deriving a sentence of the language.
+
+ ;; This iteration doesn't use any special traversal over the
+ ;; productions. A set is kept of all productions for which all
+ ;; the nonterminals in the RHS are in useful. Only productions
+ ;; not in this set are scanned on each iteration. At the end,
+ ;; this set is saved to be used when finding useful productions:
+ ;; only productions in this set will appear in the final grammar.
+
+ (while (not break)
+ (setq i (1- n))
+ (while (natnump i)
+ ;; Np[i] = N[i]
+ (aset Np i (aref N i))
+ (setq i (1- i)))
+
+ (setq i 1)
+ (while (<= i nrules)
+ (if (not (wisent-BITISSET P i))
+ (when (wisent-useful-production i N)
+ (wisent-SETBIT Np (- (aref rlhs i) ntokens))
+ (wisent-SETBIT P i)))
+ (setq i (1+ i)))
+ (if (wisent-bits-equal N Np n)
+ (setq break t)
+ (setq Ns Np
+ Np N
+ N Ns)))
+ (setq N Np)))
+
+(defun wisent-inaccessable-symbols ()
+ "Find out which productions are reachable and which symbols are used."
+ ;; Starting with an empty set of productions and a set of symbols
+ ;; which only has the start symbol in it, iterate over all
+ ;; productions until the set of productions remains unchanged for an
+ ;; iteration. For each production which has a LHS in the set of
+ ;; reachable symbols, add the production to the set of reachable
+ ;; productions, and add all of the nonterminals in the RHS of the
+ ;; production to the set of reachable symbols.
+
+ ;; Consider only the (partially) reduced grammar which has only
+ ;; nonterminals in N and productions in P.
+
+ ;; The result is the set P of productions in the reduced grammar,
+ ;; and the set V of symbols in the reduced grammar.
+
+ ;; Although this algorithm also computes the set of terminals which
+ ;; are reachable, no terminal will be deleted from the grammar. Some
+ ;; terminals might not be in the grammar but might be generated by
+ ;; semantic routines, and so the user might want them available with
+ ;; specified numbers. (Is this true?) However, the non reachable
+ ;; terminals are printed (if running in verbose mode) so that the
+ ;; user can know.
+ (let (Vp Vs Pp i tt r n m break)
+ (setq n (wisent-WORDSIZE nsyms)
+ m (wisent-WORDSIZE (1+ nrules))
+ Vp (make-vector n 0)
+ Pp (make-vector m 0))
+
+ ;; If the start symbol isn't useful, then nothing will be useful.
+ (when (wisent-BITISSET N (- start-symbol ntokens))
+ (wisent-SETBIT V start-symbol)
+ (while (not break)
+ (setq i (1- n))
+ (while (natnump i)
+ (aset Vp i (aref V i))
+ (setq i (1- i)))
+ (setq i 1)
+ (while (<= i nrules)
+ (when (and (not (wisent-BITISSET Pp i))
+ (wisent-BITISSET P i)
+ (wisent-BITISSET V (aref rlhs i)))
+ (setq r (aref rrhs i))
+ (while (natnump (setq tt (aref ritem r)))
+ (if (or (wisent-ISTOKEN tt)
+ (wisent-BITISSET N (- tt ntokens)))
+ (wisent-SETBIT Vp tt))
+ (setq r (1+ r)))
+ (wisent-SETBIT Pp i))
+ (setq i (1+ i)))
+ (if (wisent-bits-equal V Vp n)
+ (setq break t)
+ (setq Vs Vp
+ Vp V
+ V Vs))))
+ (setq V Vp)
+
+ ;; Tokens 0, 1 are internal to Wisent. Consider them useful.
+ (wisent-SETBIT V 0) ;; end-of-input token
+ (wisent-SETBIT V 1) ;; error token
+ (setq P Pp)
+
+ (setq nuseless-productions (- nrules (wisent-bits-size P m))
+ nuseless-nonterminals nvars
+ i ntokens)
+ (while (< i nsyms)
+ (if (wisent-BITISSET V i)
+ (setq nuseless-nonterminals (1- nuseless-nonterminals)))
+ (setq i (1+ i)))
+
+ ;; A token that was used in %prec should not be warned about.
+ (setq i 1)
+ (while (<= i nrules)
+ (if (aref rprec i)
+ (wisent-SETBIT V1 (aref rprec i)))
+ (setq i (1+ i)))
+ ))
+
+(defun wisent-reduce-grammar-tables ()
+ "Disable useless productions."
+ (if (> nuseless-productions 0)
+ (let ((pn 1))
+ (while (<= pn nrules)
+ (aset ruseful pn (wisent-BITISSET P pn))
+ (setq pn (1+ pn))))))
+
+(defun wisent-nonterminals-reduce ()
+ "Remove useless nonterminals."
+ (let (i n r item nontermmap tags-sorted)
+ ;; Map the nonterminals to their new index: useful first, useless
+ ;; afterwards. Kept for later report.
+ (setq nontermmap (make-vector nvars 0)
+ n ntokens
+ i ntokens)
+ (while (< i nsyms)
+ (when (wisent-BITISSET V i)
+ (aset nontermmap (- i ntokens) n)
+ (setq n (1+ n)))
+ (setq i (1+ i)))
+ (setq i ntokens)
+ (while (< i nsyms)
+ (unless (wisent-BITISSET V i)
+ (aset nontermmap (- i ntokens) n)
+ (setq n (1+ n)))
+ (setq i (1+ i)))
+ ;; Shuffle elements of tables indexed by symbol number
+ (setq tags-sorted (make-vector nvars nil)
+ i ntokens)
+ (while (< i nsyms)
+ (setq n (aref nontermmap (- i ntokens)))
+ (aset tags-sorted (- n ntokens) (aref tags i))
+ (setq i (1+ i)))
+ (setq i ntokens)
+ (while (< i nsyms)
+ (aset tags i (aref tags-sorted (- i ntokens)))
+ (setq i (1+ i)))
+ ;; Replace all symbol numbers in valid data structures.
+ (setq i 1)
+ (while (<= i nrules)
+ (aset rlhs i (aref nontermmap (- (aref rlhs i) ntokens)))
+ (setq i (1+ i)))
+ (setq r 0)
+ (while (setq item (aref ritem r))
+ (if (wisent-ISVAR item)
+ (aset ritem r (aref nontermmap (- item ntokens))))
+ (setq r (1+ r)))
+ (setq start-symbol (aref nontermmap (- start-symbol ntokens))
+ nsyms (- nsyms nuseless-nonterminals)
+ nvars (- nvars nuseless-nonterminals))
+ ))
+
+(defun wisent-total-useless ()
+ "Report number of useless nonterminals and productions."
+ (let* ((src (wisent-source))
+ (src (if src (concat " in " src) ""))
+ (msg (format "Grammar%s contains" src)))
+ (if (> nuseless-nonterminals 0)
+ (setq msg (format "%s %d useless nonterminal%s"
+ msg nuseless-nonterminals
+ (if (> nuseless-nonterminals 0) "s" ""))))
+ (if (and (> nuseless-nonterminals 0) (> nuseless-productions 0))
+ (setq msg (format "%s and" msg)))
+ (if (> nuseless-productions 0)
+ (setq msg (format "%s %d useless rule%s"
+ msg nuseless-productions
+ (if (> nuseless-productions 0) "s" ""))))
+ (message msg)))
+
+(defun wisent-reduce-grammar ()
+ "Find unreachable terminals, nonterminals and productions."
+ ;; Allocate the global sets used to compute the reduced grammar
+ (setq N (make-vector (wisent-WORDSIZE nvars) 0)
+ P (make-vector (wisent-WORDSIZE (1+ nrules)) 0)
+ V (make-vector (wisent-WORDSIZE nsyms) 0)
+ V1 (make-vector (wisent-WORDSIZE nsyms) 0)
+ nuseless-nonterminals 0
+ nuseless-productions 0)
+
+ (wisent-useless-nonterminals)
+ (wisent-inaccessable-symbols)
+
+ (when (> (+ nuseless-nonterminals nuseless-productions) 0)
+ (wisent-total-useless)
+ (or (wisent-BITISSET N (- start-symbol ntokens))
+ (error "Start symbol `%s' does not derive any sentence"
+ (wisent-tag start-symbol)))
+ (wisent-reduce-grammar-tables)
+ (if (> nuseless-nonterminals 0)
+ (wisent-nonterminals-reduce))))
+
+(defun wisent-print-useless ()
+ "Output the detailed results of the reductions."
+ (let (i b r)
+ (when (> nuseless-nonterminals 0)
+ ;; Useless nonterminals have been moved after useful ones.
+ (wisent-log "\n\nUseless nonterminals:\n\n")
+ (setq i 0)
+ (while (< i nuseless-nonterminals)
+ (wisent-log " %s\n" (wisent-tag (+ nsyms i)))
+ (setq i (1+ i))))
+ (setq b nil
+ i 0)
+ (while (< i ntokens)
+ (unless (or (wisent-BITISSET V i) (wisent-BITISSET V1 i))
+ (or b
+ (wisent-log "\n\nTerminals which are not used:\n\n"))
+ (setq b t)
+ (wisent-log " %s\n" (wisent-tag i)))
+ (setq i (1+ i)))
+ (when (> nuseless-productions 0)
+ (wisent-log "\n\nUseless rules:\n\n")
+ (setq i 1)
+ (while (<= i nrules)
+ (unless (aref ruseful i)
+ (wisent-log "#%s " (wisent-pad-string (format "%d" i) 4))
+ (wisent-log "%s:" (wisent-tag (aref rlhs i)))
+ (setq r (aref rrhs i))
+ (while (natnump (aref ritem r))
+ (wisent-log " %s" (wisent-tag (aref ritem r)))
+ (setq r (1+ r)))
+ (wisent-log ";\n"))
+ (setq i (1+ i))))
+ (if (or b (> nuseless-nonterminals 0) (> nuseless-productions 0))
+ (wisent-log "\n\n"))
+ ))
+
+;;;; -----------------------------
+;;;; Match rules with nonterminals
+;;;; -----------------------------
+
+(defun wisent-set-derives ()
+ "Find, for each variable (nonterminal), which rules can derive it.
+It sets up the value of DERIVES so that DERIVES[i - NTOKENS] points to
+a list of rule numbers, terminated with -1."
+ (let (i lhs p q dset delts)
+ (setq dset (make-vector nvars nil)
+ delts (make-vector (1+ nrules) 0))
+ (setq p 0 ;; p = delts
+ i nrules)
+ (while (> i 0)
+ (when (aref ruseful i)
+ (setq lhs (aref rlhs i))
+ ;; p->next = dset[lhs];
+ ;; p->value = i;
+ (aset delts p (cons i (aref dset (- lhs ntokens)))) ;; (value . next)
+ (aset dset (- lhs ntokens) p) ;; dset[lhs] = p
+ (setq p (1+ p)) ;; p++
+ )
+ (setq i (1- i)))
+
+ (setq derives (make-vector nvars nil)
+ i ntokens)
+
+ (while (< i nsyms)
+ (setq q nil
+ p (aref dset (- i ntokens))) ;; p = dset[i]
+
+ (while p
+ (setq p (aref delts p)
+ q (cons (car p) q) ;;q++ = p->value
+ p (cdr p))) ;; p = p->next
+ (setq q (nreverse (cons -1 q))) ;; *q++ = -1
+ (aset derives (- i ntokens) q) ;; derives[i] = q
+ (setq i (1+ i)))
+ ))
+
+;;;; --------------------------------------------------------
+;;;; Find which nonterminals can expand into the null string.
+;;;; --------------------------------------------------------
+
+(defun wisent-print-nullable ()
+ "Print NULLABLE."
+ (let (i)
+ (wisent-log "NULLABLE\n")
+ (setq i ntokens)
+ (while (< i nsyms)
+ (wisent-log "\t%s: %s\n" (wisent-tag i)
+ (if (aref nullable (- i ntokens))
+ "yes" : "no"))
+ (setq i (1+ i)))
+ (wisent-log "\n\n")))
+
+(defun wisent-set-nullable ()
+ "Set up NULLABLE.
+A vector saying which nonterminals can expand into the null string.
+NULLABLE[i - NTOKENS] is nil if symbol I can do so."
+ (let (ruleno s1 s2 p r squeue rcount rsets relts item any-tokens)
+ (setq squeue (make-vector nvars 0)
+ rcount (make-vector (1+ nrules) 0)
+ rsets (make-vector nvars nil) ;; - ntokens
+ relts (make-vector (+ nitems nvars 1) nil)
+ nullable (make-vector nvars nil)) ;; - ntokens
+ (setq s1 0 s2 0 ;; s1 = s2 = squeue
+ p 0 ;; p = relts
+ ruleno 1)
+ (while (<= ruleno nrules)
+ (when (aref ruseful ruleno)
+ (if (> (aref ritem (aref rrhs ruleno)) 0)
+ (progn
+ ;; This rule has a non empty RHS.
+ (setq any-tokens nil
+ r (aref rrhs ruleno))
+ (while (> (aref ritem r) 0)
+ (if (wisent-ISTOKEN (aref ritem r))
+ (setq any-tokens t))
+ (setq r (1+ r)))
+
+ ;; This rule has only nonterminals: schedule it for the
+ ;; second pass.
+ (unless any-tokens
+ (setq r (aref rrhs ruleno))
+ (while (> (setq item (aref ritem r)) 0)
+ (aset rcount ruleno (1+ (aref rcount ruleno)))
+ ;; p->next = rsets[item];
+ ;; p->value = ruleno;
+ (aset relts p (cons ruleno (aref rsets (- item ntokens))))
+ ;; rsets[item] = p;
+ (aset rsets (- item ntokens) p)
+ (setq p (1+ p)
+ r (1+ r)))))
+ ;; This rule has an empty RHS.
+ ;; assert (ritem[rrhs[ruleno]] == -ruleno)
+ (when (and (aref ruseful ruleno)
+ (setq item (aref rlhs ruleno))
+ (not (aref nullable (- item ntokens))))
+ (aset nullable (- item ntokens) t)
+ (aset squeue s2 item)
+ (setq s2 (1+ s2)))
+ )
+ )
+ (setq ruleno (1+ ruleno)))
+
+ (while (< s1 s2)
+ ;; p = rsets[*s1++]
+ (setq p (aref rsets (- (aref squeue s1) ntokens))
+ s1 (1+ s1))
+ (while p
+ (setq p (aref relts p)
+ ruleno (car p)
+ p (cdr p)) ;; p = p->next
+ ;; if (--rcount[ruleno] == 0)
+ (when (zerop (aset rcount ruleno (1- (aref rcount ruleno))))
+ (setq item (aref rlhs ruleno))
+ (aset nullable (- item ntokens) t)
+ (aset squeue s2 item)
+ (setq s2 (1+ s2)))))
+
+ (if wisent-debug-flag
+ (wisent-print-nullable))
+ ))
+
+;;;; -----------
+;;;; Subroutines
+;;;; -----------
+
+(defun wisent-print-fderives ()
+ "Print FDERIVES."
+ (let (i j rp)
+ (wisent-log "\n\n\nFDERIVES\n")
+ (setq i ntokens)
+ (while (< i nsyms)
+ (wisent-log "\n\n%s derives\n\n" (wisent-tag i))
+ (setq rp (aref fderives (- i ntokens))
+ j 0)
+ (while (<= j nrules)
+ (if (wisent-BITISSET rp j)
+ (wisent-log " %d\n" j))
+ (setq j (1+ j)))
+ (setq i (1+ i)))))
+
+(defun wisent-set-fderives ()
+ "Set up FDERIVES.
+An NVARS by NRULES matrix of bits indicating which rules can help
+derive the beginning of the data for each nonterminal. For example,
+if symbol 5 can be derived as the sequence of symbols 8 3 20, and one
+of the rules for deriving symbol 8 is rule 4, then the
+\[5 - NTOKENS, 4] bit in FDERIVES is set."
+ (let (i j k)
+ (setq fderives (make-vector nvars nil))
+ (setq i 0)
+ (while (< i nvars)
+ (aset fderives i (make-vector rulesetsize 0))
+ (setq i (1+ i)))
+
+ (wisent-set-firsts)
+
+ (setq i ntokens)
+ (while (< i nsyms)
+ (setq j ntokens)
+ (while (< j nsyms)
+ ;; if (BITISSET (FIRSTS (i), j - ntokens))
+ (when (wisent-BITISSET (aref firsts (- i ntokens)) (- j ntokens))
+ (setq k (aref derives (- j ntokens)))
+ (while (> (car k) 0) ;; derives[j][k] > 0
+ ;; SETBIT (FDERIVES (i), derives[j][k]);
+ (wisent-SETBIT (aref fderives (- i ntokens)) (car k))
+ (setq k (cdr k))))
+ (setq j (1+ j)))
+ (setq i (1+ i)))
+
+ (if wisent-debug-flag
+ (wisent-print-fderives))
+ ))
+
+(defun wisent-print-firsts ()
+ "Print FIRSTS."
+ (let (i j v)
+ (wisent-log "\n\n\nFIRSTS\n\n")
+ (setq i ntokens)
+ (while (< i nsyms)
+ (wisent-log "\n\n%s firsts\n\n" (wisent-tag i))
+ (setq v (aref firsts (- i ntokens))
+ j 0)
+ (while (< j nvars)
+ (if (wisent-BITISSET v j)
+ (wisent-log "\t\t%d (%s)\n"
+ (+ j ntokens) (wisent-tag (+ j ntokens))))
+ (setq j (1+ j)))
+ (setq i (1+ i)))))
+
+(defun wisent-TC (R n)
+ "Transitive closure.
+Given R an N by N matrix of bits, modify its contents to be the
+transitive closure of what was given."
+ (let (i j k)
+ ;; R (J, I) && R (I, K) => R (J, K).
+ ;; I *must* be the outer loop.
+ (setq i 0)
+ (while (< i n)
+ (setq j 0)
+ (while (< j n)
+ (when (wisent-BITISSET (aref R j) i)
+ (setq k 0)
+ (while (< k n)
+ (if (wisent-BITISSET (aref R i) k)
+ (wisent-SETBIT (aref R j) k))
+ (setq k (1+ k))))
+ (setq j (1+ j)))
+ (setq i (1+ i)))))
+
+(defun wisent-RTC (R n)
+ "Reflexive Transitive Closure.
+Same as `wisent-TC' and then set all the bits on the diagonal of R, an
+N by N matrix of bits."
+ (let (i)
+ (wisent-TC R n)
+ (setq i 0)
+ (while (< i n)
+ (wisent-SETBIT (aref R i) i)
+ (setq i (1+ i)))))
+
+(defun wisent-set-firsts ()
+ "Set up FIRSTS.
+An NVARS by NVARS bit matrix indicating which items can represent the
+beginning of the input corresponding to which other items. For
+example, if some rule expands symbol 5 into the sequence of symbols 8
+3 20, the symbol 8 can be the beginning of the data for symbol 5, so
+the bit [8 - NTOKENS, 5 - NTOKENS] in FIRSTS is set."
+ (let (row symbol sp rowsize i)
+ (setq rowsize (wisent-WORDSIZE nvars)
+ varsetsize rowsize
+ firsts (make-vector nvars nil)
+ i 0)
+ (while (< i nvars)
+ (aset firsts i (make-vector rowsize 0))
+ (setq i (1+ i)))
+
+ (setq row 0 ;; row = firsts
+ i ntokens)
+ (while (< i nsyms)
+ (setq sp (aref derives (- i ntokens)))
+ (while (>= (car sp) 0)
+ (setq symbol (aref ritem (aref rrhs (car sp)))
+ sp (cdr sp))
+ (when (wisent-ISVAR symbol)
+ (setq symbol (- symbol ntokens))
+ (wisent-SETBIT (aref firsts row) symbol)
+ ))
+ (setq row (1+ row)
+ i (1+ i)))
+
+ (wisent-RTC firsts nvars)
+
+ (if wisent-debug-flag
+ (wisent-print-firsts))
+ ))
+
+(defun wisent-initialize-closure (n)
+ "Allocate the ITEMSET and RULESET vectors.
+And precompute useful data so that `wisent-closure' can be called.
+N is the number of elements to allocate for ITEMSET."
+ (setq itemset (make-vector n 0)
+ rulesetsize (wisent-WORDSIZE (1+ nrules))
+ ruleset (make-vector rulesetsize 0))
+
+ (wisent-set-fderives))
+
+(defun wisent-print-closure ()
+ "Print ITEMSET."
+ (let (i)
+ (wisent-log "\n\nclosure n = %d\n\n" nitemset)
+ (setq i 0) ;; isp = itemset
+ (while (< i nitemset)
+ (wisent-log " %d\n" (aref itemset i))
+ (setq i (1+ i)))))
+
+(defun wisent-closure (core n)
+ "Set up RULESET and ITEMSET for the transitions out of CORE state.
+Given a vector of item numbers items, of length N, set up RULESET and
+ITEMSET to indicate what rules could be run and which items could be
+accepted when those items are the active ones.
+
+RULESET contains a bit for each rule. `wisent-closure' sets the bits
+for all rules which could potentially describe the next input to be
+read.
+
+ITEMSET is a vector of item numbers; NITEMSET is the number of items
+in ITEMSET. `wisent-closure' places there the indices of all items
+which represent units of input that could arrive next."
+ (let (c r v symbol ruleno itemno)
+ (if (zerop n)
+ (progn
+ (setq r 0
+ v (aref fderives (- start-symbol ntokens)))
+ (while (< r rulesetsize)
+ ;; ruleset[r] = FDERIVES (start-symbol)[r];
+ (aset ruleset r (aref v r))
+ (setq r (1+ r)))
+ )
+ (fillarray ruleset 0)
+ (setq c 0)
+ (while (< c n)
+ (setq symbol (aref ritem (aref core c)))
+ (when (wisent-ISVAR symbol)
+ (setq r 0
+ v (aref fderives (- symbol ntokens)))
+ (while (< r rulesetsize)
+ ;; ruleset[r] |= FDERIVES (ritem[core[c]])[r];
+ (aset ruleset r (logior (aref ruleset r) (aref v r)))
+ (setq r (1+ r))))
+ (setq c (1+ c)))
+ )
+ (setq nitemset 0
+ c 0
+ ruleno 0
+ r (* rulesetsize wisent-BITS-PER-WORD))
+ (while (< ruleno r)
+ (when (wisent-BITISSET ruleset ruleno)
+ (setq itemno (aref rrhs ruleno))
+ (while (and (< c n) (< (aref core c) itemno))
+ (aset itemset nitemset (aref core c))
+ (setq nitemset (1+ nitemset)
+ c (1+ c)))
+ (aset itemset nitemset itemno)
+ (setq nitemset (1+ nitemset)))
+ (setq ruleno (1+ ruleno)))
+
+ (while (< c n)
+ (aset itemset nitemset (aref core c))
+ (setq nitemset (1+ nitemset)
+ c (1+ c)))
+
+ (if wisent-debug-flag
+ (wisent-print-closure))
+ ))
+
+;;;; --------------------------------------------------
+;;;; Generate the nondeterministic finite state machine
+;;;; --------------------------------------------------
+
+(defun wisent-allocate-itemsets ()
+ "Allocate storage for itemsets."
+ (let (symbol i count symbol-count)
+ ;; Count the number of occurrences of all the symbols in RITEMS.
+ ;; Note that useless productions (hence useless nonterminals) are
+ ;; browsed too, hence we need to allocate room for _all_ the
+ ;; symbols.
+ (setq count 0
+ symbol-count (make-vector (+ nsyms nuseless-nonterminals) 0)
+ i 0)
+ (while (setq symbol (aref ritem i))
+ (when (> symbol 0)
+ (setq count (1+ count))
+ (aset symbol-count symbol (1+ (aref symbol-count symbol))))
+ (setq i (1+ i)))
+ ;; See comments before `wisent-new-itemsets'. All the vectors of
+ ;; items live inside kernel-items. The number of active items
+ ;; after some symbol cannot be more than the number of times that
+ ;; symbol appears as an item, which is symbol-count[symbol]. We
+ ;; allocate that much space for each symbol.
+ (setq kernel-base (make-vector nsyms nil)
+ kernel-items (make-vector count 0)
+ count 0
+ i 0)
+ (while (< i nsyms)
+ (aset kernel-base i count)
+ (setq count (+ count (aref symbol-count i))
+ i (1+ i)))
+ (setq shift-symbol symbol-count
+ kernel-end (make-vector nsyms nil))
+ ))
+
+(defun wisent-allocate-storage ()
+ "Allocate storage for the state machine."
+ (wisent-allocate-itemsets)
+ (setq shiftset (make-vector nsyms 0)
+ redset (make-vector (1+ nrules) 0)
+ state-table (make-vector wisent-state-table-size nil)))
+
+(defun wisent-new-itemsets ()
+ "Find which symbols can be shifted in the current state.
+And for each one record which items would be active after that shift.
+Uses the contents of ITEMSET. SHIFT-SYMBOL is set to a vector of the
+symbols that can be shifted. For each symbol in the grammar,
+KERNEL-BASE[symbol] points to a vector of item numbers activated if
+that symbol is shifted, and KERNEL-END[symbol] points after the end of
+that vector."
+ (let (i shiftcount isp ksp symbol)
+ (fillarray kernel-end nil)
+ (setq shiftcount 0
+ isp 0)
+ (while (< isp nitemset)
+ (setq i (aref itemset isp)
+ isp (1+ isp)
+ symbol (aref ritem i))
+ (when (> symbol 0)
+ (setq ksp (aref kernel-end symbol))
+ (when (not ksp)
+ ;; shift-symbol[shiftcount++] = symbol;
+ (aset shift-symbol shiftcount symbol)
+ (setq shiftcount (1+ shiftcount)
+ ksp (aref kernel-base symbol)))
+ ;; *ksp++ = i + 1;
+ (aset kernel-items ksp (1+ i))
+ (setq ksp (1+ ksp))
+ (aset kernel-end symbol ksp)))
+ (setq nshifts shiftcount)))
+
+(defun wisent-new-state (symbol)
+ "Create a new state for those items, if necessary.
+SYMBOL is the core accessing-symbol.
+Subroutine of `wisent-get-state'."
+ (let (n p isp1 isp2 iend items)
+ (setq isp1 (aref kernel-base symbol)
+ iend (aref kernel-end symbol)
+ n (- iend isp1)
+ p (make-core)
+ items (make-vector n 0))
+ (set-core-accessing-symbol p symbol)
+ (set-core-number p nstates)
+ (set-core-nitems p n)
+ (set-core-items p items)
+ (setq isp2 0) ;; isp2 = p->items
+ (while (< isp1 iend)
+ ;; *isp2++ = *isp1++;
+ (aset items isp2 (aref kernel-items isp1))
+ (setq isp1 (1+ isp1)
+ isp2 (1+ isp2)))
+ (set-core-next last-state p)
+ (setq last-state p
+ nstates (1+ nstates))
+ p))
+
+(defun wisent-get-state (symbol)
+ "Find the state we would get to by shifting SYMBOL.
+Return the state number for the state we would get to (from the
+current state) by shifting SYMBOL. Create a new state if no
+equivalent one exists already. Used by `wisent-append-states'."
+ (let (key isp1 isp2 iend sp sp2 found n)
+ (setq isp1 (aref kernel-base symbol)
+ iend (aref kernel-end symbol)
+ n (- iend isp1)
+ key 0)
+ ;; Add up the target state's active item numbers to get a hash key
+ (while (< isp1 iend)
+ (setq key (+ key (aref kernel-items isp1))
+ isp1 (1+ isp1)))
+ (setq key (% key wisent-state-table-size)
+ sp (aref state-table key))
+ (if sp
+ (progn
+ (setq found nil)
+ (while (not found)
+ (when (= (core-nitems sp) n)
+ (setq found t
+ isp1 (aref kernel-base symbol)
+ ;; isp2 = sp->items;
+ sp2 (core-items sp)
+ isp2 0)
+
+ (while (and found (< isp1 iend))
+ ;; if (*isp1++ != *isp2++)
+ (if (not (= (aref kernel-items isp1)
+ (aref sp2 isp2)))
+ (setq found nil))
+ (setq isp1 (1+ isp1)
+ isp2 (1+ isp2))))
+ (if (not found)
+ (if (core-link sp)
+ (setq sp (core-link sp))
+ ;; sp = sp->link = new-state(symbol)
+ (setq sp (set-core-link sp (wisent-new-state symbol))
+ found t)))))
+ ;; bucket is empty
+ ;; state-table[key] = sp = new-state(symbol)
+ (setq sp (wisent-new-state symbol))
+ (aset state-table key sp))
+ ;; return (sp->number);
+ (core-number sp)))
+
+(defun wisent-append-states ()
+ "Find or create the core structures for states.
+Use the information computed by `wisent-new-itemsets' to find the
+state numbers reached by each shift transition from the current state.
+SHIFTSET is set up as a vector of state numbers of those states."
+ (let (i j symbol)
+ ;; First sort shift-symbol into increasing order
+ (setq i 1)
+ (while (< i nshifts)
+ (setq symbol (aref shift-symbol i)
+ j i)
+ (while (and (> j 0) (> (aref shift-symbol (1- j)) symbol))
+ (aset shift-symbol j (aref shift-symbol (1- j)))
+ (setq j (1- j)))
+ (aset shift-symbol j symbol)
+ (setq i (1+ i)))
+ (setq i 0)
+ (while (< i nshifts)
+ (setq symbol (aref shift-symbol i))
+ (aset shiftset i (wisent-get-state symbol))
+ (setq i (1+ i)))
+ ))
+
+(defun wisent-initialize-states ()
+ "Initialize states."
+ (let ((p (make-core)))
+ (setq first-state p
+ last-state p
+ this-state p
+ nstates 1)))
+
+(defun wisent-save-shifts ()
+ "Save the NSHIFTS of SHIFTSET into the current linked list."
+ (let (p i shifts)
+ (setq p (make-shifts)
+ shifts (make-vector nshifts 0)
+ i 0)
+ (set-shifts-number p (core-number this-state))
+ (set-shifts-nshifts p nshifts)
+ (set-shifts-shifts p shifts)
+ (while (< i nshifts)
+ ;; (p->shifts)[i] = shiftset[i];
+ (aset shifts i (aref shiftset i))
+ (setq i (1+ i)))
+
+ (if last-shift
+ (set-shifts-next last-shift p)
+ (setq first-shift p))
+ (setq last-shift p)))
+
+(defun wisent-insert-start-shift ()
+ "Create the next-to-final state.
+That is the state to which a shift has already been made in the
+initial state. Subroutine of `wisent-augment-automaton'."
+ (let (statep sp)
+ (setq statep (make-core))
+ (set-core-number statep nstates)
+ (set-core-accessing-symbol statep start-symbol)
+ (set-core-next last-state statep)
+ (setq last-state statep)
+ ;; Make a shift from this state to (what will be) the final state.
+ (setq sp (make-shifts))
+ (set-shifts-number sp nstates)
+ (setq nstates (1+ nstates))
+ (set-shifts-nshifts sp 1)
+ (set-shifts-shifts sp (vector nstates))
+ (set-shifts-next last-shift sp)
+ (setq last-shift sp)))
+
+(defun wisent-augment-automaton ()
+ "Set up initial and final states as parser wants them.
+Make sure that the initial state has a shift that accepts the
+grammar's start symbol and goes to the next-to-final state, which has
+a shift going to the final state, which has a shift to the termination
+state. Create such states and shifts if they don't happen to exist
+already."
+ (let (i k statep sp sp2 sp1 shifts)
+ (setq sp first-shift)
+ (if sp
+ (progn
+ (if (zerop (shifts-number sp))
+ (progn
+ (setq k (shifts-nshifts sp)
+ statep (core-next first-state))
+ ;; The states reached by shifts from first-state are
+ ;; numbered 1...K. Look for one reached by
+ ;; START-SYMBOL.
+ (while (and (< (core-accessing-symbol statep) start-symbol)
+ (< (core-number statep) k))
+ (setq statep (core-next statep)))
+ (if (= (core-accessing-symbol statep) start-symbol)
+ (progn
+ ;; We already have a next-to-final state. Make
+ ;; sure it has a shift to what will be the final
+ ;; state.
+ (setq k (core-number statep))
+ (while (and sp (< (shifts-number sp) k))
+ (setq sp1 sp
+ sp (shifts-next sp)))
+ (if (and sp (= (shifts-number sp) k))
+ (progn
+ (setq i (shifts-nshifts sp)
+ sp2 (make-shifts)
+ shifts (make-vector (1+ i) 0))
+ (set-shifts-number sp2 k)
+ (set-shifts-nshifts sp2 (1+ i))
+ (set-shifts-shifts sp2 shifts)
+ (aset shifts 0 nstates)
+ (while (> i 0)
+ ;; sp2->shifts[i] = sp->shifts[i - 1];
+ (aset shifts i (aref (shifts-shifts sp) (1- i)))
+ (setq i (1- i)))
+ ;; Patch sp2 into the chain of shifts in
+ ;; place of sp, following sp1.
+ (set-shifts-next sp2 (shifts-next sp))
+ (set-shifts-next sp1 sp2)
+ (if (eq sp last-shift)
+ (setq last-shift sp2))
+ )
+ (setq sp2 (make-shifts))
+ (set-shifts-number sp2 k)
+ (set-shifts-nshifts sp2 1)
+ (set-shifts-shifts sp2 (vector nstates))
+ ;; Patch sp2 into the chain of shifts between
+ ;; sp1 and sp.
+ (set-shifts-next sp2 sp)
+ (set-shifts-next sp1 sp2)
+ (if (not sp)
+ (setq last-shift sp2))
+ )
+ )
+ ;; There is no next-to-final state as yet.
+ ;; Add one more shift in FIRST-SHIFT, going to the
+ ;; next-to-final state (yet to be made).
+ (setq sp first-shift
+ sp2 (make-shifts)
+ i (shifts-nshifts sp)
+ shifts (make-vector (1+ i) 0))
+ (set-shifts-nshifts sp2 (1+ i))
+ (set-shifts-shifts sp2 shifts)
+ ;; Stick this shift into the vector at the proper place.
+ (setq statep (core-next first-state)
+ k 0
+ i 0)
+ (while (< i (shifts-nshifts sp))
+ (when (and (> (core-accessing-symbol statep) start-symbol)
+ (= i k))
+ (aset shifts k nstates)
+ (setq k (1+ k)))
+ (aset shifts k (aref (shifts-shifts sp) i))
+ (setq statep (core-next statep))
+ (setq i (1+ i)
+ k (1+ k)))
+ (when (= i k)
+ (aset shifts k nstates)
+ (setq k (1+ k)))
+ ;; Patch sp2 into the chain of shifts in place of
+ ;; sp, at the beginning.
+ (set-shifts-next sp2 (shifts-next sp))
+ (setq first-shift sp2)
+ (if (eq last-shift sp)
+ (setq last-shift sp2))
+ ;; Create the next-to-final state, with shift to
+ ;; what will be the final state.
+ (wisent-insert-start-shift)))
+ ;; The initial state didn't even have any shifts. Give it
+ ;; one shift, to the next-to-final state.
+ (setq sp (make-shifts))
+ (set-shifts-nshifts sp 1)
+ (set-shifts-shifts sp (vector nstates))
+ ;; Patch sp into the chain of shifts at the beginning.
+ (set-shifts-next sp first-shift)
+ (setq first-shift sp)
+ ;; Create the next-to-final state, with shift to what will
+ ;; be the final state.
+ (wisent-insert-start-shift)))
+ ;; There are no shifts for any state. Make one shift, from the
+ ;; initial state to the next-to-final state.
+ (setq sp (make-shifts))
+ (set-shifts-nshifts sp 1)
+ (set-shifts-shifts sp (vector nstates))
+ ;; Initialize the chain of shifts with sp.
+ (setq first-shift sp
+ last-shift sp)
+ ;; Create the next-to-final state, with shift to what will be
+ ;; the final state.
+ (wisent-insert-start-shift))
+ ;; Make the final state--the one that follows a shift from the
+ ;; next-to-final state. The symbol for that shift is 0
+ ;; (end-of-file).
+ (setq statep (make-core))
+ (set-core-number statep nstates)
+ (set-core-next last-state statep)
+ (setq last-state statep)
+ ;; Make the shift from the final state to the termination state.
+ (setq sp (make-shifts))
+ (set-shifts-number sp nstates)
+ (setq nstates (1+ nstates))
+ (set-shifts-nshifts sp 1)
+ (set-shifts-shifts sp (vector nstates))
+ (set-shifts-next last-shift sp)
+ (setq last-shift sp)
+ ;; Note that the variable FINAL-STATE refers to what we sometimes
+ ;; call the termination state.
+ (setq final-state nstates)
+ ;; Make the termination state.
+ (setq statep (make-core))
+ (set-core-number statep nstates)
+ (setq nstates (1+ nstates))
+ (set-core-next last-state statep)
+ (setq last-state statep)))
+
+(defun wisent-save-reductions ()
+ "Make a reductions structure.
+Find which rules can be used for reduction transitions from the
+current state and make a reductions structure for the state to record
+their rule numbers."
+ (let (i item count p rules)
+ ;; Find and count the active items that represent ends of rules.
+ (setq count 0
+ i 0)
+ (while (< i nitemset)
+ (setq item (aref ritem (aref itemset i)))
+ (when (< item 0)
+ (aset redset count (- item))
+ (setq count (1+ count)))
+ (setq i (1+ i)))
+ ;; Make a reductions structure and copy the data into it.
+ (when (> count 0)
+ (setq p (make-reductions)
+ rules (make-vector count 0))
+ (set-reductions-number p (core-number this-state))
+ (set-reductions-nreds p count)
+ (set-reductions-rules p rules)
+ (setq i 0)
+ (while (< i count)
+ ;; (p->rules)[i] = redset[i]
+ (aset rules i (aref redset i))
+ (setq i (1+ i)))
+ (if last-reduction
+ (set-reductions-next last-reduction p)
+ (setq first-reduction p))
+ (setq last-reduction p))))
+
+(defun wisent-generate-states ()
+ "Compute the nondeterministic finite state machine from the grammar."
+ (wisent-allocate-storage)
+ (wisent-initialize-closure nitems)
+ (wisent-initialize-states)
+ (while this-state
+ ;; Set up RULESET and ITEMSET for the transitions out of this
+ ;; state. RULESET gets a 1 bit for each rule that could reduce
+ ;; now. ITEMSET gets a vector of all the items that could be
+ ;; accepted next.
+ (wisent-closure (core-items this-state) (core-nitems this-state))
+ ;; Record the reductions allowed out of this state.
+ (wisent-save-reductions)
+ ;; Find the itemsets of the states that shifts can reach.
+ (wisent-new-itemsets)
+ ;; Find or create the core structures for those states.
+ (wisent-append-states)
+ ;; Create the shifts structures for the shifts to those states,
+ ;; now that the state numbers transitioning to are known.
+ (if (> nshifts 0)
+ (wisent-save-shifts))
+ ;; States are queued when they are created; process them all.
+ (setq this-state (core-next this-state)))
+ ;; Set up initial and final states as parser wants them.
+ (wisent-augment-automaton))
+
+;;;; ---------------------------
+;;;; Compute look-ahead criteria
+;;;; ---------------------------
+
+;; Compute how to make the finite state machine deterministic; find
+;; which rules need lookahead in each state, and which lookahead
+;; tokens they accept.
+
+;; `wisent-lalr', the entry point, builds these data structures:
+
+;; GOTO-MAP, FROM-STATE and TO-STATE record each shift transition
+;; which accepts a variable (a nonterminal). NGOTOS is the number of
+;; such transitions.
+;; FROM-STATE[t] is the state number which a transition leads from and
+;; TO-STATE[t] is the state number it leads to.
+;; All the transitions that accept a particular variable are grouped
+;; together and GOTO-MAP[i - NTOKENS] is the index in FROM-STATE and
+;; TO-STATE of the first of them.
+
+;; CONSISTENT[s] is non-nil if no lookahead is needed to decide what
+;; to do in state s.
+
+;; LARULENO is a vector which records the rules that need lookahead in
+;; various states. The elements of LARULENO that apply to state s are
+;; those from LOOKAHEADS[s] through LOOKAHEADS[s+1]-1. Each element
+;; of LARULENO is a rule number.
+
+;; If LR is the length of LARULENO, then a number from 0 to LR-1 can
+;; specify both a rule and a state where the rule might be applied.
+;; LA is a LR by NTOKENS matrix of bits.
+;; LA[l, i] is 1 if the rule LARULENO[l] is applicable in the
+;; appropriate state when the next token is symbol i.
+;; If LA[l, i] and LA[l, j] are both 1 for i != j, it is a conflict.
+
+(wisent-defcontext digraph
+ INDEX R VERTICES
+ infinity top)
+
+(defun wisent-traverse (i)
+ "Traverse I."
+ (let (j k height Ri Fi break)
+ (setq top (1+ top)
+ height top)
+ (aset VERTICES top i) ;; VERTICES[++top] = i
+ (aset INDEX i top) ;; INDEX[i] = height = top
+
+ (setq Ri (aref R i))
+ (when Ri
+ (setq j 0)
+ (while (>= (aref Ri j) 0)
+ (if (zerop (aref INDEX (aref Ri j)))
+ (wisent-traverse (aref Ri j)))
+ ;; if (INDEX[i] > INDEX[R[i][j]])
+ (if (> (aref INDEX i) (aref INDEX (aref Ri j)))
+ ;; INDEX[i] = INDEX[R[i][j]];
+ (aset INDEX i (aref INDEX (aref Ri j))))
+ (setq Fi (aref F i)
+ k 0)
+ (while (< k tokensetsize)
+ ;; F (i)[k] |= F (R[i][j])[k];
+ (aset Fi k (logior (aref Fi k)
+ (aref (aref F (aref Ri j)) k)))
+ (setq k (1+ k)))
+ (setq j (1+ j))))
+
+ (when (= (aref INDEX i) height)
+ (setq break nil)
+ (while (not break)
+ (setq j (aref VERTICES top) ;; j = VERTICES[top--]
+ top (1- top))
+ (aset INDEX j infinity)
+ (if (= i j)
+ (setq break t)
+ (setq k 0)
+ (while (< k tokensetsize)
+ ;; F (j)[k] = F (i)[k];
+ (aset (aref F j) k (aref (aref F i) k))
+ (setq k (1+ k))))))
+ ))
+
+(defun wisent-digraph (relation)
+ "Digraph RELATION."
+ (wisent-with-context digraph
+ (setq infinity (+ ngotos 2)
+ INDEX (make-vector (1+ ngotos) 0)
+ VERTICES (make-vector (1+ ngotos) 0)
+ top 0
+ R relation)
+ (let ((i 0))
+ (while (< i ngotos)
+ (if (and (= (aref INDEX i) 0) (aref R i))
+ (wisent-traverse i))
+ (setq i (1+ i))))))
+
+(defun wisent-set-state-table ()
+ "Build state table."
+ (let (sp)
+ (setq state-table (make-vector nstates nil)
+ sp first-state)
+ (while sp
+ (aset state-table (core-number sp) sp)
+ (setq sp (core-next sp)))))
+
+(defun wisent-set-accessing-symbol ()
+ "Build accessing symbol table."
+ (let (sp)
+ (setq accessing-symbol (make-vector nstates 0)
+ sp first-state)
+ (while sp
+ (aset accessing-symbol (core-number sp) (core-accessing-symbol sp))
+ (setq sp (core-next sp)))))
+
+(defun wisent-set-shift-table ()
+ "Build shift table."
+ (let (sp)
+ (setq shift-table (make-vector nstates nil)
+ sp first-shift)
+ (while sp
+ (aset shift-table (shifts-number sp) sp)
+ (setq sp (shifts-next sp)))))
+
+(defun wisent-set-reduction-table ()
+ "Build reduction table."
+ (let (rp)
+ (setq reduction-table (make-vector nstates nil)
+ rp first-reduction)
+ (while rp
+ (aset reduction-table (reductions-number rp) rp)
+ (setq rp (reductions-next rp)))))
+
+(defun wisent-set-maxrhs ()
+ "Setup MAXRHS length."
+ (let (i len max)
+ (setq len 0
+ max 0
+ i 0)
+ (while (aref ritem i)
+ (if (> (aref ritem i) 0)
+ (setq len (1+ len))
+ (if (> len max)
+ (setq max len))
+ (setq len 0))
+ (setq i (1+ i)))
+ (setq maxrhs max)))
+
+(defun wisent-initialize-LA ()
+ "Set up LA."
+ (let (i j k count rp sp np v)
+ (setq consistent (make-vector nstates nil)
+ lookaheads (make-vector (1+ nstates) 0)
+ count 0
+ i 0)
+ (while (< i nstates)
+ (aset lookaheads i count)
+ (setq rp (aref reduction-table i)
+ sp (aref shift-table i))
+ ;; if (rp &&
+ ;; (rp->nreds > 1
+ ;; || (sp && ! ISVAR(accessing-symbol[sp->shifts[0]]))))
+ (if (and rp
+ (or (> (reductions-nreds rp) 1)
+ (and sp
+ (not (wisent-ISVAR
+ (aref accessing-symbol
+ (aref (shifts-shifts sp) 0)))))))
+ (setq count (+ count (reductions-nreds rp)))
+ (aset consistent i t))
+
+ (when sp
+ (setq k 0
+ j (shifts-nshifts sp)
+ v (shifts-shifts sp))
+ (while (< k j)
+ (when (= (aref accessing-symbol (aref v k))
+ error-token-number)
+ (aset consistent i nil)
+ (setq k j)) ;; break
+ (setq k (1+ k))))
+ (setq i (1+ i)))
+
+ (aset lookaheads nstates count)
+
+ (if (zerop count)
+ (progn
+ (setq LA (make-vector 1 nil)
+ LAruleno (make-vector 1 0)
+ lookback (make-vector 1 nil)))
+ (setq LA (make-vector count nil)
+ LAruleno (make-vector count 0)
+ lookback (make-vector count nil)))
+ (setq i 0 j (length LA))
+ (while (< i j)
+ (aset LA i (make-vector tokensetsize 0))
+ (setq i (1+ i)))
+
+ (setq np 0
+ i 0)
+ (while (< i nstates)
+ (when (not (aref consistent i))
+ (setq rp (aref reduction-table i))
+ (when rp
+ (setq j 0
+ k (reductions-nreds rp)
+ v (reductions-rules rp))
+ (while (< j k)
+ (aset LAruleno np (aref v j))
+ (setq np (1+ np)
+ j (1+ j)))))
+ (setq i (1+ i)))))
+
+(defun wisent-set-goto-map ()
+ "Set up GOTO-MAP."
+ (let (sp i j symbol k temp-map state1 state2 v)
+ (setq goto-map (make-vector (1+ nvars) 0)
+ temp-map (make-vector (1+ nvars) 0))
+
+ (setq ngotos 0
+ sp first-shift)
+ (while sp
+ (setq i (1- (shifts-nshifts sp))
+ v (shifts-shifts sp))
+ (while (>= i 0)
+ (setq symbol (aref accessing-symbol (aref v i)))
+ (if (wisent-ISTOKEN symbol)
+ (setq i 0) ;; break
+ (setq ngotos (1+ ngotos))
+ ;; goto-map[symbol]++;
+ (aset goto-map (- symbol ntokens)
+ (1+ (aref goto-map (- symbol ntokens)))))
+ (setq i (1- i)))
+ (setq sp (shifts-next sp)))
+
+ (setq k 0
+ i ntokens
+ j 0)
+ (while (< i nsyms)
+ (aset temp-map j k)
+ (setq k (+ k (aref goto-map j))
+ i (1+ i)
+ j (1+ j)))
+ (setq i ntokens
+ j 0)
+ (while (< i nsyms)
+ (aset goto-map j (aref temp-map j))
+ (setq i (1+ i)
+ j (1+ j)))
+ ;; goto-map[nsyms] = ngotos;
+ ;; temp-map[nsyms] = ngotos;
+ (aset goto-map j ngotos)
+ (aset temp-map j ngotos)
+
+ (setq from-state (make-vector ngotos 0)
+ to-state (make-vector ngotos 0)
+ sp first-shift)
+ (while sp
+ (setq state1 (shifts-number sp)
+ v (shifts-shifts sp)
+ i (1- (shifts-nshifts sp)))
+ (while (>= i 0)
+ (setq state2 (aref v i)
+ symbol (aref accessing-symbol state2))
+ (if (wisent-ISTOKEN symbol)
+ (setq i 0) ;; break
+ ;; k = temp-map[symbol]++;
+ (setq k (aref temp-map (- symbol ntokens)))
+ (aset temp-map (- symbol ntokens) (1+ k))
+ (aset from-state k state1)
+ (aset to-state k state2))
+ (setq i (1- i)))
+ (setq sp (shifts-next sp)))
+ ))
+
+(defun wisent-map-goto (state symbol)
+ "Map a STATE/SYMBOL pair into its numeric representation."
+ (let (high low middle s result)
+ ;; low = goto-map[symbol];
+ ;; high = goto-map[symbol + 1] - 1;
+ (setq low (aref goto-map (- symbol ntokens))
+ high (1- (aref goto-map (- (1+ symbol) ntokens))))
+ (while (and (not result) (<= low high))
+ (setq middle (/ (+ low high) 2)
+ s (aref from-state middle))
+ (cond
+ ((= s state)
+ (setq result middle))
+ ((< s state)
+ (setq low (1+ middle)))
+ (t
+ (setq high (1- middle)))))
+ (or result
+ (error "Internal error in `wisent-map-goto'"))
+ ))
+
+(defun wisent-initialize-F ()
+ "Set up F."
+ (let (i j k sp edge rowp rp reads nedges stateno symbol v break)
+ (setq F (make-vector ngotos nil)
+ i 0)
+ (while (< i ngotos)
+ (aset F i (make-vector tokensetsize 0))
+ (setq i (1+ i)))
+
+ (setq reads (make-vector ngotos nil)
+ edge (make-vector (1+ ngotos) 0)
+ nedges 0
+ rowp 0 ;; rowp = F
+ i 0)
+ (while (< i ngotos)
+ (setq stateno (aref to-state i)
+ sp (aref shift-table stateno))
+ (when sp
+ (setq k (shifts-nshifts sp)
+ v (shifts-shifts sp)
+ j 0
+ break nil)
+ (while (and (not break) (< j k))
+ ;; symbol = accessing-symbol[sp->shifts[j]];
+ (setq symbol (aref accessing-symbol (aref v j)))
+ (if (wisent-ISVAR symbol)
+ (setq break t) ;; break
+ (wisent-SETBIT (aref F rowp) symbol)
+ (setq j (1+ j))))
+
+ (while (< j k)
+ ;; symbol = accessing-symbol[sp->shifts[j]];
+ (setq symbol (aref accessing-symbol (aref v j)))
+ (when (aref nullable (- symbol ntokens))
+ (aset edge nedges (wisent-map-goto stateno symbol))
+ (setq nedges (1+ nedges)))
+ (setq j (1+ j)))
+
+ (when (> nedges 0)
+ ;; reads[i] = rp = NEW2(nedges + 1, short);
+ (setq rp (make-vector (1+ nedges) 0)
+ j 0)
+ (aset reads i rp)
+ (while (< j nedges)
+ ;; rp[j] = edge[j];
+ (aset rp j (aref edge j))
+ (setq j (1+ j)))
+ (aset rp nedges -1)
+ (setq nedges 0)))
+ (setq rowp (1+ rowp))
+ (setq i (1+ i)))
+ (wisent-digraph reads)
+ ))
+
+(defun wisent-add-lookback-edge (stateno ruleno gotono)
+ "Add a lookback edge.
+STATENO, RULENO, GOTONO are self-explanatory."
+ (let (i k found)
+ (setq i (aref lookaheads stateno)
+ k (aref lookaheads (1+ stateno))
+ found nil)
+ (while (and (not found) (< i k))
+ (if (= (aref LAruleno i) ruleno)
+ (setq found t)
+ (setq i (1+ i))))
+
+ (or found
+ (error "Internal error in `wisent-add-lookback-edge'"))
+
+ ;; value . next
+ ;; lookback[i] = (gotono . lookback[i])
+ (aset lookback i (cons gotono (aref lookback i)))))
+
+(defun wisent-transpose (R-arg n)
+ "Return the transpose of R-ARG, of size N.
+Destroy R-ARG, as it is replaced with the result. R-ARG[I] is nil or
+a -1 terminated list of numbers. RESULT[NUM] is nil or the -1
+terminated list of the I such as NUM is in R-ARG[I]."
+ (let (i j new-R end-R nedges v sp)
+ (setq new-R (make-vector n nil)
+ end-R (make-vector n nil)
+ nedges (make-vector n 0))
+
+ ;; Count.
+ (setq i 0)
+ (while (< i n)
+ (setq v (aref R-arg i))
+ (when v
+ (setq j 0)
+ (while (>= (aref v j) 0)
+ (aset nedges (aref v j) (1+ (aref nedges (aref v j))))
+ (setq j (1+ j))))
+ (setq i (1+ i)))
+
+ ;; Allocate.
+ (setq i 0)
+ (while (< i n)
+ (when (> (aref nedges i) 0)
+ (setq sp (make-vector (1+ (aref nedges i)) 0))
+ (aset sp (aref nedges i) -1)
+ (aset new-R i sp)
+ (aset end-R i 0))
+ (setq i (1+ i)))
+
+ ;; Store.
+ (setq i 0)
+ (while (< i n)
+ (setq v (aref R-arg i))
+ (when v
+ (setq j 0)
+ (while (>= (aref v j) 0)
+ (aset (aref new-R (aref v j)) (aref end-R (aref v j)) i)
+ (aset end-R (aref v j) (1+ (aref end-R (aref v j))))
+ (setq j (1+ j))))
+ (setq i (1+ i)))
+
+ new-R))
+
+(defun wisent-build-relations ()
+ "Build relations."
+ (let (i j k rulep rp sp length nedges done state1 stateno
+ symbol1 symbol2 edge states v)
+ (setq includes (make-vector ngotos nil)
+ edge (make-vector (1+ ngotos) 0)
+ states (make-vector (1+ maxrhs) 0)
+ i 0)
+
+ (while (< i ngotos)
+ (setq nedges 0
+ state1 (aref from-state i)
+ symbol1 (aref accessing-symbol (aref to-state i))
+ rulep (aref derives (- symbol1 ntokens)))
+
+ (while (> (car rulep) 0)
+ (aset states 0 state1)
+ (setq length 1
+ stateno state1
+ rp (aref rrhs (car rulep))) ;; rp = ritem + rrhs[*rulep]
+ (while (> (aref ritem rp) 0) ;; *rp > 0
+ (setq symbol2 (aref ritem rp)
+ sp (aref shift-table stateno)
+ k (shifts-nshifts sp)
+ v (shifts-shifts sp)
+ j 0)
+ (while (< j k)
+ (setq stateno (aref v j))
+ (if (= (aref accessing-symbol stateno) symbol2)
+ (setq j k) ;; break
+ (setq j (1+ j))))
+ ;; states[length++] = stateno;
+ (aset states length stateno)
+ (setq length (1+ length))
+ (setq rp (1+ rp)))
+
+ (if (not (aref consistent stateno))
+ (wisent-add-lookback-edge stateno (car rulep) i))
+
+ (setq length (1- length)
+ done nil)
+ (while (not done)
+ (setq done t
+ rp (1- rp))
+ (when (and (>= rp 0) (wisent-ISVAR (aref ritem rp)))
+ ;; stateno = states[--length];
+ (setq length (1- length)
+ stateno (aref states length))
+ (aset edge nedges (wisent-map-goto stateno (aref ritem rp)))
+ (setq nedges (1+ nedges))
+ (if (aref nullable (- (aref ritem rp) ntokens))
+ (setq done nil))))
+ (setq rulep (cdr rulep)))
+
+ (when (> nedges 0)
+ (setq v (make-vector (1+ nedges) 0)
+ j 0)
+ (aset includes i v)
+ (while (< j nedges)
+ (aset v j (aref edge j))
+ (setq j (1+ j)))
+ (aset v nedges -1))
+ (setq i (1+ i)))
+
+ (setq includes (wisent-transpose includes ngotos))
+ ))
+
+(defun wisent-compute-FOLLOWS ()
+ "Compute follows."
+ (wisent-digraph includes))
+
+(defun wisent-compute-lookaheads ()
+ "Compute lookaheads."
+ (let (i j n v1 v2 sp)
+ (setq n (aref lookaheads nstates)
+ i 0)
+ (while (< i n)
+ (setq sp (aref lookback i))
+ (while sp
+ (setq v1 (aref LA i)
+ v2 (aref F (car sp))
+ j 0)
+ (while (< j tokensetsize)
+ ;; LA (i)[j] |= F (sp->value)[j]
+ (aset v1 j (logior (aref v1 j) (aref v2 j)))
+ (setq j (1+ j)))
+ (setq sp (cdr sp)))
+ (setq i (1+ i)))))
+
+(defun wisent-lalr ()
+ "Make the nondeterministic finite state machine deterministic."
+ (setq tokensetsize (wisent-WORDSIZE ntokens))
+ (wisent-set-state-table)
+ (wisent-set-accessing-symbol)
+ (wisent-set-shift-table)
+ (wisent-set-reduction-table)
+ (wisent-set-maxrhs)
+ (wisent-initialize-LA)
+ (wisent-set-goto-map)
+ (wisent-initialize-F)
+ (wisent-build-relations)
+ (wisent-compute-FOLLOWS)
+ (wisent-compute-lookaheads))
+
+;;;; -----------------------------------------------
+;;;; Find and resolve or report look-ahead conflicts
+;;;; -----------------------------------------------
+
+(defsubst wisent-log-resolution (state LAno token resolution)
+ "Log a shift-reduce conflict resolution.
+In specified STATE between rule pointed by lookahead number LANO and
+TOKEN, resolved as RESOLUTION."
+ (if (or wisent-verbose-flag wisent-debug-flag)
+ (wisent-log
+ "Conflict in state %d between rule %d and token %s resolved as %s.\n"
+ state (aref LAruleno LAno) (wisent-tag token) resolution)))
+
+(defun wisent-flush-shift (state token)
+ "Turn off the shift recorded in the specified STATE for TOKEN.
+Used when we resolve a shift-reduce conflict in favor of the reduction."
+ (let (shiftp i k v)
+ (when (setq shiftp (aref shift-table state))
+ (setq k (shifts-nshifts shiftp)
+ v (shifts-shifts shiftp)
+ i 0)
+ (while (< i k)
+ (if (and (not (zerop (aref v i)))
+ (= token (aref accessing-symbol (aref v i))))
+ (aset v i 0))
+ (setq i (1+ i))))))
+
+(defun wisent-resolve-sr-conflict (state lookaheadnum)
+ "Attempt to resolve shift-reduce conflict for one rule.
+Resolve by means of precedence declarations. The conflict occurred in
+specified STATE for the rule pointed by the lookahead symbol
+LOOKAHEADNUM. It has already been checked that the rule has a
+precedence. A conflict is resolved by modifying the shift or reduce
+tables so that there is no longer a conflict."
+ (let (i redprec errp errs nerrs token sprec sassoc)
+ ;; Find the rule to reduce by to get precedence of reduction
+ (setq token (aref tags (aref rprec (aref LAruleno lookaheadnum)))
+ redprec (wisent-prec token)
+ errp (make-errs)
+ errs (make-vector ntokens 0)
+ nerrs 0
+ i 0)
+ (set-errs-errs errp errs)
+ (while (< i ntokens)
+ (setq token (aref tags i))
+ (when (and (wisent-BITISSET (aref LA lookaheadnum) i)
+ (wisent-BITISSET lookaheadset i)
+ (setq sprec (wisent-prec token)))
+ ;; Shift-reduce conflict occurs for token number I and it has
+ ;; a precedence. The precedence of shifting is that of token
+ ;; I.
+ (cond
+ ((< sprec redprec)
+ (wisent-log-resolution state lookaheadnum i "reduce")
+ ;; Flush the shift for this token
+ (wisent-RESETBIT lookaheadset i)
+ (wisent-flush-shift state i)
+ )
+ ((> sprec redprec)
+ (wisent-log-resolution state lookaheadnum i "shift")
+ ;; Flush the reduce for this token
+ (wisent-RESETBIT (aref LA lookaheadnum) i)
+ )
+ (t
+ ;; Matching precedence levels.
+ ;; For left association, keep only the reduction.
+ ;; For right association, keep only the shift.
+ ;; For nonassociation, keep neither.
+ (setq sassoc (wisent-assoc token))
+ (cond
+ ((eq sassoc 'right)
+ (wisent-log-resolution state lookaheadnum i "shift"))
+ ((eq sassoc 'left)
+ (wisent-log-resolution state lookaheadnum i "reduce"))
+ ((eq sassoc 'nonassoc)
+ (wisent-log-resolution state lookaheadnum i "an error"))
+ )
+ (when (not (eq sassoc 'right))
+ ;; Flush the shift for this token
+ (wisent-RESETBIT lookaheadset i)
+ (wisent-flush-shift state i))
+ (when (not (eq sassoc 'left))
+ ;; Flush the reduce for this token
+ (wisent-RESETBIT (aref LA lookaheadnum) i))
+ (when (eq sassoc 'nonassoc)
+ ;; Record an explicit error for this token
+ (aset errs nerrs i)
+ (setq nerrs (1+ nerrs)))
+ )))
+ (setq i (1+ i)))
+ (when (> nerrs 0)
+ (set-errs-nerrs errp nerrs)
+ (aset err-table state errp))
+ ))
+
+(defun wisent-set-conflicts (state)
+ "Find and attempt to resolve conflicts in specified STATE."
+ (let (i j k v shiftp symbol)
+ (unless (aref consistent state)
+ (fillarray lookaheadset 0)
+
+ (when (setq shiftp (aref shift-table state))
+ (setq k (shifts-nshifts shiftp)
+ v (shifts-shifts shiftp)
+ i 0)
+ (while (and (< i k)
+ (wisent-ISTOKEN
+ (setq symbol (aref accessing-symbol (aref v i)))))
+ (or (zerop (aref v i))
+ (wisent-SETBIT lookaheadset symbol))
+ (setq i (1+ i))))
+
+ ;; Loop over all rules which require lookahead in this state
+ ;; first check for shift-reduce conflict, and try to resolve
+ ;; using precedence
+ (setq i (aref lookaheads state)
+ k (aref lookaheads (1+ state)))
+ (while (< i k)
+ (when (aref rprec (aref LAruleno i))
+ (setq v (aref LA i)
+ j 0)
+ (while (< j tokensetsize)
+ (if (zerop (logand (aref v j) (aref lookaheadset j)))
+ (setq j (1+ j))
+ ;; if (LA (i)[j] & lookaheadset[j])
+ (wisent-resolve-sr-conflict state i)
+ (setq j tokensetsize)))) ;; break
+ (setq i (1+ i)))
+
+ ;; Loop over all rules which require lookahead in this state
+ ;; Check for conflicts not resolved above.
+ (setq i (aref lookaheads state))
+ (while (< i k)
+ (setq v (aref LA i)
+ j 0)
+ (while (< j tokensetsize)
+ ;; if (LA (i)[j] & lookaheadset[j])
+ (if (not (zerop (logand (aref v j) (aref lookaheadset j))))
+ (aset conflicts state t))
+ (setq j (1+ j)))
+ (setq j 0)
+ (while (< j tokensetsize)
+ ;; lookaheadset[j] |= LA (i)[j];
+ (aset lookaheadset j (logior (aref lookaheadset j)
+ (aref v j)))
+ (setq j (1+ j)))
+ (setq i (1+ i)))
+ )))
+
+(defun wisent-resolve-conflicts ()
+ "Find and resolve conflicts."
+ (let (i)
+ (setq conflicts (make-vector nstates nil)
+ shiftset (make-vector tokensetsize 0)
+ lookaheadset (make-vector tokensetsize 0)
+ err-table (make-vector nstates nil)
+ i 0)
+ (while (< i nstates)
+ (wisent-set-conflicts i)
+ (setq i (1+ i)))))
+
+(defun wisent-count-sr-conflicts (state)
+ "Count the number of shift/reduce conflicts in specified STATE."
+ (let (i j k shiftp symbol v)
+ (setq src-count 0
+ shiftp (aref shift-table state))
+ (when shiftp
+ (fillarray shiftset 0)
+ (fillarray lookaheadset 0)
+ (setq k (shifts-nshifts shiftp)
+ v (shifts-shifts shiftp)
+ i 0)
+ (while (< i k)
+ (when (not (zerop (aref v i)))
+ (setq symbol (aref accessing-symbol (aref v i)))
+ (if (wisent-ISVAR symbol)
+ (setq i k) ;; break
+ (wisent-SETBIT shiftset symbol)))
+ (setq i (1+ i)))
+
+ (setq k (aref lookaheads (1+ state))
+ i (aref lookaheads state))
+ (while (< i k)
+ (setq v (aref LA i)
+ j 0)
+ (while (< j tokensetsize)
+ ;; lookaheadset[j] |= LA (i)[j]
+ (aset lookaheadset j (logior (aref lookaheadset j)
+ (aref v j)))
+ (setq j (1+ j)))
+ (setq i (1+ i)))
+
+ (setq k 0)
+ (while (< k tokensetsize)
+ ;; lookaheadset[k] &= shiftset[k];
+ (aset lookaheadset k (logand (aref lookaheadset k)
+ (aref shiftset k)))
+ (setq k (1+ k)))
+
+ (setq i 0)
+ (while (< i ntokens)
+ (if (wisent-BITISSET lookaheadset i)
+ (setq src-count (1+ src-count)))
+ (setq i (1+ i))))
+ src-count))
+
+(defun wisent-count-rr-conflicts (state)
+ "Count the number of reduce/reduce conflicts in specified STATE."
+ (let (i j count n m)
+ (setq rrc-count 0
+ m (aref lookaheads state)
+ n (aref lookaheads (1+ state)))
+ (when (>= (- n m) 2)
+ (setq i 0)
+ (while (< i ntokens)
+ (setq count 0
+ j m)
+ (while (< j n)
+ (if (wisent-BITISSET (aref LA j) i)
+ (setq count (1+ count)))
+ (setq j (1+ j)))
+
+ (if (>= count 2)
+ (setq rrc-count (1+ rrc-count)))
+ (setq i (1+ i))))
+ rrc-count))
+
+(defvar wisent-expected-conflicts nil
+ "*If non-nil suppress the warning about shift/reduce conflicts.
+It is a decimal integer N that says there should be no warning if
+there are N shift/reduce conflicts and no reduce/reduce conflicts. A
+warning is given if there are either more or fewer conflicts, or if
+there are any reduce/reduce conflicts.")
+
+(defun wisent-total-conflicts ()
+ "Report the total number of conflicts."
+ (unless (and (zerop rrc-total)
+ (or (zerop src-total)
+ (= src-total (or wisent-expected-conflicts 0))))
+ (let* ((src (wisent-source))
+ (src (if src (concat " in " src) ""))
+ (msg (format "Grammar%s contains" src)))
+ (if (> src-total 0)
+ (setq msg (format "%s %d shift/reduce conflict%s"
+ msg src-total (if (> src-total 1)
+ "s" ""))))
+ (if (and (> src-total 0) (> rrc-total 0))
+ (setq msg (format "%s and" msg)))
+ (if (> rrc-total 0)
+ (setq msg (format "%s %d reduce/reduce conflict%s"
+ msg rrc-total (if (> rrc-total 1)
+ "s" ""))))
+ (message msg))))
+
+(defun wisent-print-conflicts ()
+ "Report conflicts."
+ (let (i)
+ (setq src-total 0
+ rrc-total 0
+ i 0)
+ (while (< i nstates)
+ (when (aref conflicts i)
+ (wisent-count-sr-conflicts i)
+ (wisent-count-rr-conflicts i)
+ (setq src-total (+ src-total src-count)
+ rrc-total (+ rrc-total rrc-count))
+ (when (or wisent-verbose-flag wisent-debug-flag)
+ (wisent-log "State %d contains" i)
+ (if (> src-count 0)
+ (wisent-log " %d shift/reduce conflict%s"
+ src-count (if (> src-count 1) "s" "")))
+
+ (if (and (> src-count 0) (> rrc-count 0))
+ (wisent-log " and"))
+
+ (if (> rrc-count 0)
+ (wisent-log " %d reduce/reduce conflict%s"
+ rrc-count (if (> rrc-count 1) "s" "")))
+
+ (wisent-log ".\n")))
+ (setq i (1+ i)))
+ (wisent-total-conflicts)))
+
+;;;; --------------------------------------
+;;;; Report information on generated parser
+;;;; --------------------------------------
+(defun wisent-print-grammar ()
+ "Print grammar."
+ (let (i j r break left-count right-count)
+
+ (wisent-log "\n\nGrammar\n\n Number, Rule\n")
+ (setq i 1)
+ (while (<= i nrules)
+ ;; Don't print rules disabled in `wisent-reduce-grammar-tables'.
+ (when (aref ruseful i)
+ (wisent-log " %s %s ->"
+ (wisent-pad-string (number-to-string i) 6)
+ (wisent-tag (aref rlhs i)))
+ (setq r (aref rrhs i))
+ (if (> (aref ritem r) 0)
+ (while (> (aref ritem r) 0)
+ (wisent-log " %s" (wisent-tag (aref ritem r)))
+ (setq r (1+ r)))
+ (wisent-log " /* empty */"))
+ (wisent-log "\n"))
+ (setq i (1+ i)))
+
+ (wisent-log "\n\nTerminals, with rules where they appear\n\n")
+ (wisent-log "%s (-1)\n" (wisent-tag 0))
+ (setq i 1)
+ (while (< i ntokens)
+ (wisent-log "%s (%d)" (wisent-tag i) i)
+ (setq j 1)
+ (while (<= j nrules)
+ (setq r (aref rrhs j)
+ break nil)
+ (while (and (not break) (> (aref ritem r) 0))
+ (if (setq break (= (aref ritem r) i))
+ (wisent-log " %d" j)
+ (setq r (1+ r))))
+ (setq j (1+ j)))
+ (wisent-log "\n")
+ (setq i (1+ i)))
+
+ (wisent-log "\n\nNonterminals, with rules where they appear\n\n")
+ (setq i ntokens)
+ (while (< i nsyms)
+ (setq left-count 0
+ right-count 0
+ j 1)
+ (while (<= j nrules)
+ (if (= (aref rlhs j) i)
+ (setq left-count (1+ left-count)))
+ (setq r (aref rrhs j)
+ break nil)
+ (while (and (not break) (> (aref ritem r) 0))
+ (if (= (aref ritem r) i)
+ (setq right-count (1+ right-count)
+ break t)
+ (setq r (1+ r))))
+ (setq j (1+ j)))
+ (wisent-log "%s (%d)\n " (wisent-tag i) i)
+ (when (> left-count 0)
+ (wisent-log " on left:")
+ (setq j 1)
+ (while (<= j nrules)
+ (if (= (aref rlhs j) i)
+ (wisent-log " %d" j))
+ (setq j (1+ j))))
+ (when (> right-count 0)
+ (if (> left-count 0)
+ (wisent-log ","))
+ (wisent-log " on right:")
+ (setq j 1)
+ (while (<= j nrules)
+ (setq r (aref rrhs j)
+ break nil)
+ (while (and (not break) (> (aref ritem r) 0))
+ (if (setq break (= (aref ritem r) i))
+ (wisent-log " %d" j)
+ (setq r (1+ r))))
+ (setq j (1+ j))))
+ (wisent-log "\n")
+ (setq i (1+ i)))
+ ))
+
+(defun wisent-print-reductions (state)
+ "Print reductions on STATE."
+ (let (i j k v symbol m n defaulted
+ default-LA default-rule cmax count shiftp errp nodefault)
+ (setq nodefault nil
+ i 0)
+ (fillarray shiftset 0)
+
+ (setq shiftp (aref shift-table state))
+ (when shiftp
+ (setq k (shifts-nshifts shiftp)
+ v (shifts-shifts shiftp)
+ i 0)
+ (while (< i k)
+ (when (not (zerop (aref v i)))
+ (setq symbol (aref accessing-symbol (aref v i)))
+ (if (wisent-ISVAR symbol)
+ (setq i k) ;; break
+ ;; If this state has a shift for the error token, don't
+ ;; use a default rule.
+ (if (= symbol error-token-number)
+ (setq nodefault t))
+ (wisent-SETBIT shiftset symbol)))
+ (setq i (1+ i))))
+
+ (setq errp (aref err-table state))
+ (when errp
+ (setq k (errs-nerrs errp)
+ v (errs-errs errp)
+ i 0)
+ (while (< i k)
+ (if (not (zerop (setq symbol (aref v i))))
+ (wisent-SETBIT shiftset symbol))
+ (setq i (1+ i))))
+
+ (setq m (aref lookaheads state)
+ n (aref lookaheads (1+ state)))
+
+ (cond
+ ((and (= (- n m) 1) (not nodefault))
+ (setq default-rule (aref LAruleno m)
+ v (aref LA m)
+ k 0)
+ (while (< k tokensetsize)
+ (aset lookaheadset k (logand (aref v k)
+ (aref shiftset k)))
+ (setq k (1+ k)))
+
+ (setq i 0)
+ (while (< i ntokens)
+ (if (wisent-BITISSET lookaheadset i)
+ (wisent-log " %s\t[reduce using rule %d (%s)]\n"
+ (wisent-tag i) default-rule
+ (wisent-tag (aref rlhs default-rule))))
+ (setq i (1+ i)))
+ (wisent-log " $default\treduce using rule %d (%s)\n\n"
+ default-rule
+ (wisent-tag (aref rlhs default-rule)))
+ )
+ ((>= (- n m) 1)
+ (setq cmax 0
+ default-LA -1
+ default-rule 0)
+ (when (not nodefault)
+ (setq i m)
+ (while (< i n)
+ (setq v (aref LA i)
+ count 0
+ k 0)
+ (while (< k tokensetsize)
+ ;; lookaheadset[k] = LA (i)[k] & ~shiftset[k]
+ (aset lookaheadset k
+ (logand (aref v k)
+ (lognot (aref shiftset k))))
+ (setq k (1+ k)))
+ (setq j 0)
+ (while (< j ntokens)
+ (if (wisent-BITISSET lookaheadset j)
+ (setq count (1+ count)))
+ (setq j (1+ j)))
+ (if (> count cmax)
+ (setq cmax count
+ default-LA i
+ default-rule (aref LAruleno i)))
+ (setq k 0)
+ (while (< k tokensetsize)
+ (aset shiftset k (logior (aref shiftset k)
+ (aref lookaheadset k)))
+ (setq k (1+ k)))
+ (setq i (1+ i))))
+
+ (fillarray shiftset 0)
+
+ (when shiftp
+ (setq k (shifts-nshifts shiftp)
+ v (shifts-shifts shiftp)
+ i 0)
+ (while (< i k)
+ (when (not (zerop (aref v i)))
+ (setq symbol (aref accessing-symbol (aref v i)))
+ (if (wisent-ISVAR symbol)
+ (setq i k) ;; break
+ (wisent-SETBIT shiftset symbol)))
+ (setq i (1+ i))))
+
+ (setq i 0)
+ (while (< i ntokens)
+ (setq defaulted nil
+ count (if (wisent-BITISSET shiftset i) 1 0)
+ j m)
+ (while (< j n)
+ (when (wisent-BITISSET (aref LA j) i)
+ (if (zerop count)
+ (progn
+ (if (not (= j default-LA))
+ (wisent-log
+ " %s\treduce using rule %d (%s)\n"
+ (wisent-tag i) (aref LAruleno j)
+ (wisent-tag (aref rlhs (aref LAruleno j))))
+ (setq defaulted t))
+ (setq count (1+ count)))
+ (if defaulted
+ (wisent-log
+ " %s\treduce using rule %d (%s)\n"
+ (wisent-tag i) (aref LAruleno default-LA)
+ (wisent-tag (aref rlhs (aref LAruleno default-LA)))))
+ (setq defaulted nil)
+ (wisent-log
+ " %s\t[reduce using rule %d (%s)]\n"
+ (wisent-tag i) (aref LAruleno j)
+ (wisent-tag (aref rlhs (aref LAruleno j))))))
+ (setq j (1+ j)))
+ (setq i (1+ i)))
+
+ (if (>= default-LA 0)
+ (wisent-log
+ " $default\treduce using rule %d (%s)\n"
+ default-rule
+ (wisent-tag (aref rlhs default-rule))))
+ ))))
+
+(defun wisent-print-actions (state)
+ "Print actions on STATE."
+ (let (i j k v state1 symbol shiftp errp redp rule nerrs break)
+ (setq shiftp (aref shift-table state)
+ redp (aref reduction-table state)
+ errp (aref err-table state))
+ (if (and (not shiftp) (not redp))
+ (if (= final-state state)
+ (wisent-log " $default\taccept\n")
+ (wisent-log " NO ACTIONS\n"))
+ (if (not shiftp)
+ (setq i 0
+ k 0)
+ (setq k (shifts-nshifts shiftp)
+ v (shifts-shifts shiftp)
+ i 0
+ break nil)
+ (while (and (not break) (< i k))
+ (if (zerop (setq state1 (aref v i)))
+ (setq i (1+ i))
+ (setq symbol (aref accessing-symbol state1))
+ ;; The following line used to be turned off.
+ (if (wisent-ISVAR symbol)
+ (setq break t) ;; break
+ (wisent-log " %s\tshift, and go to state %d\n"
+ (wisent-tag symbol) state1)
+ (setq i (1+ i)))))
+ (if (> i 0)
+ (wisent-log "\n")))
+
+ (when errp
+ (setq nerrs (errs-nerrs errp)
+ v (errs-errs errp)
+ j 0)
+ (while (< j nerrs)
+ (if (aref v j)
+ (wisent-log " %s\terror (nonassociative)\n"
+ (wisent-tag (aref v j))))
+ (setq j (1+ j)))
+ (if (> j 0)
+ (wisent-log "\n")))
+
+ (cond
+ ((and (aref consistent state) redp)
+ (setq rule (aref (reductions-rules redp) 0)
+ symbol (aref rlhs rule))
+ (wisent-log " $default\treduce using rule %d (%s)\n\n"
+ rule (wisent-tag symbol))
+ )
+ (redp
+ (wisent-print-reductions state)
+ ))
+
+ (when (< i k)
+ (setq v (shifts-shifts shiftp))
+ (while (< i k)
+ (when (setq state1 (aref v i))
+ (setq symbol (aref accessing-symbol state1))
+ (wisent-log " %s\tgo to state %d\n"
+ (wisent-tag symbol) state1))
+ (setq i (1+ i)))
+ (wisent-log "\n"))
+ )))
+
+(defun wisent-print-core (state)
+ "Print STATE core."
+ (let (i k rule statep sp sp1)
+ (setq statep (aref state-table state)
+ k (core-nitems statep))
+ (when (> k 0)
+ (setq i 0)
+ (while (< i k)
+ ;; sp1 = sp = ritem + statep->items[i];
+ (setq sp1 (aref (core-items statep) i)
+ sp sp1)
+ (while (> (aref ritem sp) 0)
+ (setq sp (1+ sp)))
+
+ (setq rule (- (aref ritem sp)))
+ (wisent-log " %s -> " (wisent-tag (aref rlhs rule)))
+
+ (setq sp (aref rrhs rule))
+ (while (< sp sp1)
+ (wisent-log "%s " (wisent-tag (aref ritem sp)))
+ (setq sp (1+ sp)))
+ (wisent-log ".")
+ (while (> (aref ritem sp) 0)
+ (wisent-log " %s" (wisent-tag (aref ritem sp)))
+ (setq sp (1+ sp)))
+ (wisent-log " (rule %d)\n" rule)
+ (setq i (1+ i)))
+ (wisent-log "\n"))))
+
+(defun wisent-print-state (state)
+ "Print information on STATE."
+ (wisent-log "\n\nstate %d\n\n" state)
+ (wisent-print-core state)
+ (wisent-print-actions state))
+
+(defun wisent-print-states ()
+ "Print information on states."
+ (let ((i 0))
+ (while (< i nstates)
+ (wisent-print-state i)
+ (setq i (1+ i)))))
+
+(defun wisent-print-results ()
+ "Print information on generated parser.
+Report detailed informations if `wisent-verbose-flag' or
+`wisent-debug-flag' are non-nil."
+ (when (or wisent-verbose-flag wisent-debug-flag)
+ (wisent-print-useless))
+ (wisent-print-conflicts)
+ (when (or wisent-verbose-flag wisent-debug-flag)
+ (wisent-print-grammar)
+ (wisent-print-states))
+ ;; Append output to log file when running in batch mode
+ (when (wisent-noninteractive)
+ (wisent-append-to-log-file)
+ (wisent-clear-log)))
+
+;;;; ---------------------------------
+;;;; Build the generated parser tables
+;;;; ---------------------------------
+
+(defun wisent-action-row (state actrow)
+ "Figure out the actions for the specified STATE.
+Decide what to do for each type of token if seen as the lookahead
+token in specified state. The value returned is used as the default
+action for the state. In addition, ACTROW is filled with what to do
+for each kind of token, index by symbol number, with nil meaning do
+the default action. The value 'error, means this situation is an
+error. The parser recognizes this value specially.
+
+This is where conflicts are resolved. The loop over lookahead rules
+considered lower-numbered rules last, and the last rule considered
+that likes a token gets to handle it."
+ (let (i j k m n v default-rule nreds rule max count
+ shift-state symbol redp shiftp errp nodefault)
+
+ (fillarray actrow nil)
+
+ (setq default-rule 0
+ nodefault nil ;; nil inhibit having any default reduction
+ nreds 0
+ m 0
+ n 0
+ redp (aref reduction-table state))
+
+ (when redp
+ (setq nreds (reductions-nreds redp))
+ (when (>= nreds 1)
+ ;; loop over all the rules available here which require
+ ;; lookahead
+ (setq m (aref lookaheads state)
+ n (aref lookaheads (1+ state))
+ i (1- n))
+ (while (>= i m)
+ ;; and find each token which the rule finds acceptable to
+ ;; come next
+ (setq j 0)
+ (while (< j ntokens)
+ ;; and record this rule as the rule to use if that token
+ ;; follows.
+ (if (wisent-BITISSET (aref LA i) j)
+ (aset actrow j (- (aref LAruleno i)))
+ )
+ (setq j (1+ j)))
+ (setq i (1- i)))))
+
+ ;; Now see which tokens are allowed for shifts in this state. For
+ ;; them, record the shift as the thing to do. So shift is
+ ;; preferred to reduce.
+ (setq shiftp (aref shift-table state))
+ (when shiftp
+ (setq k (shifts-nshifts shiftp)
+ v (shifts-shifts shiftp)
+ i 0)
+ (while (< i k)
+ (setq shift-state (aref v i))
+ (if (zerop shift-state)
+ nil ;; continue
+ (setq symbol (aref accessing-symbol shift-state))
+ (if (wisent-ISVAR symbol)
+ (setq i k) ;; break
+ (aset actrow symbol shift-state)
+ ;; Do not use any default reduction if there is a shift
+ ;; for error
+ (if (= symbol error-token-number)
+ (setq nodefault t))))
+ (setq i (1+ i))))
+
+ ;; See which tokens are an explicit error in this state (due to
+ ;; %nonassoc). For them, record error as the action.
+ (setq errp (aref err-table state))
+ (when errp
+ (setq k (errs-nerrs errp)
+ v (errs-errs errp)
+ i 0)
+ (while (< i k)
+ (aset actrow (aref v i) wisent-error-tag)
+ (setq i (1+ i))))
+
+ ;; Now find the most common reduction and make it the default
+ ;; action for this state.
+ (when (and (>= nreds 1) (not nodefault))
+ (if (aref consistent state)
+ (setq default-rule (- (aref (reductions-rules redp) 0)))
+ (setq max 0
+ i m)
+ (while (< i n)
+ (setq count 0
+ rule (- (aref LAruleno i))
+ j 0)
+ (while (< j ntokens)
+ (if (and (numberp (aref actrow j))
+ (= (aref actrow j) rule))
+ (setq count (1+ count)))
+ (setq j (1+ j)))
+ (if (> count max)
+ (setq max count
+ default-rule rule))
+ (setq i (1+ i)))
+ ;; actions which match the default are replaced with zero,
+ ;; which means "use the default"
+ (when (> max 0)
+ (setq j 0)
+ (while (< j ntokens)
+ (if (and (numberp (aref actrow j))
+ (= (aref actrow j) default-rule))
+ (aset actrow j nil))
+ (setq j (1+ j)))
+ )))
+
+ ;; If have no default rule, if this is the final state the default
+ ;; is accept else it is an error. So replace any action which
+ ;; says "error" with "use default".
+ (when (zerop default-rule)
+ (if (= final-state state)
+ (setq default-rule wisent-accept-tag)
+ (setq j 0)
+ (while (< j ntokens)
+ (if (eq (aref actrow j) wisent-error-tag)
+ (aset actrow j nil))
+ (setq j (1+ j)))
+ (setq default-rule wisent-error-tag)))
+ default-rule))
+
+(defconst wisent-default-tag 'default
+ "Tag used in an action table to indicate a default action.")
+
+;; These variables only exist locally in the function
+;; `wisent-state-actions' and are shared by all other nested callees.
+(wisent-defcontext semantic-actions
+ ;; Uninterned symbols used in code generation.
+ stack sp gotos state
+ ;; Name of the current semantic action
+ NAME)
+
+(defun wisent-state-actions ()
+ "Figure out the actions for every state.
+Return the action table."
+ ;; Store the semantic action obarray in (unused) RCODE[0].
+ (aset rcode 0 (make-vector 13 0))
+ (let (i j action-table actrow action)
+ (setq action-table (make-vector nstates nil)
+ actrow (make-vector ntokens nil)
+ i 0)
+ (wisent-with-context semantic-actions
+ (setq stack (make-symbol "stack")
+ sp (make-symbol "sp")
+ gotos (make-symbol "gotos")
+ state (make-symbol "state"))
+ (while (< i nstates)
+ (setq action (wisent-action-row i actrow))
+ ;; Translate a reduction into semantic action
+ (and (integerp action) (< action 0)
+ (setq action (wisent-semantic-action (- action))))
+ (aset action-table i (list (cons wisent-default-tag action)))
+ (setq j 0)
+ (while (< j ntokens)
+ (when (setq action (aref actrow j))
+ ;; Translate a reduction into semantic action
+ (and (integerp action) (< action 0)
+ (setq action (wisent-semantic-action (- action))))
+ (aset action-table i (cons (cons (aref tags j) action)
+ (aref action-table i)))
+ )
+ (setq j (1+ j)))
+ (aset action-table i (nreverse (aref action-table i)))
+ (setq i (1+ i)))
+ action-table)))
+
+(defun wisent-goto-actions ()
+ "Figure out what to do after reducing with each rule.
+Depending on the saved state from before the beginning of parsing the
+data that matched this rule. Return the goto table."
+ (let (i j m n symbol state goto-table)
+ (setq goto-table (make-vector nstates nil)
+ i ntokens)
+ (while (< i nsyms)
+ (setq symbol (- i ntokens)
+ m (aref goto-map symbol)
+ n (aref goto-map (1+ symbol))
+ j m)
+ (while (< j n)
+ (setq state (aref from-state j))
+ (aset goto-table state
+ (cons (cons (aref tags i) (aref to-state j))
+ (aref goto-table state)))
+ (setq j (1+ j)))
+ (setq i (1+ i)))
+ goto-table))
+
+(defsubst wisent-quote-p (sym)
+ "Return non-nil if SYM is bound to the `quote' function."
+ (condition-case nil
+ (eq (indirect-function sym)
+ (indirect-function 'quote))
+ (error nil)))
+
+(defsubst wisent-backquote-p (sym)
+ "Return non-nil if SYM is bound to the `backquote' function."
+ (condition-case nil
+ (eq (indirect-function sym)
+ (indirect-function 'backquote))
+ (error nil)))
+
+(defun wisent-check-$N (x m)
+ "Return non-nil if X is a valid $N or $regionN symbol.
+That is if X is a $N or $regionN symbol with N >= 1 and N <= M.
+Also warn if X is a $N or $regionN symbol with N < 1 or N > M."
+ (when (symbolp x)
+ (let* ((n (symbol-name x))
+ (i (and (string-match "\\`\\$\\(region\\)?\\([0-9]+\\)\\'" n)
+ (string-to-number (match-string 2 n)))))
+ (when i
+ (if (and (>= i 1) (<= i m))
+ t
+ (message
+ "*** In %s, %s might be a free variable (rule has %s)"
+ NAME x (format (cond ((< m 1) "no component")
+ ((= m 1) "%d component")
+ ("%d components"))
+ m))
+ nil)))))
+
+(defun wisent-semantic-action-expand-body (body n &optional found)
+ "Parse BODY of semantic action.
+N is the maximum number of $N variables that can be referenced in
+BODY. Warn on references out of permitted range.
+Optional argument FOUND is the accumulated list of '$N' references
+encountered so far.
+Return a cons (FOUND . XBODY), where FOUND is the list of $N
+references found in BODY, and XBODY is BODY expression with
+`backquote' forms expanded."
+ (if (not (listp body))
+ ;; BODY is an atom, no expansion needed
+ (progn
+ (if (wisent-check-$N body n)
+ ;; Accumulate $i symbol
+ (add-to-list 'found body))
+ (cons found body))
+ ;; BODY is a list, expand inside it
+ (let (xbody sexpr)
+ ;; If backquote expand it first
+ (if (wisent-backquote-p (car body))
+ (setq body (macroexpand body)))
+ (while body
+ (setq sexpr (car body)
+ body (cdr body))
+ (cond
+ ;; Function call excepted quote expression
+ ((and (consp sexpr)
+ (not (wisent-quote-p (car sexpr))))
+ (setq sexpr (wisent-semantic-action-expand-body sexpr n found)
+ found (car sexpr)
+ sexpr (cdr sexpr)))
+ ;; $i symbol
+ ((wisent-check-$N sexpr n)
+ ;; Accumulate $i symbol
+ (add-to-list 'found sexpr))
+ )
+ ;; Accumulate expanded forms
+ (setq xbody (nconc xbody (list sexpr))))
+ (cons found xbody))))
+
+(defun wisent-semantic-action (r)
+ "Set up the Elisp function for semantic action at rule R.
+On entry RCODE[R] contains a vector [BODY N (NTERM I)] where BODY is the
+body of the semantic action, N is the maximum number of values
+available in the parser's stack, NTERM is the nonterminal the semantic
+action belongs to, and I is the index of the semantic action inside
+NTERM definition. Return the semantic action symbol.
+The semantic action function accepts three arguments:
+
+- the state/value stack
+- the top-of-stack index
+- the goto table
+
+And returns the updated top-of-stack index."
+ (if (not (aref ruseful r))
+ (aset rcode r nil)
+ (let* ((actn (aref rcode r))
+ (n (aref actn 1)) ; nb of val avail. in stack
+ (NAME (apply 'format "%s:%d" (aref actn 2)))
+ (form (wisent-semantic-action-expand-body (aref actn 0) n))
+ ($l (car form)) ; list of $vars used in body
+ (form (cdr form)) ; expanded form of body
+ (nt (aref rlhs r)) ; nonterminal item no.
+ (bl nil) ; `let*' binding list
+ $v i j)
+
+ ;; Compute $N and $regionN bindings
+ (setq i n)
+ (while (> i 0)
+ (setq j (1+ (* 2 (- n i))))
+ ;; Only bind $regionI if used in action
+ (setq $v (intern (format "$region%d" i)))
+ (if (memq $v $l)
+ (setq bl (cons `(,$v (cdr (aref ,stack (- ,sp ,j)))) bl)))
+ ;; Only bind $I if used in action
+ (setq $v (intern (format "$%d" i)))
+ (if (memq $v $l)
+ (setq bl (cons `(,$v (car (aref ,stack (- ,sp ,j)))) bl)))
+ (setq i (1- i)))
+
+ ;; Compute J, the length of rule's RHS. It will give the
+ ;; current parser state at STACK[SP - 2*J], and where to push
+ ;; the new semantic value and the next state, respectively at:
+ ;; STACK[SP - 2*J + 1] and STACK[SP - 2*J + 2]. Generally N,
+ ;; the maximum number of values available in the stack, is equal
+ ;; to J. But, for mid-rule actions, N is the number of rule
+ ;; elements before the action and J is always 0 (empty rule).
+ (setq i (aref rrhs r)
+ j 0)
+ (while (> (aref ritem i) 0)
+ (setq j (1+ j)
+ i (1+ i)))
+
+ ;; Create the semantic action symbol.
+ (setq actn (intern NAME (aref rcode 0)))
+
+ ;; Store source code in function cell of the semantic action
+ ;; symbol. It will be byte-compiled at automaton's compilation
+ ;; time. Using a byte-compiled automaton can significantly
+ ;; speed up parsing!
+ (fset actn
+ `(lambda (,stack ,sp ,gotos)
+ (let* (,@bl
+ ($region
+ ,(cond
+ ((= n 1)
+ (if (assq '$region1 bl)
+ '$region1
+ `(cdr (aref ,stack (1- ,sp)))))
+ ((> n 1)
+ `(wisent-production-bounds
+ ,stack (- ,sp ,(1- (* 2 n))) (1- ,sp)))))
+ ($action ,NAME)
+ ($nterm ',(aref tags nt))
+ ,@(and (> j 0) `((,sp (- ,sp ,(* j 2)))))
+ (,state (cdr (assq $nterm
+ (aref ,gotos
+ (aref ,stack ,sp))))))
+ (setq ,sp (+ ,sp 2))
+ ;; push semantic value
+ (aset ,stack (1- ,sp) (cons ,form $region))
+ ;; push next state
+ (aset ,stack ,sp ,state)
+ ;; return new top of stack
+ ,sp)))
+
+ ;; Return the semantic action symbol
+ actn)))
+
+;;;; ----------------------------
+;;;; Build parser LALR automaton.
+;;;; ----------------------------
+
+(defun wisent-parser-automaton ()
+ "Compute and return LALR(1) automaton from GRAMMAR.
+GRAMMAR is in internal format. GRAM/ACTS are grammar rules
+in internal format. STARTS defines the start symbols."
+ ;; Check for useless stuff
+ (wisent-reduce-grammar)
+
+ (wisent-set-derives)
+ (wisent-set-nullable)
+ ;; convert to nondeterministic finite state machine.
+ (wisent-generate-states)
+ ;; make it deterministic.
+ (wisent-lalr)
+ ;; Find and record any conflicts: places where one token of
+ ;; lookahead is not enough to disambiguate the parsing. Also
+ ;; resolve s/r conflicts based on precedence declarations.
+ (wisent-resolve-conflicts)
+ (wisent-print-results)
+
+ (vector (wisent-state-actions) ; action table
+ (wisent-goto-actions) ; goto table
+ start-table ; start symbols
+ (aref rcode 0) ; sem. action symbol obarray
+ )
+ )
+
+;;;; -------------------
+;;;; Parse input grammar
+;;;; -------------------
+
+(defconst wisent-reserved-symbols (list wisent-error-term)
+ "The list of reserved symbols.
+Also all symbols starting with a character defined in
+`wisent-reserved-capitals' are reserved for internal use.")
+
+(defconst wisent-reserved-capitals '(?\$ ?\@)
+ "The list of reserved capital letters.
+All symbol starting with one of these letters are reserved for
+internal use.")
+
+(defconst wisent-starts-nonterm '$STARTS
+ "Main start symbol.
+It gives the rules for start symbols.")
+
+(defvar wisent-single-start-flag nil
+ "Non-nil means allows only one start symbol like in Bison.
+That is don't add extra start rules to the grammar. This is
+useful to compare the Wisent's generated automaton with the Bison's
+one.")
+
+(defsubst wisent-ISVALID-VAR (x)
+ "Return non-nil if X is a character or an allowed symbol."
+ (and x (symbolp x)
+ (not (memq (aref (symbol-name x) 0) wisent-reserved-capitals))
+ (not (memq x wisent-reserved-symbols))))
+
+(defsubst wisent-ISVALID-TOKEN (x)
+ "Return non-nil if X is a character or an allowed symbol."
+ (or (wisent-char-p x)
+ (wisent-ISVALID-VAR x)))
+
+(defun wisent-push-token (symbol &optional nocheck)
+ "Push a new SYMBOL in the list of tokens.
+Bypass checking if NOCHECK is non-nil."
+ ;; Check
+ (or nocheck (wisent-ISVALID-TOKEN symbol)
+ (error "Invalid terminal symbol: %S" symbol))
+ (if (memq symbol token-list)
+ (message "*** duplicate terminal `%s' ignored" symbol)
+ ;; Set up properties
+ (wisent-set-prec symbol nil)
+ (wisent-set-assoc symbol nil)
+ (wisent-set-item-number symbol ntokens)
+ ;; Add
+ (setq ntokens (1+ ntokens)
+ token-list (cons symbol token-list))))
+
+(defun wisent-push-var (symbol &optional nocheck)
+ "Push a new SYMBOL in the list of nonterminals.
+Bypass checking if NOCHECK is non-nil."
+ ;; Check
+ (unless nocheck
+ (or (wisent-ISVALID-VAR symbol)
+ (error "Invalid nonterminal symbol: %S" symbol))
+ (if (memq symbol var-list)
+ (error "Nonterminal `%s' already defined" symbol)))
+ ;; Set up properties
+ (wisent-set-item-number symbol nvars)
+ ;; Add
+ (setq nvars (1+ nvars)
+ var-list (cons symbol var-list)))
+
+(defun wisent-parse-nonterminals (defs)
+ "Parse nonterminal definitions in DEFS.
+Fill in each element of the global arrays RPREC, RCODE, RUSEFUL with
+respectively rule precedence level, semantic action code and
+usefulness flag. Return a list of rules of the form (LHS . RHS) where
+LHS and RHS are respectively the Left Hand Side and Right Hand Side of
+the rule."
+ (setq rprec nil
+ rcode nil
+ nitems 0
+ nrules 0)
+ (let (def nonterm rlist rule rules rhs rest item items
+ rhl plevel semact @n @count iactn)
+ (setq @count 0)
+ (while defs
+ (setq def (car defs)
+ defs (cdr defs)
+ nonterm (car def)
+ rlist (cdr def)
+ iactn 0)
+ (or (consp rlist)
+ (error "Invalid nonterminal definition syntax: %S" def))
+ (while rlist
+ (setq rule (car rlist)
+ rlist (cdr rlist)
+ items (car rule)
+ rest (cdr rule)
+ rhl 0
+ rhs nil)
+
+ ;; Check & count items
+ (setq nitems (1+ nitems)) ;; LHS item
+ (while items
+ (setq item (car items)
+ items (cdr items)
+ nitems (1+ nitems)) ;; RHS items
+ (if (listp item)
+ ;; Mid-rule action
+ (progn
+ (setq @count (1+ @count)
+ @n (intern (format "@%d" @count)))
+ (wisent-push-var @n t)
+ ;; Push a new empty rule with the mid-rule action
+ (setq semact (vector item rhl (list nonterm iactn))
+ iactn (1+ iactn)
+ plevel nil
+ rcode (cons semact rcode)
+ rprec (cons plevel rprec)
+ item @n ;; Replace action by @N nonterminal
+ rules (cons (list item) rules)
+ nitems (1+ nitems)
+ nrules (1+ nrules)))
+ ;; Check terminal or nonterminal symbol
+ (cond
+ ((or (memq item token-list) (memq item var-list)))
+ ;; Create new literal character token
+ ((wisent-char-p item) (wisent-push-token item t))
+ ((error "Symbol `%s' is used, but is not defined as a token and
has no rules"
+ item))))
+ (setq rhl (1+ rhl)
+ rhs (cons item rhs)))
+
+ ;; Check & collect rule precedence level
+ (setq plevel (when (vectorp (car rest))
+ (setq item (car rest)
+ rest (cdr rest))
+ (if (and (= (length item) 1)
+ (memq (aref item 0) token-list)
+ (wisent-prec (aref item 0)))
+ (wisent-item-number (aref item 0))
+ (error "Invalid rule precedence level syntax: %S"
item)))
+ rprec (cons plevel rprec))
+
+ ;; Check & collect semantic action body
+ (setq semact (vector
+ (if rest
+ (if (cdr rest)
+ (error "Invalid semantic action syntax: %S" rest)
+ (car rest))
+ ;; Give a default semantic action body: nil
+ ;; for an empty rule or $1, the value of the
+ ;; first symbol in the rule, otherwise.
+ (if (> rhl 0) '$1 '()))
+ rhl
+ (list nonterm iactn))
+ iactn (1+ iactn)
+ rcode (cons semact rcode))
+ (setq rules (cons (cons nonterm (nreverse rhs)) rules)
+ nrules (1+ nrules))))
+
+ (setq ruseful (make-vector (1+ nrules) t)
+ rprec (vconcat (cons nil (nreverse rprec)))
+ rcode (vconcat (cons nil (nreverse rcode))))
+ (nreverse rules)
+ ))
+
+(defun wisent-parse-grammar (grammar &optional start-list)
+ "Parse GRAMMAR and build a suitable internal representation.
+Optional argument START-LIST defines the start symbols.
+GRAMMAR is a list of form: (TOKENS ASSOCS . NONTERMS)
+
+TOKENS is a list of terminal symbols (tokens).
+
+ASSOCS is nil or an alist of (ASSOC-TYPE . ASSOC-VALUE) elements
+describing the associativity of TOKENS. ASSOC-TYPE must be one of the
+`default-prec' `nonassoc', `left' or `right' symbols. When ASSOC-TYPE
+is `default-prec', ASSOC-VALUE must be nil or t (the default).
+Otherwise it is a list of tokens which must have been previously
+declared in TOKENS.
+
+NONTERMS is the list of non terminal definitions (see function
+`wisent-parse-nonterminals')."
+ (or (and (consp grammar) (> (length grammar) 2))
+ (error "Bad input grammar"))
+
+ (let (i r rhs pre dpre lst start-var assoc rules item
+ token var def tokens defs ep-token ep-var ep-def)
+
+ ;; Built-in tokens
+ (setq ntokens 0 nvars 0)
+ (wisent-push-token wisent-eoi-term t)
+ (wisent-push-token wisent-error-term t)
+
+ ;; Check/collect terminals
+ (setq lst (car grammar))
+ (while lst
+ (wisent-push-token (car lst))
+ (setq lst (cdr lst)))
+
+ ;; Check/Set up tokens precedence & associativity
+ (setq lst (nth 1 grammar)
+ pre 0
+ defs nil
+ dpre nil
+ default-prec t)
+ (while lst
+ (setq def (car lst)
+ assoc (car def)
+ tokens (cdr def)
+ lst (cdr lst))
+ (if (eq assoc 'default-prec)
+ (progn
+ (or (null (cdr tokens))
+ (memq (car tokens) '(t nil))
+ (error "Invalid default-prec value: %S" tokens))
+ (setq default-prec (car tokens))
+ (if dpre
+ (message "*** redefining default-prec to %s"
+ default-prec))
+ (setq dpre t))
+ (or (memq assoc '(left right nonassoc))
+ (error "Invalid associativity syntax: %S" assoc))
+ (setq pre (1+ pre))
+ (while tokens
+ (setq token (car tokens)
+ tokens (cdr tokens))
+ (if (memq token defs)
+ (message "*** redefining precedence of `%s'" token))
+ (or (memq token token-list)
+ ;; Define token not previously declared.
+ (wisent-push-token token))
+ (setq defs (cons token defs))
+ ;; Record the precedence and associativity of the terminal.
+ (wisent-set-prec token pre)
+ (wisent-set-assoc token assoc))))
+
+ ;; Check/Collect nonterminals
+ (setq lst (nthcdr 2 grammar)
+ defs nil)
+ (while lst
+ (setq def (car lst)
+ lst (cdr lst))
+ (or (consp def)
+ (error "Invalid nonterminal definition: %S" def))
+ (if (memq (car def) token-list)
+ (error "Nonterminal `%s' already defined as token" (car def)))
+ (wisent-push-var (car def))
+ (setq defs (cons def defs)))
+ (or defs
+ (error "No input grammar"))
+ (setq defs (nreverse defs))
+
+ ;; Set up the start symbol.
+ (setq start-table nil)
+ (cond
+
+ ;; 1. START-LIST is nil, the start symbol is the first
+ ;; nonterminal defined in the grammar (Bison like).
+ ((null start-list)
+ (setq start-var (caar defs)))
+
+ ;; 2. START-LIST contains only one element, it is the start
+ ;; symbol (Bison like).
+ ((or wisent-single-start-flag (null (cdr start-list)))
+ (setq start-var (car start-list))
+ (or (assq start-var defs)
+ (error "Start symbol `%s' has no rule" start-var)))
+
+ ;; 3. START-LIST contains more than one element. All defines
+ ;; potential start symbols. One of them (the first one by
+ ;; default) will be given at parse time to be the parser goal.
+ ;; If `wisent-single-start-flag' is non-nil that feature is
+ ;; disabled and the first nonterminal in START-LIST defines
+ ;; the start symbol, like in case 2 above.
+ ((not wisent-single-start-flag)
+
+ ;; START-LIST is a list of nonterminals '(nt0 ... ntN).
+ ;; Build and push ad hoc start rules in the grammar:
+
+ ;; ($STARTS ((nt0) $1) ((nt1) $1) ... ((ntN) $1))
+ ;; ($nt1 (($$nt1 nt1) $2))
+ ;; ...
+ ;; ($ntN (($$ntN ntN) $2))
+
+ ;; Where internal symbols $ntI and $$ntI are respectively
+ ;; nonterminals and terminals.
+
+ ;; The internal start symbol $STARTS is used to build the
+ ;; LALR(1) automaton. The true default start symbol used by the
+ ;; parser is the first nonterminal in START-LIST (nt0).
+ (setq start-var wisent-starts-nonterm
+ lst (nreverse start-list))
+ (while lst
+ (setq var (car lst)
+ lst (cdr lst))
+ (or (memq var var-list)
+ (error "Start symbol `%s' has no rule" var))
+ (unless (assq var start-table) ;; Ignore duplicates
+ ;; For each nt start symbol
+ (setq ep-var (intern (format "$%s" var))
+ ep-token (intern (format "$$%s" var)))
+ (wisent-push-token ep-token t)
+ (wisent-push-var ep-var t)
+ (setq
+ ;; Add entry (nt . $$nt) to start-table
+ start-table (cons (cons var ep-token) start-table)
+ ;; Add rule ($nt (($$nt nt) $2))
+ defs (cons (list ep-var (list (list ep-token var) '$2)) defs)
+ ;; Add start rule (($nt) $1)
+ ep-def (cons (list (list ep-var) '$1) ep-def))
+ ))
+ (wisent-push-var start-var t)
+ (setq defs (cons (cons start-var ep-def) defs))))
+
+ ;; Set up rules main data structure & RPREC, RCODE, RUSEFUL
+ (setq rules (wisent-parse-nonterminals defs))
+
+ ;; Set up the terminal & nonterminal lists.
+ (setq nsyms (+ ntokens nvars)
+ token-list (nreverse token-list)
+ lst var-list
+ var-list nil)
+ (while lst
+ (setq var (car lst)
+ lst (cdr lst)
+ var-list (cons var var-list))
+ (wisent-set-item-number ;; adjust nonterminal item number to
+ var (+ ntokens (wisent-item-number var)))) ;; I += NTOKENS
+
+ ;; Store special item numbers
+ (setq error-token-number (wisent-item-number wisent-error-term)
+ start-symbol (wisent-item-number start-var))
+
+ ;; Keep symbols in the TAGS vector so that TAGS[I] is the symbol
+ ;; associated to item number I.
+ (setq tags (vconcat token-list var-list))
+ ;; Set up RLHS RRHS & RITEM data structures from list of rules
+ ;; (LHS . RHS) received from `wisent-parse-nonterminals'.
+ (setq rlhs (make-vector (1+ nrules) nil)
+ rrhs (make-vector (1+ nrules) nil)
+ ritem (make-vector (1+ nitems) nil)
+ i 0
+ r 1)
+ (while rules
+ (aset rlhs r (wisent-item-number (caar rules)))
+ (aset rrhs r i)
+ (setq rhs (cdar rules)
+ pre nil)
+ (while rhs
+ (setq item (wisent-item-number (car rhs)))
+ ;; Get default precedence level of rule, that is the
+ ;; precedence of the last terminal in it.
+ (and (wisent-ISTOKEN item)
+ default-prec
+ (setq pre item))
+
+ (aset ritem i item)
+ (setq i (1+ i)
+ rhs (cdr rhs)))
+ ;; Setup the precedence level of the rule, that is the one
+ ;; specified by %prec or the default one.
+ (and (not (aref rprec r)) ;; Already set by %prec
+ pre
+ (wisent-prec (aref tags pre))
+ (aset rprec r pre))
+ (aset ritem i (- r))
+ (setq i (1+ i)
+ r (1+ r))
+ (setq rules (cdr rules)))
+ ))
+
+;;;; ---------------------
+;;;; Compile input grammar
+;;;; ---------------------
+
+(defun wisent-compile-grammar (grammar &optional start-list)
+ "Compile the LALR(1) GRAMMAR.
+
+GRAMMAR is a list (TOKENS ASSOCS . NONTERMS) where:
+
+- TOKENS is a list of terminal symbols (tokens).
+
+- ASSOCS is nil, or an alist of (ASSOC-TYPE . ASSOC-VALUE) elements
+ describing the associativity of TOKENS. ASSOC-TYPE must be one of
+ the `default-prec' `nonassoc', `left' or `right' symbols. When
+ ASSOC-TYPE is `default-prec', ASSOC-VALUE must be nil or t (the
+ default). Otherwise it is a list of tokens which must have been
+ previously declared in TOKENS.
+
+- NONTERMS is a list of nonterminal definitions.
+
+Optional argument START-LIST specify the possible grammar start
+symbols. This is a list of nonterminals which must have been
+previously declared in GRAMMAR's NONTERMS form. By default, the start
+symbol is the first nonterminal defined. When START-LIST contains
+only one element, it is the start symbol. Otherwise, all elements are
+possible start symbols, unless `wisent-single-start-flag' is non-nil.
+In that case, the first element is the start symbol, and others are
+ignored.
+
+Return an automaton as a vector: [ACTIONS GOTOS STARTS FUNCTIONS]
+where:
+
+- ACTIONS is a state/token matrix telling the parser what to do at
+ every state based on the current lookahead token. That is shift,
+ reduce, accept or error.
+
+- GOTOS is a state/nonterminal matrix telling the parser the next
+ state to go to after reducing with each rule.
+
+- STARTS is an alist which maps the allowed start nonterminal symbols
+ to tokens that will be first shifted into the parser stack.
+
+- FUNCTIONS is an obarray of semantic action symbols. Each symbol's
+ function definition is the semantic action lambda expression."
+ (if (wisent-automaton-p grammar)
+ grammar ;; Grammar already compiled just return it
+ (wisent-with-context compile-grammar
+ (let* ((gc-cons-threshold 1000000)
+ automaton)
+ (garbage-collect)
+ (setq wisent-new-log-flag t)
+ ;; Parse input grammar
+ (wisent-parse-grammar grammar start-list)
+ ;; Generate the LALR(1) automaton
+ (setq automaton (wisent-parser-automaton))
+ automaton))))
+
+;;;; --------------------------
+;;;; Byte compile input grammar
+;;;; --------------------------
+
+(require 'bytecomp)
+
+(defun wisent-byte-compile-grammar (form)
+ "Byte compile the `wisent-compile-grammar' FORM.
+Automatically called by the Emacs Lisp byte compiler as a
+`byte-compile' handler."
+ ;; Eval the `wisent-compile-grammar' form to obtain an LALR
+ ;; automaton internal data structure. Then, because the internal
+ ;; data structure contains an obarray, convert it to a lisp form so
+ ;; it can be byte-compiled.
+ (byte-compile-form (wisent-automaton-lisp-form (eval form))))
+
+(put 'wisent-compile-grammar 'byte-compile 'wisent-byte-compile-grammar)
+
+(defun wisent-automaton-lisp-form (automaton)
+ "Return a Lisp form that produces AUTOMATON.
+See also `wisent-compile-grammar' for more details on AUTOMATON."
+ (or (wisent-automaton-p automaton)
+ (signal 'wrong-type-argument
+ (list 'wisent-automaton-p automaton)))
+ (let ((obn (make-symbol "ob")) ; Generated obarray name
+ (obv (aref automaton 3)) ; Semantic actions obarray
+ )
+ `(let ((,obn (make-vector 13 0)))
+ ;; Generate code to initialize the semantic actions obarray,
+ ;; in local variable OBN.
+ ,@(let (obcode)
+ (mapatoms
+ #'(lambda (s)
+ (setq obcode
+ (cons `(fset (intern ,(symbol-name s) ,obn)
+ #',(symbol-function s))
+ obcode)))
+ obv)
+ obcode)
+ ;; Generate code to create the automaton.
+ (vector
+ ;; In code generated to initialize the action table, take
+ ;; care of symbols that are interned in the semantic actions
+ ;; obarray.
+ (vector
+ ,@(mapcar
+ #'(lambda (state) ;; for each state
+ `(list
+ ,@(mapcar
+ #'(lambda (tr) ;; for each transition
+ (let ((k (car tr)) ; token
+ (a (cdr tr))) ; action
+ (if (and (symbolp a)
+ (intern-soft (symbol-name a) obv))
+ `(cons ,(if (symbolp k) `(quote ,k) k)
+ (intern-soft ,(symbol-name a) ,obn))
+ `(quote ,tr))))
+ state)))
+ (aref automaton 0)))
+ ;; The code of the goto table is unchanged.
+ ,(aref automaton 1)
+ ;; The code of the alist of start symbols is unchanged.
+ ',(aref automaton 2)
+ ;; The semantic actions obarray is in the local variable OBN.
+ ,obn))))
+
+(provide 'semantic/wisent/comp)
+
+;;; semantic/wisent/comp.el ends here
Index: cedet/semantic/wisent/java-tags.el
===================================================================
RCS file: cedet/semantic/wisent/java-tags.el
diff -N cedet/semantic/wisent/java-tags.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/wisent/java-tags.el 28 Sep 2009 15:15:11 -0000 1.2
@@ -0,0 +1,122 @@
+;;; semantic/wisent/java-tags.el --- Java LALR parser for Emacs
+
+;;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: David Ponce <address@hidden>
+;; Maintainer: David Ponce <address@hidden>
+;; Created: 15 Dec 2001
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+
+;;; History:
+;;
+
+;;; Code:
+
+(require 'semantic/wisent)
+(require 'semantic/wisent/javat-wy)
+(require 'semantic/java)
+
+;;;;
+;;;; Simple parser error reporting function
+;;;;
+
+(defun wisent-java-parse-error (msg)
+ "Error reporting function called when a parse error occurs.
+MSG is the message string to report."
+;; (let ((error-start (nth 2 wisent-input)))
+;; (if (number-or-marker-p error-start)
+;; (goto-char error-start)))
+ (message msg)
+ ;;(debug)
+ )
+
+;;;;
+;;;; Local context
+;;;;
+
+(define-mode-local-override semantic-get-local-variables
+ java-mode ()
+ "Get local values from a specific context.
+Parse the current context for `field_declaration' nonterminals to
+collect tags, such as local variables or prototypes.
+This function override `get-local-variables'."
+ (let ((vars nil)
+ ;; We want nothing to do with funny syntaxing while doing this.
+ (semantic-unmatched-syntax-hook nil))
+ (while (not (semantic-up-context (point) 'function))
+ (save-excursion
+ (forward-char 1)
+ (setq vars
+ (append (semantic-parse-region
+ (point)
+ (save-excursion (semantic-end-of-context) (point))
+ 'field_declaration
+ 0 t)
+ vars))))
+ vars))
+
+;;;;
+;;;; Semantic integration of the Java LALR parser
+;;;;
+
+;;;###autoload
+(defun wisent-java-default-setup ()
+ "Hook run to setup Semantic in `java-mode'.
+Use the alternate LALR(1) parser."
+ (wisent-java-tags-wy--install-parser)
+ (setq
+ ;; Lexical analysis
+ semantic-lex-number-expression semantic-java-number-regexp
+ semantic-lex-analyzer 'wisent-java-tags-lexer
+ ;; Parsing
+ semantic-tag-expand-function 'semantic-java-expand-tag
+ ;; Environment
+ semantic-imenu-summary-function 'semantic-format-tag-prototype
+ imenu-create-index-function 'semantic-create-imenu-index
+ semantic-type-relation-separator-character '(".")
+ semantic-command-separation-character ";"
+ ;; speedbar and imenu buckets name
+ semantic-symbol->name-assoc-list-for-type-parts
+ ;; in type parts
+ '((type . "Classes")
+ (variable . "Variables")
+ (function . "Methods"))
+ semantic-symbol->name-assoc-list
+ ;; everywhere
+ (append semantic-symbol->name-assoc-list-for-type-parts
+ '((include . "Imports")
+ (package . "Package")))
+ ;; navigation inside 'type children
+ senator-step-at-tag-classes '(function variable)
+ )
+ ;; Setup javadoc stuff
+ (semantic-java-doc-setup))
+
+(provide 'semantic/wisent/java-tags)
+
+;; Local variables:
+;; generated-autoload-file: "../loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/wisent/java-tags"
+;; End:
+
+;;; semantic/wisent/java-tags.el ends here
Index: cedet/semantic/wisent/javascript.el
===================================================================
RCS file: cedet/semantic/wisent/javascript.el
diff -N cedet/semantic/wisent/javascript.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/wisent/javascript.el 28 Sep 2009 15:15:11 -0000 1.2
@@ -0,0 +1,103 @@
+;;; semantic/wisent/javascript.el --- javascript parser support
+
+;;; Copyright (C) 2005 Free Software Foundation, Inc.
+
+;; Author: Eric Ludlam <address@hidden>
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Parser support for javascript language.
+
+
+;;; Code:
+(require 'semantic/java)
+(require 'semantic/wisent)
+(require 'semantic/wisent/js-wy)
+
+(defun wisent-javascript-jv-expand-tag (tag)
+ "Expand TAG into a list of equivalent tags, or nil.
+Expand multiple variable declarations in the same statement, that is
+tags of class `variable' whose name is equal to a list of elements of
+the form (NAME VALUE START . END). NAME is a variable name. VALUE is
+an initializer START and END are the bounds in the declaration, related
+to this variable NAME."
+ (let (elts elt value clone start end xpand)
+ (when (and (eq 'variable (semantic-tag-class tag))
+ (consp (setq elts (semantic-tag-name tag))))
+ ;; There are multiple names in the same variable declaration.
+ (while elts
+ ;; For each name element, clone the initial tag and give it
+ ;; the name of the element.
+ (setq elt (car elts)
+ elts (cdr elts)
+ clone (semantic-tag-clone tag (car elt))
+ value (car (cdr elt))
+ start (if elts (caddr elt) (semantic-tag-start tag))
+ end (if xpand (cdddr elt) (semantic-tag-end tag))
+ xpand (cons clone xpand))
+ ;; Set the definition of the cloned tag
+ (semantic-tag-put-attribute clone :default-value value)
+ ;; Set the bounds of the cloned tag with those of the name
+ ;; element.
+ (semantic-tag-set-bounds clone start end))
+ xpand)))
+
+;;; Override Methods
+;;
+;; These methods override aspects of how semantic-tools can access
+;; the tags created by the javascript parser.
+;; Local context
+(define-mode-overload-implementation semantic-get-local-variables
+ javascript-mode ()
+ "Get local values from a specific context.
+This function overrides `get-local-variables'."
+ ;; Does javascript have identifiable local variables?
+ nil)
+
+
+;;; Setup Function
+;;
+;; This sets up the javascript parser
+
+;;;###autoload
+(defun wisent-javascript-setup-parser ()
+ "Setup buffer for parse."
+ (wisent-javascript-jv-wy--install-parser)
+ (setq
+ ;; Lexical Analysis
+ semantic-lex-analyzer 'javascript-lexer-jv
+ semantic-lex-number-expression semantic-java-number-regexp
+ ;; semantic-lex-depth nil ;; Full lexical analysis
+ ;; Parsing
+ semantic-tag-expand-function 'wisent-javascript-jv-expand-tag
+ ;; Environment
+ semantic-imenu-summary-function 'semantic-format-tag-name
+ imenu-create-index-function 'semantic-create-imenu-index
+ semantic-command-separation-character ";"
+ ))
+
+(provide 'semantic/wisent/javascript-jv)
+
+;; Local variables:
+;; generated-autoload-file: "../loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/wisent/javascript"
+;; End:
+
+;;; semantic/wisent/javascript-jv.el ends here
Index: cedet/semantic/wisent/javat-wy.el
===================================================================
RCS file: cedet/semantic/wisent/javat-wy.el
diff -N cedet/semantic/wisent/javat-wy.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/wisent/javat-wy.el 28 Sep 2009 15:15:11 -0000 1.2
@@ -0,0 +1,682 @@
+;;; semantic/wisent/javat-wy.el --- Generated parser support file
+
+;; Copyright (C) 2002, 2007 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; This file was generated from the grammar file
+;; semantic/wisent/wisent-java-tags.wy in the CEDET repository.
+
+;;; Code:
+
+(require 'semantic/lex)
+
+
+;;; Prologue
+;;
+
+;;; Declarations
+;;
+(defconst wisent-java-tags-wy--keyword-table
+ (semantic-lex-make-keyword-table
+ '(("abstract" . ABSTRACT)
+ ("boolean" . BOOLEAN)
+ ("break" . BREAK)
+ ("byte" . BYTE)
+ ("case" . CASE)
+ ("catch" . CATCH)
+ ("char" . CHAR)
+ ("class" . CLASS)
+ ("const" . CONST)
+ ("continue" . CONTINUE)
+ ("default" . DEFAULT)
+ ("do" . DO)
+ ("double" . DOUBLE)
+ ("else" . ELSE)
+ ("extends" . EXTENDS)
+ ("final" . FINAL)
+ ("finally" . FINALLY)
+ ("float" . FLOAT)
+ ("for" . FOR)
+ ("goto" . GOTO)
+ ("if" . IF)
+ ("implements" . IMPLEMENTS)
+ ("import" . IMPORT)
+ ("instanceof" . INSTANCEOF)
+ ("int" . INT)
+ ("interface" . INTERFACE)
+ ("long" . LONG)
+ ("native" . NATIVE)
+ ("new" . NEW)
+ ("package" . PACKAGE)
+ ("private" . PRIVATE)
+ ("protected" . PROTECTED)
+ ("public" . PUBLIC)
+ ("return" . RETURN)
+ ("short" . SHORT)
+ ("static" . STATIC)
+ ("strictfp" . STRICTFP)
+ ("super" . SUPER)
+ ("switch" . SWITCH)
+ ("synchronized" . SYNCHRONIZED)
+ ("this" . THIS)
+ ("throw" . THROW)
+ ("throws" . THROWS)
+ ("transient" . TRANSIENT)
+ ("try" . TRY)
+ ("void" . VOID)
+ ("volatile" . VOLATILE)
+ ("while" . WHILE)
+ ("@author" . _AUTHOR)
+ ("@version" . _VERSION)
+ ("@param" . _PARAM)
+ ("@return" . _RETURN)
+ ("@exception" . _EXCEPTION)
+ ("@throws" . _THROWS)
+ ("@see" . _SEE)
+ ("@since" . _SINCE)
+ ("@serial" . _SERIAL)
+ ("@serialData" . _SERIALDATA)
+ ("@serialField" . _SERIALFIELD)
+ ("@deprecated" . _DEPRECATED))
+ '(("@deprecated" javadoc
+ (seq 12 usage
+ (type function variable)
+ opt t))
+ ("@serialField" javadoc
+ (seq 11 usage
+ (variable)
+ opt t))
+ ("@serialData" javadoc
+ (seq 10 usage
+ (function)
+ opt t))
+ ("@serial" javadoc
+ (seq 9 usage
+ (variable)
+ opt t))
+ ("@since" javadoc
+ (seq 8 usage
+ (type function variable)
+ opt t))
+ ("@see" javadoc
+ (seq 7 usage
+ (type function variable)
+ opt t with-ref t))
+ ("@throws" javadoc
+ (seq 6 usage
+ (function)
+ with-name t))
+ ("@exception" javadoc
+ (seq 5 usage
+ (function)
+ with-name t))
+ ("@return" javadoc
+ (seq 4 usage
+ (function)))
+ ("@param" javadoc
+ (seq 3 usage
+ (function)
+ with-name t))
+ ("@version" javadoc
+ (seq 2 usage
+ (type)))
+ ("@author" javadoc
+ (seq 1 usage
+ (type)))
+ ("while" summary "while (<expr>) <stmt> | do <stmt> while (<expr>);")
+ ("volatile" summary "Field declaration modifier: volatile <type> <name>
...")
+ ("void" summary "Method return type: void <name> ...")
+ ("try" summary "try {<stmts>} [catch(<parm>) {<stmts>} ...] [finally
{<stmts>}]")
+ ("transient" summary "Field declaration modifier: transient <type> <name>
...")
+ ("throws" summary "Method|Constructor declaration: throws <classType>,
...")
+ ("throw" summary "throw <expr> ;")
+ ("synchronized" summary "synchronized (<expr>) ... | Method decl.
modifier: synchronized <type> <name> ...")
+ ("switch" summary "switch(<expr>) {[case <const-expr>: <stmts> ...]
[default: <stmts>]}")
+ ("strictfp" summary "Declaration modifier: strictfp
{class|interface|<type>} <name> ...")
+ ("static" summary "Declaration modifier: static {class|interface|<type>}
<name> ...")
+ ("short" summary "Integral primitive type (-32768 to 32767)")
+ ("return" summary "return [<expr>] ;")
+ ("public" summary "Access level modifier: public {class|interface|<type>}
<name> ...")
+ ("protected" summary "Access level modifier: protected
{class|interface|<type>} <name> ...")
+ ("private" summary "Access level modifier: private
{class|interface|<type>} <name> ...")
+ ("package" summary "Package declaration: package <name>")
+ ("native" summary "Method declaration modifier: native <type> <name> ...")
+ ("long" summary "Integral primitive type (-9223372036854775808 to
9223372036854775807)")
+ ("interface" summary "Interface declaration: interface <name>")
+ ("int" summary "Integral primitive type (-2147483648 to 2147483647)")
+ ("import" summary "Import package declarations: import <package>")
+ ("implements" summary "Class SuperInterfaces declaration: implements
<name> [, ...]")
+ ("if" summary "if (<expr>) <stmt> [else <stmt>]")
+ ("goto" summary "Unused reserved word")
+ ("for" summary "for ([<init-expr>]; [<expr>]; [<update-expr>]) <stmt>")
+ ("float" summary "Primitive floating-point type (single-precision 32-bit
IEEE 754)")
+ ("finally" summary "try {<stmts>} ... finally {<stmts>}")
+ ("final" summary "Class|Member declaration modifier: final {class|<type>}
<name> ...")
+ ("extends" summary "SuperClass|SuperInterfaces declaration: extends
<name> [, ...]")
+ ("else" summary "if (<expr>) <stmt> else <stmt>")
+ ("double" summary "Primitive floating-point type (double-precision 64-bit
IEEE 754)")
+ ("do" summary "do <stmt> while (<expr>);")
+ ("default" summary "switch(<expr>) { ... default: <stmts>}")
+ ("continue" summary "continue [<label>] ;")
+ ("const" summary "Unused reserved word")
+ ("class" summary "Class declaration: class <name>")
+ ("char" summary "Integral primitive type (' ' to 'ï¿¿') (0 to 65535)")
+ ("catch" summary "try {<stmts>} catch(<parm>) {<stmts>} ... ")
+ ("case" summary "switch(<expr>) {case <const-expr>: <stmts> ... }")
+ ("byte" summary "Integral primitive type (-128 to 127)")
+ ("break" summary "break [<label>] ;")
+ ("boolean" summary "Primitive logical quantity type (true or false)")
+ ("abstract" summary "Class|Method declaration modifier: abstract
{class|<type>} <name> ...")))
+ "Table of language keywords.")
+
+(defconst wisent-java-tags-wy--token-table
+ (semantic-lex-make-type-table
+ '(("unicode"
+ (unicodecharacter))
+ ("number"
+ (NUMBER_LITERAL))
+ ("string"
+ (STRING_LITERAL))
+ ("symbol"
+ (IDENTIFIER))
+ ("punctuation"
+ (COMP . "~")
+ (OROR . "||")
+ (OREQ . "|=")
+ (OR . "|")
+ (XOREQ . "^=")
+ (XOR . "^")
+ (QUESTION . "?")
+ (URSHIFTEQ . ">>>=")
+ (URSHIFT . ">>>")
+ (RSHIFTEQ . ">>=")
+ (RSHIFT . ">>")
+ (GTEQ . ">=")
+ (GT . ">")
+ (EQEQ . "==")
+ (EQ . "=")
+ (LTEQ . "<=")
+ (LSHIFTEQ . "<<=")
+ (LSHIFT . "<<")
+ (LT . "<")
+ (SEMICOLON . ";")
+ (COLON . ":")
+ (DIVEQ . "/=")
+ (DIV . "/")
+ (DOT . ".")
+ (MINUSEQ . "-=")
+ (MINUSMINUS . "--")
+ (MINUS . "-")
+ (COMMA . ",")
+ (PLUSEQ . "+=")
+ (PLUSPLUS . "++")
+ (PLUS . "+")
+ (MULTEQ . "*=")
+ (MULT . "*")
+ (ANDEQ . "&=")
+ (ANDAND . "&&")
+ (AND . "&")
+ (MODEQ . "%=")
+ (MOD . "%")
+ (NOTEQ . "!=")
+ (NOT . "!"))
+ ("close-paren"
+ (RBRACK . "]")
+ (RBRACE . "}")
+ (RPAREN . ")"))
+ ("open-paren"
+ (LBRACK . "[")
+ (LBRACE . "{")
+ (LPAREN . "("))
+ ("block"
+ (BRACK_BLOCK . "(LBRACK RBRACK)")
+ (BRACE_BLOCK . "(LBRACE RBRACE)")
+ (PAREN_BLOCK . "(LPAREN RPAREN)")))
+ '(("keyword" :declared t)
+ ("unicode" syntax "\\\\u[0-9a-f][0-9a-f][0-9a-f][0-9a-f]")
+ ("unicode" :declared t)
+ ("number" :declared t)
+ ("string" :declared t)
+ ("symbol" :declared t)
+ ("punctuation" :declared t)
+ ("block" :declared t)))
+ "Table of lexical tokens.")
+
+(defconst wisent-java-tags-wy--parse-table
+ (progn
+ (eval-when-compile
+ (require 'semantic/wisent/comp))
+ (wisent-compile-grammar
+ '((PAREN_BLOCK BRACE_BLOCK BRACK_BLOCK LPAREN RPAREN LBRACE RBRACE LBRACK
RBRACK NOT NOTEQ MOD MODEQ AND ANDAND ANDEQ MULT MULTEQ PLUS PLUSPLUS PLUSEQ
COMMA MINUS MINUSMINUS MINUSEQ DOT DIV DIVEQ COLON SEMICOLON LT LSHIFT LSHIFTEQ
LTEQ EQ EQEQ GT GTEQ RSHIFT RSHIFTEQ URSHIFT URSHIFTEQ QUESTION XOR XOREQ OR
OREQ OROR COMP IDENTIFIER STRING_LITERAL NUMBER_LITERAL unicodecharacter
ABSTRACT BOOLEAN BREAK BYTE CASE CATCH CHAR CLASS CONST CONTINUE DEFAULT DO
DOUBLE ELSE EXTENDS FINAL FINALLY FLOAT FOR GOTO IF IMPLEMENTS IMPORT
INSTANCEOF INT INTERFACE LONG NATIVE NEW PACKAGE PRIVATE PROTECTED PUBLIC
RETURN SHORT STATIC STRICTFP SUPER SWITCH SYNCHRONIZED THIS THROW THROWS
TRANSIENT TRY VOID VOLATILE WHILE _AUTHOR _VERSION _PARAM _RETURN _EXCEPTION
_THROWS _SEE _SINCE _SERIAL _SERIALDATA _SERIALFIELD _DEPRECATED)
+ nil
+ (compilation_unit
+ ((package_declaration))
+ ((import_declaration))
+ ((type_declaration)))
+ (package_declaration
+ ((PACKAGE qualified_name SEMICOLON)
+ (wisent-raw-tag
+ (semantic-tag-new-package $2 nil))))
+ (import_declaration
+ ((IMPORT qualified_name SEMICOLON)
+ (wisent-raw-tag
+ (semantic-tag-new-include $2 nil)))
+ ((IMPORT qualified_name DOT MULT SEMICOLON)
+ (wisent-raw-tag
+ (semantic-tag-new-include
+ (concat $2 $3 $4)
+ nil))))
+ (type_declaration
+ ((SEMICOLON)
+ nil)
+ ((class_declaration))
+ ((interface_declaration)))
+ (class_declaration
+ ((modifiers_opt CLASS qualified_name superc_opt interfaces_opt
class_body)
+ (wisent-raw-tag
+ (semantic-tag-new-type $3 $2 $6
+ (if
+ (or $4 $5)
+ (cons $4 $5))
+ :typemodifiers $1))))
+ (superc_opt
+ (nil)
+ ((EXTENDS qualified_name)
+ (identity $2)))
+ (interfaces_opt
+ (nil)
+ ((IMPLEMENTS qualified_name_list)
+ (nreverse $2)))
+ (class_body
+ ((BRACE_BLOCK)
+ (semantic-parse-region
+ (car $region1)
+ (cdr $region1)
+ 'class_member_declaration 1)))
+ (class_member_declaration
+ ((LBRACE)
+ nil)
+ ((RBRACE)
+ nil)
+ ((block)
+ nil)
+ ((static_initializer)
+ nil)
+ ((constructor_declaration))
+ ((interface_declaration))
+ ((class_declaration))
+ ((method_declaration))
+ ((field_declaration)))
+ (interface_declaration
+ ((modifiers_opt INTERFACE IDENTIFIER extends_interfaces_opt
interface_body)
+ (wisent-raw-tag
+ (semantic-tag-new-type $3 $2 $5
+ (if $4
+ (cons nil $4))
+ :typemodifiers $1))))
+ (extends_interfaces_opt
+ (nil)
+ ((EXTENDS qualified_name_list)
+ (identity $2)))
+ (interface_body
+ ((BRACE_BLOCK)
+ (semantic-parse-region
+ (car $region1)
+ (cdr $region1)
+ 'interface_member_declaration 1)))
+ (interface_member_declaration
+ ((LBRACE)
+ nil)
+ ((RBRACE)
+ nil)
+ ((interface_declaration))
+ ((class_declaration))
+ ((method_declaration))
+ ((field_declaration)))
+ (static_initializer
+ ((STATIC block)))
+ (constructor_declaration
+ ((modifiers_opt constructor_declarator throwsc_opt constructor_body)
+ (wisent-raw-tag
+ (semantic-tag-new-function
+ (car $2)
+ nil
+ (cdr $2)
+ :typemodifiers $1 :throws $3 :constructor-flag t))))
+ (constructor_declarator
+ ((IDENTIFIER formal_parameter_list)
+ (cons $1 $2)))
+ (constructor_body
+ ((block)))
+ (method_declaration
+ ((modifiers_opt VOID method_declarator throwsc_opt method_body)
+ (wisent-raw-tag
+ (semantic-tag-new-function
+ (car $3)
+ $2
+ (cdr $3)
+ :typemodifiers $1 :throws $4)))
+ ((modifiers_opt type method_declarator throwsc_opt method_body)
+ (wisent-raw-tag
+ (semantic-tag-new-function
+ (car $3)
+ $2
+ (cdr $3)
+ :typemodifiers $1 :throws $4))))
+ (method_declarator
+ ((IDENTIFIER formal_parameter_list dims_opt)
+ (cons
+ (concat $1 $3)
+ $2)))
+ (throwsc_opt
+ (nil)
+ ((THROWS qualified_name_list)
+ (nreverse $2)))
+ (qualified_name_list
+ ((qualified_name_list COMMA qualified_name)
+ (cons $3 $1))
+ ((qualified_name)
+ (list $1)))
+ (method_body
+ ((SEMICOLON))
+ ((block)))
+ (block
+ ((BRACE_BLOCK)))
+ (formal_parameter_list
+ ((PAREN_BLOCK)
+ (semantic-parse-region
+ (car $region1)
+ (cdr $region1)
+ 'formal_parameters 1)))
+ (formal_parameters
+ ((LPAREN)
+ nil)
+ ((RPAREN)
+ nil)
+ ((formal_parameter COMMA))
+ ((formal_parameter RPAREN)))
+ (formal_parameter
+ ((formal_parameter_modifier_opt type variable_declarator_id)
+ (wisent-raw-tag
+ (semantic-tag-new-variable $3 $2 nil :typemodifiers $1))))
+ (formal_parameter_modifier_opt
+ (nil)
+ ((FINAL)
+ (list $1)))
+ (field_declaration
+ ((modifiers_opt type variable_declarators SEMICOLON)
+ (wisent-raw-tag
+ (semantic-tag-new-variable $3 $2 nil :typemodifiers $1))))
+ (variable_declarators
+ ((variable_declarators COMMA variable_declarator)
+ (progn
+ (setcdr
+ (cdr
+ (car $1))
+ (cdr $region2))
+ (cons $3 $1)))
+ ((variable_declarator)
+ (list $1)))
+ (variable_declarator
+ ((variable_declarator_id EQ variable_initializer)
+ (cons $1 $region))
+ ((variable_declarator_id)
+ (cons $1 $region)))
+ (variable_declarator_id
+ ((IDENTIFIER dims_opt)
+ (concat $1 $2)))
+ (variable_initializer
+ ((expression)))
+ (expression
+ ((expression term))
+ ((term)))
+ (term
+ ((literal))
+ ((operator))
+ ((primitive_type))
+ ((IDENTIFIER))
+ ((BRACK_BLOCK))
+ ((PAREN_BLOCK))
+ ((BRACE_BLOCK))
+ ((NEW))
+ ((CLASS))
+ ((THIS))
+ ((SUPER)))
+ (literal
+ ((STRING_LITERAL))
+ ((NUMBER_LITERAL)))
+ (operator
+ ((NOT))
+ ((PLUS))
+ ((PLUSPLUS))
+ ((MINUS))
+ ((MINUSMINUS))
+ ((NOTEQ))
+ ((MOD))
+ ((MODEQ))
+ ((AND))
+ ((ANDAND))
+ ((ANDEQ))
+ ((MULT))
+ ((MULTEQ))
+ ((PLUSEQ))
+ ((MINUSEQ))
+ ((DOT))
+ ((DIV))
+ ((DIVEQ))
+ ((COLON))
+ ((LT))
+ ((LSHIFT))
+ ((LSHIFTEQ))
+ ((LTEQ))
+ ((EQ))
+ ((EQEQ))
+ ((GT))
+ ((GTEQ))
+ ((RSHIFT))
+ ((RSHIFTEQ))
+ ((URSHIFT))
+ ((URSHIFTEQ))
+ ((QUESTION))
+ ((XOR))
+ ((XOREQ))
+ ((OR))
+ ((OREQ))
+ ((OROR))
+ ((COMP))
+ ((INSTANCEOF)))
+ (primitive_type
+ ((BOOLEAN))
+ ((CHAR))
+ ((LONG))
+ ((INT))
+ ((SHORT))
+ ((BYTE))
+ ((DOUBLE))
+ ((FLOAT)))
+ (modifiers_opt
+ (nil)
+ ((modifiers)
+ (nreverse $1)))
+ (modifiers
+ ((modifiers modifier)
+ (cons $2 $1))
+ ((modifier)
+ (list $1)))
+ (modifier
+ ((STRICTFP))
+ ((VOLATILE))
+ ((TRANSIENT))
+ ((SYNCHRONIZED))
+ ((NATIVE))
+ ((FINAL))
+ ((ABSTRACT))
+ ((STATIC))
+ ((PRIVATE))
+ ((PROTECTED))
+ ((PUBLIC)))
+ (type
+ ((qualified_name dims_opt)
+ (concat $1 $2))
+ ((primitive_type dims_opt)
+ (concat $1 $2)))
+ (qualified_name
+ ((qualified_name DOT IDENTIFIER)
+ (concat $1 $2 $3))
+ ((IDENTIFIER)))
+ (dims_opt
+ (nil
+ (identity ""))
+ ((dims)))
+ (dims
+ ((dims BRACK_BLOCK)
+ (concat $1 "[]"))
+ ((BRACK_BLOCK)
+ (identity "[]"))))
+ '(compilation_unit package_declaration import_declaration
class_declaration field_declaration method_declaration formal_parameter
constructor_declaration interface_declaration class_member_declaration
interface_member_declaration formal_parameters)))
+ "Parser table.")
+
+(defun wisent-java-tags-wy--install-parser ()
+ "Setup the Semantic Parser."
+ (semantic-install-function-overrides
+ '((parse-stream . wisent-parse-stream)))
+ (setq semantic-parser-name "LALR"
+ semantic--parse-table wisent-java-tags-wy--parse-table
+ semantic-debug-parser-source "wisent-java-tags.wy"
+ semantic-flex-keywords-obarray wisent-java-tags-wy--keyword-table
+ semantic-lex-types-obarray wisent-java-tags-wy--token-table)
+ ;; Collect unmatched syntax lexical tokens
+ (semantic-make-local-hook 'wisent-discarding-token-functions)
+ (add-hook 'wisent-discarding-token-functions
+ 'wisent-collect-unmatched-syntax nil t))
+
+
+;;; Analyzers
+;;
+(define-lex-keyword-type-analyzer
wisent-java-tags-wy--<keyword>-keyword-analyzer
+ "keyword analyzer for <keyword> tokens."
+ "\\(\\sw\\|\\s_\\)+")
+
+(define-lex-block-type-analyzer wisent-java-tags-wy--<block>-block-analyzer
+ "block analyzer for <block> tokens."
+ "\\s(\\|\\s)"
+ '((("(" LPAREN PAREN_BLOCK)
+ ("{" LBRACE BRACE_BLOCK)
+ ("[" LBRACK BRACK_BLOCK))
+ (")" RPAREN)
+ ("}" RBRACE)
+ ("]" RBRACK))
+ )
+
+(define-lex-regex-type-analyzer wisent-java-tags-wy--<symbol>-regexp-analyzer
+ "regexp analyzer for <symbol> tokens."
+ "\\(\\sw\\|\\s_\\)+"
+ nil
+ 'IDENTIFIER)
+
+(define-lex-sexp-type-analyzer wisent-java-tags-wy--<string>-sexp-analyzer
+ "sexp analyzer for <string> tokens."
+ "\\s\""
+ 'STRING_LITERAL)
+
+(define-lex-regex-type-analyzer wisent-java-tags-wy--<number>-regexp-analyzer
+ "regexp analyzer for <number> tokens."
+ semantic-lex-number-expression
+ nil
+ 'NUMBER_LITERAL)
+
+(define-lex-string-type-analyzer
wisent-java-tags-wy--<punctuation>-string-analyzer
+ "string analyzer for <punctuation> tokens."
+ "\\(\\s.\\|\\s$\\|\\s'\\)+"
+ '((COMP . "~")
+ (OROR . "||")
+ (OREQ . "|=")
+ (OR . "|")
+ (XOREQ . "^=")
+ (XOR . "^")
+ (QUESTION . "?")
+ (URSHIFTEQ . ">>>=")
+ (URSHIFT . ">>>")
+ (RSHIFTEQ . ">>=")
+ (RSHIFT . ">>")
+ (GTEQ . ">=")
+ (GT . ">")
+ (EQEQ . "==")
+ (EQ . "=")
+ (LTEQ . "<=")
+ (LSHIFTEQ . "<<=")
+ (LSHIFT . "<<")
+ (LT . "<")
+ (SEMICOLON . ";")
+ (COLON . ":")
+ (DIVEQ . "/=")
+ (DIV . "/")
+ (DOT . ".")
+ (MINUSEQ . "-=")
+ (MINUSMINUS . "--")
+ (MINUS . "-")
+ (COMMA . ",")
+ (PLUSEQ . "+=")
+ (PLUSPLUS . "++")
+ (PLUS . "+")
+ (MULTEQ . "*=")
+ (MULT . "*")
+ (ANDEQ . "&=")
+ (ANDAND . "&&")
+ (AND . "&")
+ (MODEQ . "%=")
+ (MOD . "%")
+ (NOTEQ . "!=")
+ (NOT . "!"))
+ 'punctuation)
+
+(define-lex-regex-type-analyzer wisent-java-tags-wy--<unicode>-regexp-analyzer
+ "regexp analyzer for <unicode> tokens."
+ "\\\\u[0-9a-f][0-9a-f][0-9a-f][0-9a-f]"
+ nil
+ 'unicodecharacter)
+
+
+;;; Epilogue
+;;
+;; Define the lexer for this grammar
+(define-lex wisent-java-tags-lexer
+ "Lexical analyzer that handles Java buffers.
+It ignores whitespaces, newlines and comments."
+ semantic-lex-ignore-whitespace
+ semantic-lex-ignore-newline
+ semantic-lex-ignore-comments
+ ;;;; Auto-generated analyzers.
+ wisent-java-tags-wy--<number>-regexp-analyzer
+ wisent-java-tags-wy--<string>-sexp-analyzer
+ ;; Must detect keywords before other symbols
+ wisent-java-tags-wy--<keyword>-keyword-analyzer
+ wisent-java-tags-wy--<symbol>-regexp-analyzer
+ wisent-java-tags-wy--<punctuation>-string-analyzer
+ wisent-java-tags-wy--<block>-block-analyzer
+ ;; In theory, unicode chars should be turned into normal chars
+ ;; and then combined into regular ascii keywords and text. This
+ ;; analyzer just keeps these things from making the lexer go boom.
+ wisent-java-tags-wy--<unicode>-regexp-analyzer
+ ;;;;
+ semantic-lex-default-action)
+
+(provide 'semantic/wisent/javat-wy)
+
+;;; semantic/wisent/javat-wy.el ends here
Index: cedet/semantic/wisent/js-wy.el
===================================================================
RCS file: cedet/semantic/wisent/js-wy.el
diff -N cedet/semantic/wisent/js-wy.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/wisent/js-wy.el 28 Sep 2009 15:15:11 -0000 1.2
@@ -0,0 +1,491 @@
+;;; semantic/wisent/js-wy.el --- Generated parser support file
+
+;; Copyright (C) 2005 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; This file was generated from the grammar file
+;; semantic/wisent/wisent-javascript-jv.wy in the CEDET repository.
+
+;;; Code:
+(require 'semantic/lex)
+
+;;; Prologue
+;;
+
+;;; Declarations
+;;
+(defconst wisent-javascript-jv-wy--keyword-table
+ (semantic-lex-make-keyword-table
+ '(("if" . IF)
+ ("break" . BREAK)
+ ("continue" . CONTINUE)
+ ("else" . ELSE)
+ ("for" . FOR)
+ ("function" . FUNCTION)
+ ("this" . THIS)
+ ("return" . RETURN)
+ ("while" . WHILE)
+ ("void" . VOID_SYMBOL)
+ ("new" . NEW)
+ ("delete" . DELETE)
+ ("var" . VAR)
+ ("with" . WITH)
+ ("typeof" . TYPEOF)
+ ("in" . IN))
+ '(("in" summary "in something")
+ ("typeof" summary "typeof ")
+ ("with" summary "with ")
+ ("var" summary "var <variablename> [= value];")
+ ("delete" summary "delete(<objectreference>) - Deletes the object.")
+ ("new" summary "new <objecttype> - Creates a new object.")
+ ("void" summary "Method return type: void <name> ...")
+ ("while" summary "while (<expr>) <stmt> | do <stmt> while (<expr>);")
+ ("return" summary "return [<expr>] ;")
+ ("this" summary "this")
+ ("function" summary "function declaration blah blah")
+ ("for" summary "for ([<init-expr>]; [<expr>]; [<update-expr>]) <stmt>")
+ ("else" summary "if (<expr>) <stmt> else <stmt>")
+ ("continue" summary "continue [<label>] ;")
+ ("break" summary "break [<label>] ;")
+ ("if" summary "if (<expr>) <stmt> [else <stmt>] (jv)")))
+ "Table of language keywords.")
+
+(defconst wisent-javascript-jv-wy--token-table
+ (semantic-lex-make-type-table
+ '(("<no-type>"
+ (NULL_TOKEN)
+ (QUERY)
+ (TRUE)
+ (FALSE))
+ ("number"
+ (NUMBER))
+ ("string"
+ (STRING))
+ ("symbol"
+ (VARIABLE))
+ ("close-paren"
+ (CLOSE_SQ_BRACKETS . "]")
+ (END_BLOCK . "}")
+ (CLOSE_PARENTHESIS . ")"))
+ ("open-paren"
+ (OPEN_SQ_BRACKETS . "[")
+ (START_BLOCK . "{")
+ (OPEN_PARENTHESIS . "("))
+ ("block"
+ (BRACK_BLOCK . "(OPEN_SQ_BRACKETS CLOSE_SQ_BRACKETS)")
+ (BRACE_BLOCK . "(START_BLOCK END_BLOCK)")
+ (PAREN_BLOCK . "(OPEN_PARENTHESIS CLOSE_PARENTHESIS)"))
+ ("punctuation"
+ (ONES_COMPLIMENT . "~")
+ (SEMICOLON . ";")
+ (LINE_TERMINATOR . "\n")
+ (LESS_THAN . "<")
+ (DOT . ".")
+ (COMMA . ",")
+ (COLON . ":")
+ (DIV . "/")
+ (DECREMENT . "--")
+ (INCREMENT . "++")
+ (PLUS_EQUALS . "+=")
+ (PLUS . "+")
+ (MULTIPLY_EQUALS . "*=")
+ (MULTIPLY . "*")
+ (MOD_EQUALS . "%=")
+ (MOD . "%")
+ (MINUS_EQUALS . "-=")
+ (MINUS . "-")
+ (LS_EQUAL . "<=")
+ (LOGICAL_NOT . "!!")
+ (LOGICAL_OR . "||")
+ (LOGICAL_AND . "&&")
+ (GT_EQUAL . ">=")
+ (GREATER_THAN . ">")
+ (EQUALS . "==")
+ (DIV_EQUALS . "/=")
+ (NOT_EQUAL . "!=")
+ (BITWISE_SHIFT_RIGHT_ZERO_FILL_EQUALS . ">>>=")
+ (BITWISE_SHIFT_RIGHT_ZERO_FILL . ">>>")
+ (BITWISE_SHIFT_RIGHT_EQUALS . ">>=")
+ (BITWISE_SHIFT_RIGHT . ">>")
+ (BITWISE_SHIFT_LEFT_EQUALS . "<<=")
+ (BITWISE_SHIFT_LEFT . "<<")
+ (BITWISE_OR_EQUALS . "|=")
+ (BITWISE_OR . "|")
+ (BITWISE_EXCLUSIVE_OR_EQUALS . "^=")
+ (BITWISE_EXCLUSIVE_OR . "^")
+ (BITWISE_AND_EQUALS . "&=")
+ (BITWISE_AND . "&")
+ (ASSIGN_SYMBOL . "=")))
+ '(("number" :declared t)
+ ("string" :declared t)
+ ("symbol" :declared t)
+ ("keyword" :declared t)
+ ("block" :declared t)
+ ("punctuation" :declared t)))
+ "Table of lexical tokens.")
+
+(defconst wisent-javascript-jv-wy--parse-table
+ (progn
+ (eval-when-compile
+ (require 'semantic/wisent/comp))
+ (wisent-compile-grammar
+ '((ASSIGN_SYMBOL BITWISE_AND BITWISE_AND_EQUALS BITWISE_EXCLUSIVE_OR
BITWISE_EXCLUSIVE_OR_EQUALS BITWISE_OR BITWISE_OR_EQUALS BITWISE_SHIFT_LEFT
BITWISE_SHIFT_LEFT_EQUALS BITWISE_SHIFT_RIGHT BITWISE_SHIFT_RIGHT_EQUALS
BITWISE_SHIFT_RIGHT_ZERO_FILL BITWISE_SHIFT_RIGHT_ZERO_FILL_EQUALS NOT_EQUAL
DIV_EQUALS EQUALS GREATER_THAN GT_EQUAL LOGICAL_AND LOGICAL_OR LOGICAL_NOT
LS_EQUAL MINUS MINUS_EQUALS MOD MOD_EQUALS MULTIPLY MULTIPLY_EQUALS PLUS
PLUS_EQUALS INCREMENT DECREMENT DIV COLON COMMA DOT LESS_THAN LINE_TERMINATOR
SEMICOLON ONES_COMPLIMENT PAREN_BLOCK BRACE_BLOCK BRACK_BLOCK OPEN_PARENTHESIS
CLOSE_PARENTHESIS START_BLOCK END_BLOCK OPEN_SQ_BRACKETS CLOSE_SQ_BRACKETS IF
BREAK CONTINUE ELSE FOR FUNCTION THIS RETURN WHILE VOID_SYMBOL NEW DELETE VAR
WITH TYPEOF IN VARIABLE STRING NUMBER FALSE TRUE QUERY NULL_TOKEN)
+ ((left PLUS MINUS)
+ (left MULTIPLY DIV MOD)
+ (nonassoc FALSE)
+ (nonassoc HIGHER_THAN_FALSE)
+ (nonassoc ELSE)
+ (nonassoc LOWER_THAN_CLOSE_PARENTHESIS)
+ (nonassoc CLOSE_PARENTHESIS))
+ (Program
+ ((SourceElement)))
+ (SourceElement
+ ((Statement))
+ ((FunctionDeclaration)))
+ (Statement
+ ((Block))
+ ((VariableStatement))
+ ((EmptyStatement))
+ ((ExpressionStatement))
+ ((IfStatement))
+ ((IterationExpression))
+ ((ContinueStatement))
+ ((BreakStatement))
+ ((ReturnStatement))
+ ((WithStatement)))
+ (FunctionDeclaration
+ ((FUNCTION VARIABLE FormalParameterListBlock Block)
+ (wisent-raw-tag
+ (semantic-tag-new-function $2 nil $3))))
+ (FormalParameterListBlock
+ ((PAREN_BLOCK)
+ (semantic-parse-region
+ (car $region1)
+ (cdr $region1)
+ 'FormalParameterList 1)))
+ (FormalParameterList
+ ((OPEN_PARENTHESIS)
+ nil)
+ ((VARIABLE)
+ (wisent-raw-tag
+ (semantic-tag-new-variable $1 nil nil)))
+ ((CLOSE_PARENTHESIS)
+ nil)
+ ((COMMA)
+ nil))
+ (StatementList
+ ((Statement))
+ ((StatementList Statement)))
+ (Block
+ ((BRACE_BLOCK)))
+ (BlockExpand
+ ((START_BLOCK StatementList END_BLOCK))
+ ((START_BLOCK END_BLOCK)))
+ (VariableStatement
+ ((VAR VariableDeclarationList SEMICOLON)
+ (wisent-raw-tag
+ (semantic-tag-new-variable $2 nil nil))))
+ (VariableDeclarationList
+ ((VariableDeclaration)
+ (list $1))
+ ((VariableDeclarationList COMMA VariableDeclaration)
+ (append $1
+ (list $3))))
+ (VariableDeclaration
+ ((VARIABLE)
+ (append
+ (list $1 nil)
+ $region))
+ ((VARIABLE Initializer)
+ (append
+ (cons $1 $2)
+ $region)))
+ (Initializer
+ ((ASSIGN_SYMBOL AssignmentExpression)
+ (list $2)))
+ (EmptyStatement
+ ((SEMICOLON)))
+ (ExpressionStatement
+ ((Expression SEMICOLON)))
+ (IfStatement
+ ((IF OPEN_PARENTHESIS Expression CLOSE_PARENTHESIS Statement)
+ [HIGHER_THAN_FALSE])
+ ((IF OPEN_PARENTHESIS Expression CLOSE_PARENTHESIS Statement ELSE
Statement))
+ ((IF OPEN_PARENTHESIS FALSE CLOSE_PARENTHESIS Statement))
+ ((IF OPEN_PARENTHESIS LeftHandSideExpression AssignmentOperator
AssignmentExpression CLOSE_PARENTHESIS Statement)))
+ (IterationExpression
+ ((WHILE OPEN_PARENTHESIS Expression CLOSE_PARENTHESIS Statement)
+ [HIGHER_THAN_FALSE])
+ ((WHILE OPEN_PARENTHESIS FALSE CLOSE_PARENTHESIS Statement))
+ ((WHILE OPEN_PARENTHESIS LeftHandSideExpression AssignmentOperator
AssignmentExpression CLOSE_PARENTHESIS Statement))
+ ((FOR OPEN_PARENTHESIS OptionalExpression SEMICOLON OptionalExpression
SEMICOLON OptionalExpression CLOSE_PARENTHESIS Statement))
+ ((FOR OPEN_PARENTHESIS VAR VariableDeclarationList SEMICOLON
OptionalExpression SEMICOLON OptionalExpression CLOSE_PARENTHESIS Statement))
+ ((FOR OPEN_PARENTHESIS LeftHandSideExpression IN Expression
CLOSE_PARENTHESIS Statement))
+ ((FOR OPEN_PARENTHESIS VAR VARIABLE OptionalInitializer IN Expression
CLOSE_PARENTHESIS Statement)))
+ (ContinueStatement
+ ((CONTINUE SEMICOLON)))
+ (BreakStatement
+ ((BREAK SEMICOLON)))
+ (ReturnStatement
+ ((RETURN Expression SEMICOLON))
+ ((RETURN SEMICOLON)))
+ (WithStatement
+ ((WITH OPEN_PARENTHESIS Expression CLOSE_PARENTHESIS Statement)))
+ (OptionalInitializer
+ ((Initializer))
+ (nil))
+ (PrimaryExpression
+ ((THIS))
+ ((VARIABLE))
+ ((NUMBER))
+ ((STRING))
+ ((NULL_TOKEN))
+ ((TRUE))
+ ((FALSE))
+ ((OPEN_PARENTHESIS Expression CLOSE_PARENTHESIS)))
+ (MemberExpression
+ ((PrimaryExpression))
+ ((MemberExpression OPEN_SQ_BRACKETS Expression CLOSE_SQ_BRACKETS))
+ ((MemberExpression DOT VARIABLE))
+ ((NEW MemberExpression Arguments)))
+ (NewExpression
+ ((MemberExpression))
+ ((NEW NewExpression)))
+ (CallExpression
+ ((MemberExpression Arguments))
+ ((CallExpression Arguments))
+ ((CallExpression OPEN_SQ_BRACKETS Expression CLOSE_SQ_BRACKETS))
+ ((CallExpression DOT VARIABLE)))
+ (Arguments
+ ((OPEN_PARENTHESIS CLOSE_PARENTHESIS))
+ ((OPEN_PARENTHESIS ArgumentList CLOSE_PARENTHESIS)))
+ (ArgumentList
+ ((AssignmentExpression))
+ ((ArgumentList COMMA AssignmentExpression)))
+ (LeftHandSideExpression
+ ((NewExpression))
+ ((CallExpression)))
+ (PostfixExpression
+ ((LeftHandSideExpression))
+ ((LeftHandSideExpression INCREMENT))
+ ((LeftHandSideExpression DECREMENT)))
+ (UnaryExpression
+ ((PostfixExpression))
+ ((DELETE UnaryExpression))
+ ((VOID_SYMBOL UnaryExpression))
+ ((TYPEOF UnaryExpression))
+ ((INCREMENT UnaryExpression))
+ ((DECREMENT UnaryExpression))
+ ((PLUS UnaryExpression))
+ ((MINUS UnaryExpression))
+ ((ONES_COMPLIMENT UnaryExpression))
+ ((LOGICAL_NOT UnaryExpression)))
+ (MultiplicativeExpression
+ ((UnaryExpression))
+ ((MultiplicativeExpression MULTIPLY UnaryExpression))
+ ((MultiplicativeExpression DIV UnaryExpression))
+ ((MultiplicativeExpression MOD UnaryExpression)))
+ (AdditiveExpression
+ ((MultiplicativeExpression))
+ ((AdditiveExpression PLUS MultiplicativeExpression))
+ ((AdditiveExpression MINUS MultiplicativeExpression)))
+ (ShiftExpression
+ ((AdditiveExpression))
+ ((ShiftExpression BITWISE_SHIFT_LEFT AdditiveExpression))
+ ((ShiftExpression BITWISE_SHIFT_RIGHT AdditiveExpression))
+ ((ShiftExpression BITWISE_SHIFT_RIGHT_ZERO_FILL AdditiveExpression)))
+ (RelationalExpression
+ ((ShiftExpression))
+ ((RelationalExpression LESS_THAN ShiftExpression))
+ ((RelationalExpression GREATER_THAN ShiftExpression))
+ ((RelationalExpression LS_EQUAL ShiftExpression))
+ ((RelationalExpression GT_EQUAL ShiftExpression)))
+ (EqualityExpression
+ ((RelationalExpression))
+ ((EqualityExpression EQUALS RelationalExpression))
+ ((EqualityExpression NOT_EQUAL RelationalExpression)))
+ (BitwiseANDExpression
+ ((EqualityExpression))
+ ((BitwiseANDExpression BITWISE_AND EqualityExpression)))
+ (BitwiseXORExpression
+ ((BitwiseANDExpression))
+ ((BitwiseXORExpression BITWISE_EXCLUSIVE_OR BitwiseANDExpression)))
+ (BitwiseORExpression
+ ((BitwiseXORExpression))
+ ((BitwiseORExpression BITWISE_OR BitwiseXORExpression)))
+ (LogicalANDExpression
+ ((BitwiseORExpression))
+ ((LogicalANDExpression LOGICAL_AND BitwiseORExpression)))
+ (LogicalORExpression
+ ((LogicalANDExpression))
+ ((LogicalORExpression LOGICAL_OR LogicalANDExpression)))
+ (ConditionalExpression
+ ((LogicalORExpression))
+ ((LogicalORExpression QUERY AssignmentExpression COLON
AssignmentExpression)))
+ (AssignmentExpression
+ ((ConditionalExpression))
+ ((LeftHandSideExpression AssignmentOperator AssignmentExpression)
+ [LOWER_THAN_CLOSE_PARENTHESIS]))
+ (AssignmentOperator
+ ((ASSIGN_SYMBOL))
+ ((MULTIPLY_EQUALS))
+ ((DIV_EQUALS))
+ ((MOD_EQUALS))
+ ((PLUS_EQUALS))
+ ((MINUS_EQUALS))
+ ((BITWISE_SHIFT_LEFT_EQUALS))
+ ((BITWISE_SHIFT_RIGHT_EQUALS))
+ ((BITWISE_SHIFT_RIGHT_ZERO_FILL_EQUALS))
+ ((BITWISE_AND_EQUALS))
+ ((BITWISE_EXCLUSIVE_OR_EQUALS))
+ ((BITWISE_OR_EQUALS)))
+ (Expression
+ ((AssignmentExpression))
+ ((Expression COMMA AssignmentExpression)))
+ (OptionalExpression
+ ((Expression))
+ (nil)))
+ '(Program FormalParameterList)))
+ "Parser table.")
+
+(defun wisent-javascript-jv-wy--install-parser ()
+ "Setup the Semantic Parser."
+ (semantic-install-function-overrides
+ '((parse-stream . wisent-parse-stream)))
+ (setq semantic-parser-name "LALR"
+ semantic--parse-table wisent-javascript-jv-wy--parse-table
+ semantic-debug-parser-source "wisent-javascript-jv.wy"
+ semantic-flex-keywords-obarray wisent-javascript-jv-wy--keyword-table
+ semantic-lex-types-obarray wisent-javascript-jv-wy--token-table)
+ ;; Collect unmatched syntax lexical tokens
+ (semantic-make-local-hook 'wisent-discarding-token-functions)
+ (add-hook 'wisent-discarding-token-functions
+ 'wisent-collect-unmatched-syntax nil t))
+
+
+;;; Analyzers
+;;
+(define-lex-keyword-type-analyzer
wisent-javascript-jv-wy--<keyword>-keyword-analyzer
+ "keyword analyzer for <keyword> tokens."
+ "\\(\\sw\\|\\s_\\)+")
+
+(define-lex-block-type-analyzer wisent-javascript-jv-wy--<block>-block-analyzer
+ "block analyzer for <block> tokens."
+ "\\s(\\|\\s)"
+ '((("(" OPEN_PARENTHESIS PAREN_BLOCK)
+ ("{" START_BLOCK BRACE_BLOCK)
+ ("[" OPEN_SQ_BRACKETS BRACK_BLOCK))
+ (")" CLOSE_PARENTHESIS)
+ ("}" END_BLOCK)
+ ("]" CLOSE_SQ_BRACKETS))
+ )
+
+(define-lex-regex-type-analyzer
wisent-javascript-jv-wy--<symbol>-regexp-analyzer
+ "regexp analyzer for <symbol> tokens."
+ "\\(\\sw\\|\\s_\\)+"
+ nil
+ 'VARIABLE)
+
+(define-lex-sexp-type-analyzer wisent-javascript-jv-wy--<string>-sexp-analyzer
+ "sexp analyzer for <string> tokens."
+ "\\s\""
+ 'STRING)
+
+(define-lex-regex-type-analyzer
wisent-javascript-jv-wy--<number>-regexp-analyzer
+ "regexp analyzer for <number> tokens."
+ semantic-lex-number-expression
+ nil
+ 'NUMBER)
+
+(define-lex-string-type-analyzer
wisent-javascript-jv-wy--<punctuation>-string-analyzer
+ "string analyzer for <punctuation> tokens."
+ "\\(\\s.\\|\\s$\\|\\s'\\)+"
+ '((ONES_COMPLIMENT . "~")
+ (SEMICOLON . ";")
+ (LINE_TERMINATOR . "\n")
+ (LESS_THAN . "<")
+ (DOT . ".")
+ (COMMA . ",")
+ (COLON . ":")
+ (DIV . "/")
+ (DECREMENT . "--")
+ (INCREMENT . "++")
+ (PLUS_EQUALS . "+=")
+ (PLUS . "+")
+ (MULTIPLY_EQUALS . "*=")
+ (MULTIPLY . "*")
+ (MOD_EQUALS . "%=")
+ (MOD . "%")
+ (MINUS_EQUALS . "-=")
+ (MINUS . "-")
+ (LS_EQUAL . "<=")
+ (LOGICAL_NOT . "!!")
+ (LOGICAL_OR . "||")
+ (LOGICAL_AND . "&&")
+ (GT_EQUAL . ">=")
+ (GREATER_THAN . ">")
+ (EQUALS . "==")
+ (DIV_EQUALS . "/=")
+ (NOT_EQUAL . "!=")
+ (BITWISE_SHIFT_RIGHT_ZERO_FILL_EQUALS . ">>>=")
+ (BITWISE_SHIFT_RIGHT_ZERO_FILL . ">>>")
+ (BITWISE_SHIFT_RIGHT_EQUALS . ">>=")
+ (BITWISE_SHIFT_RIGHT . ">>")
+ (BITWISE_SHIFT_LEFT_EQUALS . "<<=")
+ (BITWISE_SHIFT_LEFT . "<<")
+ (BITWISE_OR_EQUALS . "|=")
+ (BITWISE_OR . "|")
+ (BITWISE_EXCLUSIVE_OR_EQUALS . "^=")
+ (BITWISE_EXCLUSIVE_OR . "^")
+ (BITWISE_AND_EQUALS . "&=")
+ (BITWISE_AND . "&")
+ (ASSIGN_SYMBOL . "="))
+ 'punctuation)
+
+
+;;; Epilogue
+;;
+;;here something like:
+;;(define-lex wisent-java-tags-lexer
+;; should go
+(define-lex javascript-lexer-jv
+"javascript thingy"
+;;std stuff
+ semantic-lex-ignore-whitespace
+ semantic-lex-ignore-newline
+ semantic-lex-ignore-comments
+
+ ;;stuff generated from the wy file(one for each "type" declaration)
+ wisent-javascript-jv-wy--<number>-regexp-analyzer
+ wisent-javascript-jv-wy--<string>-sexp-analyzer
+
+ wisent-javascript-jv-wy--<keyword>-keyword-analyzer
+
+ wisent-javascript-jv-wy--<symbol>-regexp-analyzer
+ wisent-javascript-jv-wy--<punctuation>-string-analyzer
+ wisent-javascript-jv-wy--<block>-block-analyzer
+
+
+ ;;;;more std stuff
+ semantic-lex-default-action
+ )
+
+(provide 'semantic/wisent/js-wy)
+
+;;; semantic/wisent/js-wy.el ends here
Index: cedet/semantic/wisent/wisent.el
===================================================================
RCS file: cedet/semantic/wisent/wisent.el
diff -N cedet/semantic/wisent/wisent.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/semantic/wisent/wisent.el 28 Sep 2009 15:15:11 -0000 1.2
@@ -0,0 +1,479 @@
+;;; semantic/wisent/wisent.el --- GNU Bison for Emacs - Runtime
+
+;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: David Ponce <address@hidden>
+;; Maintainer: David Ponce <address@hidden>
+;; Created: 30 January 2002
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Parser engine and runtime of Wisent.
+;;
+;; Wisent (the European Bison ;-) is an Elisp implementation of the
+;; GNU Compiler Compiler Bison. The Elisp code is a port of the C
+;; code of GNU Bison 1.28 & 1.31.
+;;
+;; For more details on the basic concepts for understanding Wisent,
+;; read the Bison manual ;)
+;;
+;; For more details on Wisent itself read the Wisent manual.
+
+;;; History:
+;;
+
+;;; Code:
+
+(defgroup wisent nil
+ "
+ /\\_.-^^^-._/\\ The GNU
+ \\_ _/
+ ( `o ` (European ;-) Bison
+ \\ ` /
+ ( D ,¨ for Emacs!
+ ` ~ ,¨
+ `\"\""
+ :group 'semantic)
+
+
+;;;; -------------
+;;;; Runtime stuff
+;;;; -------------
+
+;;; Compatibility
+(eval-and-compile
+ (if (fboundp 'char-valid-p)
+ (defalias 'wisent-char-p 'char-valid-p)
+ (defalias 'wisent-char-p 'char-or-char-int-p)))
+
+;;; Printed representation of terminals and nonterminals
+(defconst wisent-escape-sequence-strings
+ '(
+ (?\a . "'\\a'") ; C-g
+ (?\b . "'\\b'") ; backspace, BS, C-h
+ (?\t . "'\\t'") ; tab, TAB, C-i
+ (?\n . "'\\n'") ; newline, C-j
+ (?\v . "'\\v'") ; vertical tab, C-k
+ (?\f . "'\\f'") ; formfeed character, C-l
+ (?\r . "'\\r'") ; carriage return, RET, C-m
+ (?\e . "'\\e'") ; escape character, ESC, C-[
+ (?\\ . "'\\'") ; backslash character, \
+ (?\d . "'\\d'") ; delete character, DEL
+ )
+ "Printed representation of usual escape sequences.")
+
+(defsubst wisent-item-to-string (item)
+ "Return a printed representation of ITEM.
+ITEM can be a nonterminal or terminal symbol, or a character literal."
+ (if (wisent-char-p item)
+ (or (cdr (assq item wisent-escape-sequence-strings))
+ (format "'%c'" item))
+ (symbol-name item)))
+
+(defsubst wisent-token-to-string (token)
+ "Return a printed representation of lexical token TOKEN."
+ (format "%s%s(%S)" (wisent-item-to-string (car token))
+ (if (nth 2 token) (format "@%s" (nth 2 token)) "")
+ (nth 1 token)))
+
+;;; Special symbols
+(defconst wisent-eoi-term '$EOI
+ "End Of Input token.")
+
+(defconst wisent-error-term 'error
+ "Error recovery token.")
+
+(defconst wisent-accept-tag 'accept
+ "Accept result after input successfully parsed.")
+
+(defconst wisent-error-tag 'error
+ "Process a syntax error.")
+
+;;; Special functions
+(defun wisent-automaton-p (obj)
+ "Return non-nil if OBJ is a LALR automaton.
+If OBJ is a symbol check its value."
+ (and obj (symbolp obj) (boundp obj)
+ (setq obj (symbol-value obj)))
+ (and (vectorp obj) (= 4 (length obj))
+ (vectorp (aref obj 0)) (vectorp (aref obj 1))
+ (= (length (aref obj 0)) (length (aref obj 1)))
+ (listp (aref obj 2)) (vectorp (aref obj 3))))
+
+(defsubst wisent-region (&rest positions)
+ "Return the start/end positions of the region including POSITIONS.
+Each element of POSITIONS is a pair (START-POS . END-POS) or nil. The
+returned value is the pair (MIN-START-POS . MAX-END-POS) or nil if no
+POSITIONS are available."
+ (let ((pl (delq nil positions)))
+ (if pl
+ (cons (apply #'min (mapcar #'car pl))
+ (apply #'max (mapcar #'cdr pl))))))
+
+;;; Reporting
+(defvar wisent-parse-verbose-flag nil
+ "*Non-nil means to issue more messages while parsing.")
+
+(defun wisent-parse-toggle-verbose-flag ()
+ "Toggle whether to issue more messages while parsing."
+ (interactive)
+ (setq wisent-parse-verbose-flag (not wisent-parse-verbose-flag))
+ (when (interactive-p)
+ (message "More messages while parsing %sabled"
+ (if wisent-parse-verbose-flag "en" "dis"))))
+
+(defsubst wisent-message (string &rest args)
+ "Print a one-line message if `wisent-parse-verbose-flag' is set.
+Pass STRING and ARGS arguments to `message'."
+ (and wisent-parse-verbose-flag
+ (apply 'message string args)))
+
+;;;; --------------------
+;;;; The LR parser engine
+;;;; --------------------
+
+(defcustom wisent-parse-max-stack-size 500
+ "The parser stack size."
+ :type 'integer
+ :group 'wisent)
+
+(defcustom wisent-parse-max-recover 3
+ "Number of tokens to shift before turning off error status."
+ :type 'integer
+ :group 'wisent)
+
+(defvar wisent-discarding-token-functions nil
+ "List of functions to be called when discarding a lexical token.
+These functions receive the lexical token discarded.
+When the parser encounters unexpected tokens, it can discards them,
+based on what directed by error recovery rules. Either when the
+parser reads tokens until one is found that can be shifted, or when an
+semantic action calls the function `wisent-skip-token' or
+`wisent-skip-block'.
+For language specific hooks, make sure you define this as a local
+hook.")
+
+(defvar wisent-pre-parse-hook nil
+ "Normal hook run just before entering the LR parser engine.")
+
+(defvar wisent-post-parse-hook nil
+ "Normal hook run just after the LR parser engine terminated.")
+
+(defvar wisent-loop nil
+ "The current parser action.
+Stop parsing when set to nil.
+This variable only has meaning in the scope of `wisent-parse'.")
+
+(defvar wisent-nerrs nil
+ "The number of parse errors encountered so far.")
+
+(defvar wisent-lookahead nil
+ "The lookahead lexical token.
+This value is non-nil if the parser terminated because of an
+unrecoverable error.")
+
+;; Variables and macros that are useful in semantic actions.
+(defvar wisent-parse-lexer-function nil
+ "The user supplied lexer function.
+This function don't have arguments.
+This variable only has meaning in the scope of `wisent-parse'.")
+
+(defvar wisent-parse-error-function nil
+ "The user supplied error function.
+This function must accept one argument, a message string.
+This variable only has meaning in the scope of `wisent-parse'.")
+
+(defvar wisent-input nil
+ "The last token read.
+This variable only has meaning in the scope of `wisent-parse'.")
+
+(defvar wisent-recovering nil
+ "Non-nil means that the parser is recovering.
+This variable only has meaning in the scope of `wisent-parse'.")
+
+;; Variables that only have meaning in the scope of a semantic action.
+;; These global definitions avoid byte-compiler warnings.
+(defvar $region nil)
+(defvar $nterm nil)
+(defvar $action nil)
+
+(defmacro wisent-lexer ()
+ "Obtain the next terminal in input."
+ '(funcall wisent-parse-lexer-function))
+
+(defmacro wisent-error (msg)
+ "Call the user supplied error reporting function with message MSG."
+ `(funcall wisent-parse-error-function ,msg))
+
+(defmacro wisent-errok ()
+ "Resume generating error messages immediately for subsequent syntax errors.
+This is useful primarily in error recovery semantic actions."
+ '(setq wisent-recovering nil))
+
+(defmacro wisent-clearin ()
+ "Discard the current lookahead token.
+This will cause a new lexical token to be read.
+This is useful primarily in error recovery semantic actions."
+ '(setq wisent-input nil))
+
+(defmacro wisent-abort ()
+ "Abort parsing and save the lookahead token.
+This is useful primarily in error recovery semantic actions."
+ '(setq wisent-lookahead wisent-input
+ wisent-loop nil))
+
+(defmacro wisent-set-region (start end)
+ "Change the region of text matched by the current nonterminal.
+START and END are respectively the beginning and end positions of the
+region. If START or END values are not a valid positions the region
+is set to nil."
+ `(setq $region (and (number-or-marker-p ,start)
+ (number-or-marker-p ,end)
+ (cons ,start ,end))))
+
+(defun wisent-skip-token ()
+ "Skip the lookahead token in order to resume parsing.
+Return nil.
+Must be used in error recovery semantic actions."
+ (if (eq (car wisent-input) wisent-eoi-term)
+ ;; Does nothing at EOI to avoid infinite recovery loop.
+ nil
+ (wisent-message "%s: skip %s" $action
+ (wisent-token-to-string wisent-input))
+ (run-hook-with-args
+ 'wisent-discarding-token-functions wisent-input)
+ (wisent-clearin)
+ (wisent-errok)))
+
+(defun wisent-skip-block (&optional bounds)
+ "Safely skip a parenthesized block in order to resume parsing.
+Return nil.
+Must be used in error recovery semantic actions.
+Optional argument BOUNDS is a pair (START . END) which indicates where
+the parenthesized block starts. Typically the value of a `$regionN'
+variable, where `N' is the the Nth element of the current rule
+components that match the block beginning. It defaults to the value
+of the `$region' variable."
+ (let ((start (car (or bounds $region)))
+ end input)
+ (if (not (number-or-marker-p start))
+ ;; No nonterminal region available, skip the lookahead token.
+ (wisent-skip-token)
+ ;; Try to skip a block.
+ (if (not (setq end (save-excursion
+ (goto-char start)
+ (and (looking-at "\\s(")
+ (condition-case nil
+ (1- (scan-lists (point) 1 0))
+ (error nil))))))
+ ;; Not actually a block, skip the lookahead token.
+ (wisent-skip-token)
+ ;; OK to safely skip the block, so read input until a matching
+ ;; close paren or EOI is encountered.
+ (setq input wisent-input)
+ (while (and (not (eq (car input) wisent-eoi-term))
+ (< (nth 2 input) end))
+ (run-hook-with-args
+ 'wisent-discarding-token-functions input)
+ (setq input (wisent-lexer)))
+ (wisent-message "%s: in enclosing block, skip from %s to %s"
+ $action
+ (wisent-token-to-string wisent-input)
+ (wisent-token-to-string input))
+ (if (eq (car wisent-input) wisent-eoi-term)
+ ;; Does nothing at EOI to avoid infinite recovery loop.
+ nil
+ (wisent-clearin)
+ (wisent-errok))
+ ;; Set end of $region to end of block.
+ (wisent-set-region (car $region) (1+ end))
+ nil))))
+
+;;; Core parser engine
+(defsubst wisent-production-bounds (stack i j)
+ "Determine the start and end locations of a production value.
+Return a pair (START . END), where START is the first available start
+location, and END the last available end location, in components
+values of the rule currently reduced.
+Return nil when no component location is available.
+STACK is the parser stack.
+I and J are the indices in STACK of respectively the value of the
+first and last components of the current rule.
+This function is for internal use by semantic actions' generated
+lambda-expression."
+ (let ((f (cadr (aref stack i)))
+ (l (cddr (aref stack j))))
+ (while (/= i j)
+ (cond
+ ((not f) (setq f (cadr (aref stack (setq i (+ i 2))))))
+ ((not l) (setq l (cddr (aref stack (setq j (- j 2))))))
+ ((setq i j))))
+ (and f l (cons f l))))
+
+(defmacro wisent-parse-action (i al)
+ "Return the next parser action.
+I is a token item number and AL is the list of (item . action)
+available at current state. The first element of AL contains the
+default action for this state."
+ `(cdr (or (assq ,i ,al) (car ,al))))
+
+(defsubst wisent-parse-start (start starts)
+ "Return the first lexical token to shift for START symbol.
+STARTS is the table of allowed start symbols or nil if the LALR
+automaton has only one entry point."
+ (if (null starts)
+ ;; Only one entry point, return the first lexical token
+ ;; available in input.
+ (wisent-lexer)
+ ;; Multiple start symbols defined, return the internal lexical
+ ;; token associated to START. By default START is the first
+ ;; nonterminal defined in STARTS.
+ (let ((token (cdr (if start (assq start starts) (car starts)))))
+ (if token
+ (list token (symbol-name token))
+ (error "Invalid start symbol %s" start)))))
+
+(defun wisent-parse (automaton lexer &optional error start)
+ "Parse input using the automaton specified in AUTOMATON.
+
+- AUTOMATON is an LALR(1) automaton generated by
+ `wisent-compile-grammar'.
+
+- LEXER is a function with no argument called by the parser to obtain
+ the next terminal (token) in input.
+
+- ERROR is an optional reporting function called when a parse error
+ occurs. It receives a message string to report. It defaults to the
+ function `wisent-message'.
+
+- START specify the start symbol (nonterminal) used by the parser as
+ its goal. It defaults to the start symbol defined in the grammar
+ \(see also `wisent-compile-grammar')."
+ (run-hooks 'wisent-pre-parse-hook)
+ (let* ((actions (aref automaton 0))
+ (gotos (aref automaton 1))
+ (starts (aref automaton 2))
+ (stack (make-vector wisent-parse-max-stack-size nil))
+ (sp 0)
+ (wisent-loop t)
+ (wisent-parse-error-function (or error 'wisent-message))
+ (wisent-parse-lexer-function lexer)
+ (wisent-recovering nil)
+ (wisent-input (wisent-parse-start start starts))
+ state tokid choices choice)
+ (setq wisent-nerrs 0 ;; Reset parse error counter
+ wisent-lookahead nil) ;; and lookahead token
+ (aset stack 0 0) ;; Initial state
+ (while wisent-loop
+ (setq state (aref stack sp)
+ tokid (car wisent-input)
+ wisent-loop (wisent-parse-action tokid (aref actions state)))
+ (cond
+
+ ;; Input successfully parsed
+ ;; -------------------------
+ ((eq wisent-loop wisent-accept-tag)
+ (setq wisent-loop nil))
+
+ ;; Syntax error in input
+ ;; ---------------------
+ ((eq wisent-loop wisent-error-tag)
+ ;; Report this error if not already recovering from an error.
+ (setq choices (aref actions state))
+ (or wisent-recovering
+ (wisent-error
+ (format "Syntax error, unexpected %s, expecting %s"
+ (wisent-token-to-string wisent-input)
+ (mapconcat 'wisent-item-to-string
+ (delq wisent-error-term
+ (mapcar 'car (cdr choices)))
+ ", "))))
+ ;; Increment the error counter
+ (setq wisent-nerrs (1+ wisent-nerrs))
+ ;; If just tried and failed to reuse lookahead token after an
+ ;; error, discard it.
+ (if (eq wisent-recovering wisent-parse-max-recover)
+ (if (eq tokid wisent-eoi-term)
+ (wisent-abort) ;; Terminate if at end of input.
+ (wisent-message "Error recovery: skip %s"
+ (wisent-token-to-string wisent-input))
+ (run-hook-with-args
+ 'wisent-discarding-token-functions wisent-input)
+ (setq wisent-input (wisent-lexer)))
+
+ ;; Else will try to reuse lookahead token after shifting the
+ ;; error token.
+
+ ;; Each real token shifted decrements this.
+ (setq wisent-recovering wisent-parse-max-recover)
+ ;; Pop the value/state stack to see if an action associated
+ ;; to special terminal symbol 'error exists.
+ (while (and (>= sp 0)
+ (not (and (setq state (aref stack sp)
+ choices (aref actions state)
+ choice (assq wisent-error-term choices))
+ (natnump (cdr choice)))))
+ (setq sp (- sp 2)))
+
+ (if (not choice)
+ ;; No 'error terminal was found. Just terminate.
+ (wisent-abort)
+ ;; Try to recover and continue parsing.
+ ;; Shift the error terminal.
+ (setq state (cdr choice) ; new state
+ sp (+ sp 2))
+ (aset stack (1- sp) nil) ; push value
+ (aset stack sp state) ; push new state
+ ;; Adjust input to error recovery state. Unless 'error
+ ;; triggers a reduction, eat the input stream until an
+ ;; expected terminal symbol is found, or EOI is reached.
+ (if (cdr (setq choices (aref actions state)))
+ (while (not (or (eq (car wisent-input) wisent-eoi-term)
+ (assq (car wisent-input) choices)))
+ (wisent-message "Error recovery: skip %s"
+ (wisent-token-to-string wisent-input))
+ (run-hook-with-args
+ 'wisent-discarding-token-functions wisent-input)
+ (setq wisent-input (wisent-lexer)))))))
+
+ ;; Shift current token on top of the stack
+ ;; ---------------------------------------
+ ((natnump wisent-loop)
+ ;; Count tokens shifted since error; after
+ ;; `wisent-parse-max-recover', turn off error status.
+ (setq wisent-recovering (and (natnump wisent-recovering)
+ (> wisent-recovering 1)
+ (1- wisent-recovering)))
+ (setq sp (+ sp 2))
+ (aset stack (1- sp) (cdr wisent-input))
+ (aset stack sp wisent-loop)
+ (setq wisent-input (wisent-lexer)))
+
+ ;; Reduce by rule (call semantic action)
+ ;; -------------------------------------
+ (t
+ (setq sp (funcall wisent-loop stack sp gotos))
+ (or wisent-input (setq wisent-input (wisent-lexer))))))
+ (run-hooks 'wisent-post-parse-hook)
+ (car (aref stack 1))))
+
+(provide 'semantic/wisent/wisent)
+
+;;; semantic/wisent/wisent.el ends here
Index: cedet/srecode/.cvsignore
===================================================================
RCS file: cedet/srecode/.cvsignore
diff -N cedet/srecode/.cvsignore
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/srecode/.cvsignore 28 Sep 2009 15:15:11 -0000 1.2
@@ -0,0 +1 @@
+loaddefs.el
Index: cedet/srecode/args.el
===================================================================
RCS file: cedet/srecode/args.el
diff -N cedet/srecode/args.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/srecode/args.el 28 Sep 2009 15:15:11 -0000 1.2
@@ -0,0 +1,188 @@
+;;; srecode/args.el --- Provide some simple template arguments
+
+;;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Srecode templates can accept arguments. These arguments represent
+;; sets of dictionary words that need to be derived. This file contains
+;; a set of simple arguments for srecode templates.
+
+(require 'srecode/insert)
+
+;;; Code:
+
+;;; :blank
+;;
+;; Using :blank means that the template should force blank lines
+;; before and after the template, reguardless of where the insertion
+;; is occuring.
+(defun srecode-semantic-handle-:blank (dict)
+ "Add macros into the dictionary DICT specifying blank line spacing.
+The wrapgap means make sure the first and last lines of the macro
+do not contain any text from preceeding or following text."
+ ;; This won't actually get used, but it might be nice
+ ;; to know about it.
+ (srecode-dictionary-set-value dict "BLANK" t)
+ )
+
+;;; :indent ARGUMENT HANDLING
+;;
+;; When a :indent argument is required, the default is to indent
+;; for the current major mode.
+(defun srecode-semantic-handle-:indent (dict)
+ "Add macros into the dictionary DICT for indentation."
+ (srecode-dictionary-set-value dict "INDENT" t)
+ )
+
+;;; :region ARGUMENT HANDLING
+;;
+;; When a :region argument is required, provide macros that
+;; deal with that active region.
+;;
+;; Regions allow a macro to wrap the region text within the
+;; template bounds.
+;;
+(defvar srecode-handle-region-when-non-active-flag nil
+ "Non-nil means do region handling w/out the region being active.")
+
+(defun srecode-semantic-handle-:region (dict)
+ "Add macros into the dictionary DICT based on the current :region."
+ ;; Only enable the region section if we can clearly show that
+ ;; the user is intending to do something with the region.
+ (when (or srecode-handle-region-when-non-active-flag
+ (eq last-command 'mouse-drag-region)
+ (and transient-mark-mode mark-active))
+ ;; Show the region section
+ (srecode-dictionary-show-section dict "REGION")
+ (srecode-dictionary-set-value
+ dict "REGIONTEXT" (buffer-substring-no-properties (point) (mark)))
+ ;; Only whack the region if our template output
+ ;; is also destined for the current buffer.
+ (when (eq standard-output (current-buffer))
+ (kill-region (point) (mark))))
+ )
+
+;;; :user ARGUMENT HANDLING
+;;
+;; When a :user argument is required, fill the dictionary with
+;; information about the current Emacs user.
+(defun srecode-semantic-handle-:user (dict)
+ "Add macros into the dictionary DICT based on the current :user."
+ (srecode-dictionary-set-value dict "AUTHOR" (user-full-name))
+ (srecode-dictionary-set-value dict "LOGIN" (user-login-name))
+ (srecode-dictionary-set-value dict "EMAIL" user-mail-address)
+ (srecode-dictionary-set-value dict "EMACSINITFILE" user-init-file)
+ (srecode-dictionary-set-value dict "UID" (user-uid))
+ )
+
+;;; :time ARGUMENT HANDLING
+;;
+;; When a :time argument is required, fill the dictionary with
+;; information about the current Emacs time.
+(defun srecode-semantic-handle-:time (dict)
+ "Add macros into the dictionary DICT based on the current :time."
+ ;; DATE Values
+ (srecode-dictionary-set-value
+ dict "YEAR" (format-time-string "%Y" (current-time)))
+ (srecode-dictionary-set-value
+ dict "MONTHNAME" (format-time-string "%B" (current-time)))
+ (srecode-dictionary-set-value
+ dict "MONTH" (format-time-string "%m" (current-time)))
+ (srecode-dictionary-set-value
+ dict "DAY" (format-time-string "%d" (current-time)))
+ (srecode-dictionary-set-value
+ dict "WEEKDAY" (format-time-string "%a" (current-time)))
+ ;; Time Values
+ (srecode-dictionary-set-value
+ dict "HOUR" (format-time-string "%H" (current-time)))
+ (srecode-dictionary-set-value
+ dict "HOUR12" (format-time-string "%l" (current-time)))
+ (srecode-dictionary-set-value
+ dict "AMPM" (format-time-string "%p" (current-time)))
+ (srecode-dictionary-set-value
+ dict "MINUTE" (format-time-string "%M" (current-time)))
+ (srecode-dictionary-set-value
+ dict "SECOND" (format-time-string "%S" (current-time)))
+ (srecode-dictionary-set-value
+ dict "TIMEZONE" (format-time-string "%Z" (current-time)))
+ ;; Convenience pre-packed date/time
+ (srecode-dictionary-set-value
+ dict "DATE" (format-time-string "%D" (current-time)))
+ (srecode-dictionary-set-value
+ dict "TIME" (format-time-string "%X" (current-time)))
+ )
+
+;;; :file ARGUMENT HANDLING
+;;
+;; When a :file argument is required, fill the dictionary with
+;; information about the file Emacs is editing at the time of
+;; insertion.
+(defun srecode-semantic-handle-:file (dict)
+ "Add macros into the dictionary DICT based on the current :file."
+ (let* ((bfn (buffer-file-name))
+ (file (file-name-nondirectory bfn))
+ (dir (file-name-directory bfn)))
+ (srecode-dictionary-set-value dict "FILENAME" file)
+ (srecode-dictionary-set-value dict "FILE" (file-name-sans-extension file))
+ (srecode-dictionary-set-value dict "EXTENSION" (file-name-extension file))
+ (srecode-dictionary-set-value dict "DIRECTORY" dir)
+ (srecode-dictionary-set-value dict "MODE" (symbol-name major-mode))
+ (srecode-dictionary-set-value
+ dict "SHORTMODE"
+ (let* ((mode-name (symbol-name major-mode))
+ (match (string-match "-mode" mode-name)))
+ (if match
+ (substring mode-name 0 match)
+ mode-name)))
+ (if (or (file-exists-p "CVS")
+ (file-exists-p "RCS"))
+ (srecode-dictionary-show-section dict "RCS")
+ )))
+
+;;; :system ARGUMENT HANDLING
+;;
+;; When a :system argument is required, fill the dictionary with
+;; information about the computer Emacs is running on.
+(defun srecode-semantic-handle-:system (dict)
+ "Add macros into the dictionary DICT based on the current :system."
+ (srecode-dictionary-set-value dict "SYSTEMCONF" system-configuration)
+ (srecode-dictionary-set-value dict "SYSTEMTYPE" system-type)
+ (srecode-dictionary-set-value dict "SYSTEMNAME" (system-name))
+ (srecode-dictionary-set-value dict "MAILHOST" (or mail-host-address
+ (system-name)))
+ )
+
+;;; :kill ARGUMENT HANDLING
+;;
+;; When a :kill argument is required, fill the dictionary with
+;; information about the current kill ring.
+(defun srecode-semantic-handle-:kill (dict)
+ "Add macros into the dictionary DICT based on the kill ring."
+ (srecode-dictionary-set-value dict "KILL" (car kill-ring))
+ (srecode-dictionary-set-value dict "KILL2" (nth 1 kill-ring))
+ (srecode-dictionary-set-value dict "KILL3" (nth 2 kill-ring))
+ (srecode-dictionary-set-value dict "KILL4" (nth 3 kill-ring))
+ )
+
+(provide 'srecode/args)
+
+;;; srecode/args.el ends here
+
Index: cedet/srecode/compile.el
===================================================================
RCS file: cedet/srecode/compile.el
diff -N cedet/srecode/compile.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/srecode/compile.el 28 Sep 2009 15:15:11 -0000 1.2
@@ -0,0 +1,641 @@
+;;; srecode/compile --- Compilation of srecode template files.
+
+;;; Copyright (C) 2005, 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Keywords: codegeneration
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Compile a Semantic Recoder template file.
+;;
+;; Template files are parsed using a Semantic/Wisent parser into
+;; a tag table. The code therin is then further parsed down using
+;; a regular expression parser.
+;;
+;; The output are a series of EIEIO objects which represent the
+;; templates in a way that could be inserted later.
+
+(require 'semantic)
+(require 'eieio)
+(require 'eieio-base)
+(require 'srecode)
+(require 'srecode/table)
+
+(declare-function srecode-template-inserter-newline-child-p "srecode/insert")
+(declare-function srecode-create-section-dictionary "srecode/dictionary")
+(declare-function srecode-dictionary-compound-variable "srecode/dictionary")
+
+;;; Code:
+
+;;; Template Class
+;;
+;; Templatets describe a patter of text that can be inserted into a
+;; buffer.
+;;
+(defclass srecode-template (eieio-named)
+ ((context :initarg :context
+ :initform nil
+ :documentation
+ "Context this template belongs to.")
+ (args :initarg :args
+ :documentation
+ "List of arguments that this template requires.")
+ (code :initarg :code
+ :documentation
+ "Compiled text from the template.")
+ (dictionary :initarg :dictionary
+ :type (or null srecode-dictionary)
+ :documentation
+ "List of section dictinaries.
+The compiled template can contain lists of section dictionaries,
+or values that are expected to be passed down into different
+section macros. The template section dictionaries are merged in with
+any incomming dictionaries values.")
+ (binding :initarg :binding
+ :documentation
+ "Preferred keybinding for this template in
`srecode-minor-mode-map'.")
+ (active :allocation :class
+ :initform nil
+ :documentation
+ "During template insertion, this is the stack of active templates.
+The top-most template is the 'active' template. Use the accessor methods
+for push, pop, and peek for the active template.")
+ (table :initarg :table
+ :documentation
+ "The table this template lives in.")
+ )
+ "Class defines storage for semantic recoder templates.")
+
+(defun srecode-flush-active-templates ()
+ "Flush the active template storage.
+Useful if something goes wrong in SRecode, and the active tempalte
+stack is broken."
+ (interactive)
+ (if (oref srecode-template active)
+ (when (y-or-n-p (format "%d active templates. Flush? "
+ (length (oref srecode-template active))))
+ (oset-default srecode-template active nil))
+ (message "No active templates to flush."))
+ )
+
+;;; Inserters
+;;
+;; Each inserter object manages a different thing that
+;; might be inserted into a template output stream.
+;;
+;; The 'srecode-insert-method' on each inserter does the actual
+;; work, and the smaller, simple inserter object is saved in
+;; the compiled templates.
+;;
+;; See srecode-insert.el for the specialized classes.
+;;
+(defclass srecode-template-inserter (eieio-named)
+ ((secondname :initarg :secondname
+ :type (or null string)
+ :documentation
+ "If there is a colon in the inserter's name, it represents
+additional static argument data."))
+ "This represents an item to be inserted via a template macro.
+Plain text strings are not handled via this baseclass."
+ :abstract t)
+
+(defmethod srecode-parse-input ((ins srecode-template-inserter)
+ tag input STATE)
+ "For the template inserter INS, parse INPUT.
+Shorten input only by the amount needed.
+Return the remains of INPUT.
+STATE is the current compilation state."
+ input)
+
+(defmethod srecode-match-end ((ins srecode-template-inserter) name)
+ "For the template inserter INS, do I end a section called NAME?"
+ nil)
+
+(defmethod srecode-inserter-apply-state ((ins srecode-template-inserter) STATE)
+ "For the template inserter INS, apply information from STATE."
+ nil)
+
+(defmethod srecode-inserter-prin-example :STATIC ((ins
srecode-template-inserter)
+ escape-start escape-end)
+ "Insert an example using inserter INS.
+Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
+ (princ " ")
+ (princ escape-start)
+ (when (and (slot-exists-p ins 'key) (oref ins key))
+ (princ (format "%c" (oref ins key))))
+ (princ "VARNAME")
+ (princ escape-end)
+ (terpri)
+ )
+
+
+;;; Compile State
+(defclass srecode-compile-state ()
+ ((context :initform "declaration"
+ :documentation "The active context.")
+ (prompts :initform nil
+ :documentation "The active prompts.")
+ (escape_start :initform "{{"
+ :documentation "The starting escape sequence.")
+ (escape_end :initform "}}"
+ :documentation "The ending escape sequence.")
+ )
+ "Current state of the compile.")
+
+(defmethod srecode-compile-add-prompt ((state srecode-compile-state)
+ prompttag)
+ "Add PROMPTTAG to the current list of prompts."
+ (with-slots (prompts) state
+ (let ((match (assoc (semantic-tag-name prompttag) prompts))
+ (newprompts prompts))
+ (when match
+ (let ((tmp prompts))
+ (setq newprompts nil)
+ (while tmp
+ (when (not (string= (car (car tmp))
+ (car prompttag)))
+ (setq newprompts (cons (car tmp)
+ newprompts)))
+ (setq tmp (cdr tmp)))))
+ (setq prompts (cons prompttag newprompts)))
+ ))
+
+;;; TEMPLATE COMPILER
+;;
+(defun srecode-compile-file (fname)
+ "Compile the templates from the file FNAME."
+ (let ((peb (get-file-buffer fname)))
+ (save-excursion
+ ;; Make whatever it is local.
+ (if (not peb)
+ (set-buffer (semantic-find-file-noselect fname))
+ (set-buffer peb))
+ ;; Do the compile.
+ (srecode-compile-templates)
+ ;; Trash the buffer if we had to read it in.
+ (if (not peb)
+ (kill-buffer (current-buffer)))
+ )))
+
+;;;###autoload
+(defun srecode-compile-templates ()
+ "Compile a semantic recode template file into a mode-local variable."
+ (interactive)
+ (require 'srecode/insert)
+ (message "Compiling template %s..."
+ (file-name-nondirectory (buffer-file-name)))
+ (let ((tags (semantic-fetch-tags))
+ (tag nil)
+ (class nil)
+ (table nil)
+ (STATE (srecode-compile-state (file-name-nondirectory
+ (buffer-file-name))))
+ (mode nil)
+ (application nil)
+ (priority nil)
+ (vars nil)
+ )
+
+ ;;
+ ;; COMPILE
+ ;;
+ (while tags
+ (setq tag (car tags)
+ class (semantic-tag-class tag))
+ ;; What type of item is it?
+ (cond
+ ;; CONTEXT tags specify the context all future tags
+ ;; belong to.
+ ((eq class 'context)
+ (oset STATE context (semantic-tag-name tag))
+ )
+
+ ;; PROMPT tags specify prompts for dictionary ? inserters
+ ;; which appear in the following templates
+ ((eq class 'prompt)
+ (srecode-compile-add-prompt STATE tag)
+ )
+
+ ;; VARIABLE tags can specify operational control
+ ((eq class 'variable)
+ (let* ((name (semantic-tag-name tag))
+ (value (semantic-tag-variable-default tag))
+ (firstvalue (car value)))
+ ;; If it is a single string, and one value, then
+ ;; look to see if it is one of our special variables.
+ (if (and (= (length value) 1) (stringp firstvalue))
+ (cond ((string= name "mode")
+ (setq mode (intern firstvalue)))
+ ((string= name "escape_start")
+ (oset STATE escape_start firstvalue)
+ )
+ ((string= name "escape_end")
+ (oset STATE escape_end firstvalue)
+ )
+ ((string= name "application")
+ (setq application (read firstvalue)))
+ ((string= name "priority")
+ (setq priority (read firstvalue)))
+ (t
+ ;; Assign this into some table of variables.
+ (setq vars (cons (cons name firstvalue) vars))
+ ))
+ ;; If it isn't a single string, then the value of the
+ ;; variable belongs to a compound dictionary value.
+ ;;
+ ;; Create a compound dictionary value from "value".
+ (require 'srecode/dictionary)
+ (let ((cv (srecode-dictionary-compound-variable
+ name :value value)))
+ (setq vars (cons (cons name cv) vars)))
+ ))
+ )
+
+ ;; FUNCTION tags are really templates.
+ ((eq class 'function)
+ (setq table (cons (srecode-compile-one-template-tag tag STATE)
+ table))
+ )
+
+ ;; Ooops
+ (t (error "Unknown TAG class %s" class))
+ )
+ ;; Continue
+ (setq tags (cdr tags)))
+
+ ;; MSG - Before install since nreverse whacks our list.
+ (message "%d templates compiled for %s"
+ (length table) mode)
+
+ ;;
+ ;; APPLY TO MODE
+ ;;
+ (if (not mode)
+ (error "You must specify a MODE for your templates"))
+
+ ;;
+ ;; Calculate priority
+ ;;
+ (if (not priority)
+ (let ((d (file-name-directory (buffer-file-name)))
+ (sd (file-name-directory (locate-library "srecode")))
+ (defaultdelta (if (eq mode 'default) 20 0)))
+ (if (string= d sd)
+ (setq priority (+ 80 defaultdelta))
+ (setq priority (+ 30 defaultdelta)))
+ (message "Templates %s has estimated priority of %d"
+ (file-name-nondirectory (buffer-file-name))
+ priority))
+ (message "Compiling templates %s priority %d... done!"
+ (file-name-nondirectory (buffer-file-name))
+ priority))
+
+ ;; Save it up!
+ (srecode-compile-template-table table mode priority application vars)
+ )
+)
+
+(defun srecode-compile-one-template-tag (tag STATE)
+ "Compile a template tag TAG into an srecode template class.
+STATE is the current compile state as an object `srecode-compile-state'."
+ (require 'srecode/dictionary)
+ (let* ((context (oref STATE context))
+ (codeout (srecode-compile-split-code
+ tag (semantic-tag-get-attribute tag :code)
+ STATE))
+ (code (cdr codeout))
+ (args (semantic-tag-function-arguments tag))
+ (binding (semantic-tag-get-attribute tag :binding))
+ (rawdicts (semantic-tag-get-attribute tag :dictionaries))
+ (sdicts (srecode-create-section-dictionary rawdicts STATE))
+ (addargs nil)
+ )
+; (message "Compiled %s to %d codes with %d args and %d prompts."
+; (semantic-tag-name tag)
+; (length code)
+; (length args)
+; (length prompts))
+ (while args
+ (setq addargs (cons (intern (car args)) addargs))
+ (when (eq (car addargs) :blank)
+ ;; If we have a wrap, then put wrap inserters on both
+ ;; ends of the code.
+ (setq code (append
+ (list (srecode-compile-inserter "BLANK"
+ "\r"
+ STATE
+ :secondname nil
+ :where 'begin))
+ code
+ (list (srecode-compile-inserter "BLANK"
+ "\r"
+ STATE
+ :secondname nil
+ :where 'end))
+ )))
+ (setq args (cdr args)))
+ (srecode-template (semantic-tag-name tag)
+ :context context
+ :args (nreverse addargs)
+ :dictionary sdicts
+ :binding binding
+ :code code)
+ ))
+
+(defun srecode-compile-do-hard-newline-p (comp)
+ "Examine COMP to decide if the upcoming newline should be hard.
+It is hard if the previous inserter is a newline object."
+ (while (and comp (stringp (car comp)))
+ (setq comp (cdr comp)))
+ (or (not comp)
+ (require 'srecode/insert)
+ (srecode-template-inserter-newline-child-p (car comp))))
+
+(defun srecode-compile-split-code (tag str STATE
+ &optional end-name)
+ "Split the code for TAG into something templatable.
+STR is the string of code from TAG to split.
+STATE is the current compile state.
+ESCAPE_START and ESCAPE_END are regexps that indicate the beginning
+escape character, and end escape character pattern for expandable
+macro names.
+Optional argument END-NAME specifies the name of a token upon which
+parsing should stop.
+If END-NAME is specified, and the input string"
+ (let* ((what str)
+ (end-token nil)
+ (comp nil)
+ (regex (concat "\n\\|" (regexp-quote (oref STATE escape_start))))
+ (regexend (regexp-quote (oref STATE escape_end)))
+ )
+ (while (and what (not end-token))
+ (cond
+ ((string-match regex what)
+ (let* ((prefix (substring what 0 (match-beginning 0)))
+ (match (substring what
+ (match-beginning 0)
+ (match-end 0)))
+ (namestart (match-end 0))
+ (junk (string-match regexend what namestart))
+ end tail name key)
+ ;; Add string to compiled output
+ (when (> (length prefix) 0)
+ (setq comp (cons prefix comp)))
+ (if (string= match "\n")
+ ;; Do newline thingy.
+ (let ((new-inserter
+ (srecode-compile-inserter
+ "INDENT"
+ "\n"
+ STATE
+ :secondname nil
+ ;; This newline is "hard" meaning ALWAYS do it
+ ;; if the previous entry is also a newline.
+ ;; Without it, user entered blank lines will be
+ ;; ignored.
+ :hard (srecode-compile-do-hard-newline-p comp)
+ )))
+ ;; Trim WHAT back.
+ (setq what (substring what namestart))
+ (when (> (length what) 0)
+ ;; make the new inserter, but only if we aren't last.
+ (setq comp (cons new-inserter comp))
+ ))
+ ;; Regular inserter thingy.
+ (setq end (if junk
+ (match-beginning 0)
+ (error "Could not find end escape for %s"
+ (semantic-tag-name tag)))
+ tail (match-end 0))
+ (cond ((not end)
+ (error "No matching escape end for %s"
+ (semantic-tag-name tag)))
+ ((<= end namestart)
+ (error "Stray end escape for %s"
+ (semantic-tag-name tag)))
+ )
+ ;; Add string to compiled output
+ (setq name (substring what namestart end)
+ key nil)
+ ;; Trim WHAT back.
+ (setq what (substring what tail))
+ ;; Get the inserter
+ (let ((new-inserter
+ (srecode-compile-parse-inserter name STATE))
+ )
+ ;; If this is an end inserter, then assign into
+ ;; the end-token.
+ (if (srecode-match-end new-inserter end-name)
+ (setq end-token new-inserter))
+ ;; Add the inserter to our compilation stream.
+ (setq comp (cons new-inserter comp))
+ ;; Allow the inserter an opportunity to modify
+ ;; the input stream.
+ (setq what (srecode-parse-input new-inserter tag what
+ STATE))
+ )
+ )))
+ (t
+ (if end-name
+ (error "Unmatched section end %s" end-name))
+ (setq comp (cons what comp)
+ what nil))))
+ (cons what (nreverse comp))))
+
+(defun srecode-compile-parse-inserter (txt STATE)
+ "Parse the inserter TXT with the current STATE.
+Return an inserter object."
+ (let ((key (aref txt 0))
+ name
+ )
+ (if (and (or (< key ?A) (> key ?Z))
+ (or (< key ?a) (> key ?z)) )
+ (setq name (substring txt 1))
+ (setq name txt
+ key nil))
+ (let* ((junk (string-match ":" name))
+ (namepart (if junk
+ (substring name 0 (match-beginning 0))
+ name))
+ (secondname (if junk
+ (substring name (match-end 0))
+ nil))
+ (new-inserter (srecode-compile-inserter
+ namepart key STATE
+ :secondname secondname
+ )))
+ ;; Return the new inserter
+ new-inserter)))
+
+(defun srecode-compile-inserter (name key STATE &rest props)
+ "Create an srecode inserter object for some macro NAME.
+KEY indicates a single character key representing a type
+of inserter to create.
+STATE is the current compile state.
+PROPS are additional properties that might need to be passed
+to the inserter constructor."
+ ;;(message "Compile: %s %S" name props)
+ (if (not key)
+ (apply 'srecode-template-inserter-variable name props)
+ (let ((classes (class-children srecode-template-inserter))
+ (new nil))
+ ;; Loop over the various subclasses and
+ ;; create the correct inserter.
+ (while (and (not new) classes)
+ (setq classes (append classes (class-children (car classes))))
+ ;; Do we have a match?
+ (when (and (not (class-abstract-p (car classes)))
+ (equal (oref (car classes) key) key))
+ ;; Create the new class, and apply state.
+ (setq new (apply (car classes) name props))
+ (srecode-inserter-apply-state new STATE)
+ )
+ (setq classes (cdr classes)))
+ (if (not new) (error "SRECODE: Unknown macro code %S" key))
+ new)))
+
+(defun srecode-compile-template-table (templates mode priority application
vars)
+ "Compile a list of TEMPLATES into an semantic recode table.
+The table being compiled is for MODE, or the string \"default\".
+PRIORITY is a numerical value that indicates this tables location
+in an ordered search.
+APPLICATION is the name of the application these templates belong to.
+A list of defined variables VARS provides a variable table."
+ (let ((namehash (make-hash-table :test 'equal
+ :size (length templates)))
+ (contexthash (make-hash-table :test 'equal :size 10))
+ (lp templates)
+ )
+
+ (while lp
+
+ (let* ((objname (oref (car lp) :object-name))
+ (context (oref (car lp) :context))
+ (globalname (concat context ":" objname))
+ )
+
+ ;; Place this template object into the global name hash.
+ (puthash globalname (car lp) namehash)
+
+ ;; Place this template into the specific context name hash.
+ (let ((hs (gethash context contexthash)))
+ ;; Make a new context if none was available.
+ (when (not hs)
+ (setq hs (make-hash-table :test 'equal :size 20))
+ (puthash context hs contexthash))
+ ;; Put into that contenxt's hash.
+ (puthash objname (car lp) hs)
+ )
+
+ (setq lp (cdr lp))))
+
+ (let* ((table (srecode-mode-table-new mode (buffer-file-name)
+ :templates (nreverse templates)
+ :namehash namehash
+ :contexthash contexthash
+ :variables vars
+ :major-mode mode
+ :priority priority
+ :application application))
+ (tmpl (oref table templates)))
+ ;; Loop over all the templates, and xref.
+ (while tmpl
+ (oset (car tmpl) :table table)
+ (setq tmpl (cdr tmpl))))
+ ))
+
+
+
+;;; DEBUG
+;;
+;; Dump out information about the current srecoder compiled templates.
+;;
+
+(defmethod srecode-dump ((tmp srecode-template))
+ "Dump the contents of the SRecode template tmp."
+ (princ "== Template \"")
+ (princ (object-name-string tmp))
+ (princ "\" in context ")
+ (princ (oref tmp context))
+ (princ "\n")
+ (when (oref tmp args)
+ (princ " Arguments: ")
+ (prin1 (oref tmp args))
+ (princ "\n"))
+ (when (oref tmp dictionary)
+ (princ " Section Dictionaries:\n")
+ (srecode-dump (oref tmp dictionary) 4)
+ ;(princ "\n")
+ )
+ (when (and (slot-boundp tmp 'binding) (oref tmp binding))
+ (princ " Binding: ")
+ (prin1 (oref tmp binding))
+ (princ "\n"))
+ (princ " Compiled Codes:\n")
+ (srecode-dump-code-list (oref tmp code) " ")
+ (princ "\n\n")
+ )
+
+(defun srecode-dump-code-list (code indent)
+ "Dump the CODE from a template code list to standard output.
+Argument INDENT specifies the indentation level for the list."
+ (let ((i 1))
+ (while code
+ (princ indent)
+ (prin1 i)
+ (princ ") ")
+ (cond ((stringp (car code))
+ (prin1 (car code)))
+ ((srecode-template-inserter-child-p (car code))
+ (srecode-dump (car code) indent))
+ (t
+ (princ "Unknown Code: ")
+ (prin1 (car code))))
+ (setq code (cdr code)
+ i (1+ i))
+ (when code
+ (princ "\n"))))
+ )
+
+(defmethod srecode-dump ((ins srecode-template-inserter) indent)
+ "Dump the state of the SRecode template inserter INS."
+ (princ "INS: \"")
+ (princ (object-name-string ins))
+ (when (oref ins :secondname)
+ (princ "\" : \"")
+ (princ (oref ins :secondname)))
+ (princ "\" type \"")
+ (let* ((oc (symbol-name (object-class ins)))
+ (junk (string-match "srecode-template-inserter-" oc))
+ (on (if junk
+ (substring oc (match-end 0))
+ oc)))
+ (princ on))
+ (princ "\"")
+ )
+
+(provide 'srecode/compile)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: srecode/loaddefs
+;; generated-autoload-load-name: "srecode/compile"
+;; End:
+
+;;; srecode/compile.el ends here
Index: cedet/srecode/cpp.el
===================================================================
RCS file: cedet/srecode/cpp.el
diff -N cedet/srecode/cpp.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/srecode/cpp.el 28 Sep 2009 15:15:11 -0000 1.2
@@ -0,0 +1,149 @@
+;;; srecode/cpp.el --- C++ specific handlers for Semantic Recoder
+
+;; Copyright (C) 2007, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+;; Jan Moringen <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Supply some C++ specific dictionary fillers and helpers
+
+;;; Code:
+
+;;; :cpp ARGUMENT HANDLING
+;;
+;; When a :cpp argument is required, fill the dictionary with
+;; information about the current C++ file.
+;;
+;; Error if not in a C++ mode.
+
+(require 'srecode)
+(require 'srecode/dictionary)
+(require 'srecode/semantic)
+
+;;;###autoload
+(defun srecode-semantic-handle-:cpp (dict)
+ "Add macros into the dictionary DICT based on the current c++ file.
+Adds the following:
+FILENAME_SYMBOL - filename converted into a C compat symbol.
+HEADER - Shown section if in a header file."
+ ;; A symbol representing
+ (let ((fsym (file-name-nondirectory (buffer-file-name)))
+ (case-fold-search t))
+
+ ;; Are we in a header file?
+ (if (string-match "\\.\\(h\\|hh\\|hpp\\|h\\+\\+\\)$" fsym)
+ (srecode-dictionary-show-section dict "HEADER")
+ (srecode-dictionary-show-section dict "NOTHEADER"))
+
+ ;; Strip out bad characters
+ (while (string-match "\\.\\| " fsym)
+ (setq fsym (replace-match "_" t t fsym)))
+ (srecode-dictionary-set-value dict "FILENAME_SYMBOL" fsym)
+ )
+ )
+
+(define-mode-local-override srecode-semantic-apply-tag-to-dict
+ c++-mode (tag-wrapper dict)
+ "Apply C++ specific features from TAG-WRAPPER into DICT.
+Calls `srecode-semantic-apply-tag-to-dict-default' first. Adds
+special behavior for tag of classes include, using and function."
+
+ ;; Use default implementation to fill in the basic properties.
+ (srecode-semantic-apply-tag-to-dict-default tag-wrapper dict)
+
+ ;; Pull out the tag for the individual pieces.
+ (let* ((tag (oref tag-wrapper :prime))
+ (class (semantic-tag-class tag)))
+
+ ;; Add additional information based on the class of the tag.
+ (cond
+ ;;
+ ;; INCLUDE
+ ;;
+ ((eq class 'include)
+ ;; For include tags, we have to discriminate between system-wide
+ ;; and local includes.
+ (if (semantic-tag-include-system-p tag)
+ (srecode-dictionary-show-section dict "SYSTEM")
+ (srecode-dictionary-show-section dict "LOCAL")))
+
+ ;;
+ ;; USING
+ ;;
+ ((eq class 'using)
+ ;; Insert the subject (a tag) of the include statement as VALUE
+ ;; entry into the dictionary.
+ (let ((value-tag (semantic-tag-get-attribute tag :value))
+ (value-dict (srecode-dictionary-add-section-dictionary
+ dict "VALUE")))
+ (srecode-semantic-apply-tag-to-dict
+ (srecode-semantic-tag (semantic-tag-name value-tag)
+ :prime value-tag)
+ value-dict))
+ ;; Discriminate using statements referring to namespaces and
+ ;; types.
+ (when (eq (semantic-tag-get-attribute tag :kind) 'namespace)
+ (srecode-dictionary-show-section dict "NAMESPACE")))
+
+ ;;
+ ;; FUNCTION
+ ;;
+ ((eq class 'function)
+ ;; @todo It would be nice to distinguish member functions from
+ ;; free functions and only apply the const and pure modifiers,
+ ;; when they make sense. My best bet would be
+ ;; (semantic-tag-function-parent tag), but it is not there, when
+ ;; the function is defined in the scope of a class.
+ (let ((member 't)
+ (modifiers (semantic-tag-modifiers tag)))
+
+ ;; Add modifiers into the dictionary
+ (dolist (modifier modifiers)
+ (let ((modifier-dict (srecode-dictionary-add-section-dictionary
+ dict "MODIFIERS")))
+ (srecode-dictionary-set-value modifier-dict "NAME" modifier)))
+
+ ;; When the function is a member function, it can have
+ ;; additional modifiers.
+ (when member
+
+ ;; For member functions, constness is called
+ ;; 'methodconst-flag'.
+ (when (semantic-tag-get-attribute tag :methodconst-flag)
+ (srecode-dictionary-show-section dict "CONST"))
+
+ ;; If the member function is pure virtual, add a dictionary
+ ;; entry.
+ (when (semantic-tag-get-attribute tag :pure-virtual-flag)
+ (srecode-dictionary-show-section dict "PURE"))
+ )
+ ))
+ ))
+ )
+
+(provide 'srecode/cpp)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: srecode/loaddefs
+;; generated-autoload-load-name: "srecode/cpp"
+;; End:
+
+;;; srecode/cpp.el ends here
Index: cedet/srecode/ctxt.el
===================================================================
RCS file: cedet/srecode/ctxt.el
diff -N cedet/srecode/ctxt.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/srecode/ctxt.el 28 Sep 2009 15:15:11 -0000 1.2
@@ -0,0 +1,247 @@
+;;; srecode/ctxt.el --- Derive a context from the source buffer.
+
+;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Manage context calculations for Semantic Recoder.
+;;
+;; SRecode templates are always bound to a context. By calculating
+;; the current context, we can narrow down the selection of possible
+;; templates to something reasonable.
+;;
+;; Alternately, code here will find a context for templates that
+;; require different pieces of code placed in multiple areas.
+
+(require 'semantic)
+(require 'semantic/tag-ls)
+
+(declare-function srecode-dictionary-show-section "srecode/dictionary")
+(declare-function srecode-dictionary-set-value "srecode/dictionary")
+
+;;; Code:
+
+(define-overload srecode-calculate-context ()
+ "Calculate the context at the current point.
+The returned context is a list, with the top-most context first.
+Each returned context is a string that that would show up in a `context'
+statement in an `.srt' file.
+
+Some useful context values used by the provided srecode templates are:
+ \"file\" - Templates that for a file (such as an empty file.)
+ \"empty\" - The file is empty
+ \"declaration\" - Top-level declarations in a file.
+ \"include\" - In or near include statements
+ \"package\" - In or near provide statements
+ \"function\" - In or near function statements
+ \"NAME\" - Near functions within NAME namespace or class
+ \"variable\" - In or near variable statements.
+ \"type\" - In or near type declarations.
+ \"comment\" - In a comment
+ \"classdecl\" - Declarations within a class/struct/etc.
+ \"variable\" - In or near class fields
+ \"function\" - In or near methods/functions
+ \"virtual\" - Nearby items are virtual
+ \"pure\" - and those virtual items are pure virtual
+ \"type\" - In or near type declarations.
+ \"comment\" - In a comment in a block of code
+ -- these items show up at the end of the context list. --
+ \"public\", \"protected\", \"private\" -
+ In or near a section of public/pritected/private entries.
+ \"code\" - In a block of code.
+ \"string\" - In a string in a block of code
+ \"comment\" - In a comment in a block of code
+
+ ... More later."
+ )
+
+(defun srecode-calculate-nearby-things ()
+ ;; NOTE: May need to add bounes to this FCN
+ "Calculate the CONTEXT type items nearby the current point.
+Assume that what we want to insert next is based on what is just
+before point. If there is nothing, then assume it is whatever is
+after point."
+ ;; @todo - ADD BOUNDS TO THE PREV/NEXT TAG SEARCH
+ ;; thus classdecl "near" stuff cannot be
+ ;; outside the bounds of the type in question.
+ (let ((near (semantic-find-tag-by-overlay-prev))
+ (prot nil)
+ (ans nil))
+ (if (not near)
+ (setq near (semantic-find-tag-by-overlay-next)))
+ (when near
+ ;; Calculate the type of thing we are near.
+ (if (not (semantic-tag-of-class-p near 'function))
+ (setq ans (cons (symbol-name (semantic-tag-class near)) ans))
+ ;; if the symbol NEAR has a parent,
+ (let ((p (semantic-tag-function-parent near)))
+ (setq ans (cons (symbol-name (semantic-tag-class near)) ans))
+ (cond ((semantic-tag-p p)
+ (setq ans (cons (semantic-tag-name p) ans)))
+ ((stringp p)
+ (setq ans (cons p ans)))
+ (t nil)))
+ ;; Was it virtual?
+ (when (semantic-tag-get-attribute near :virtual)
+ (setq ans (cons "virtual" ans)))
+ ;; Was it pure?
+ (when (semantic-tag-get-attribute near :pure-virtual-flag)
+ (setq ans (cons "pure" ans)))
+ )
+ ;; Calculate the protection
+ (setq prot (semantic-tag-protection near))
+ (when (and prot (not (eq prot 'unknown)))
+ (setq ans (cons (symbol-name prot) ans)))
+ )
+ (nreverse ans)))
+
+(defun srecode-calculate-context-font-lock ()
+ "Calculate an srecode context by using font-lock."
+ (let ((face (get-text-property (point) 'face))
+ )
+ (cond ((member face '(font-lock-string-face
+ font-lock-doc-face))
+ (list "string"))
+ ((member face '(font-lock-comment-face
+ font-lock-comment-delimiter-face))
+ (list "comment"))
+ )
+ ))
+
+(defun srecode-calculate-context-default ()
+ "Generic method for calculating a context for srecode."
+ (if (= (point-min) (point-max))
+ (list "file" "empty")
+
+ (semantic-fetch-tags)
+ (let ((ct (semantic-find-tag-by-overlay))
+ )
+ (cond ((or (not ct)
+ ;; Ok, below is a bit C specific.
+ (and (eq (semantic-tag-class (car ct)) 'type)
+ (string= (semantic-tag-type (car ct)) "namespace")))
+ (cons "declaration"
+ (or (srecode-calculate-context-font-lock)
+ (srecode-calculate-nearby-things)
+ ))
+ )
+ ((eq (semantic-tag-class (car ct)) 'function)
+ (cons "code" (srecode-calculate-context-font-lock))
+ )
+ ((eq (semantic-tag-class (car ct)) 'type) ; We know not namespace
+ (cons "classdecl"
+ (or (srecode-calculate-context-font-lock)
+ (srecode-calculate-nearby-things)))
+ )
+ ((and (car (cdr ct))
+ (eq (semantic-tag-class (car (cdr ct))) 'type))
+ (list "classdecl"
+ (symbol-name (semantic-tag-class (car ct))))
+ )
+ )
+ )))
+
+
+;;; HANDLERS
+;;
+;; The calculated context is one thing, but more info is often available.
+;; The context handlers can add info into the active dictionary that is
+;; based on the context, such as a method parent name, protection scheme,
+;; or other feature.
+
+(defun srecode-semantic-handle-:ctxt (dict &optional template)
+ "Add macros into the dictionary DICT based on the current Emacs Lisp file.
+Argument TEMPLATE is the template object adding context dictionary
+entries.
+This might add the following:
+ VIRTUAL - show a section if a function is virtual
+ PURE - show a section if a function is pure virtual.
+ PARENT - The name of a parent type for functions.
+ PROTECTION - Show a protection section, and what the protection is."
+ (require 'srecode/dictionary)
+ (when template
+
+ (let ((name (oref template object-name))
+ (cc (if (boundp 'srecode-insertion-start-context)
+ srecode-insertion-start-context))
+ ;(context (oref template context))
+ )
+
+; (when (and cc
+; (null (string= (car cc) context))
+; )
+; ;; No current context, or the base is different, then
+; ;; this is the section where we need to recalculate
+; ;; the context based on user choice, if possible.
+; ;;
+; ;; The recalculation is complex, as there are many possibilities
+; ;; that need to be divined. Set "cc" to the new context
+; ;; at the end.
+; ;;
+; ;; @todo -
+;
+; )
+
+ ;; The various context all have different features.
+ (let ((ct (nth 0 cc))
+ (it (nth 1 cc))
+ (last (last cc))
+ (parent nil)
+ )
+ (cond ((string= it "function")
+ (setq parent (nth 2 cc))
+ (when parent
+ (cond ((string= parent "virtual")
+ (srecode-dictionary-show-section dict "VIRTUAL")
+ (when (nth 3 cc)
+ (srecode-dictionary-show-section dict "PURE"))
+ )
+ (t
+ (srecode-dictionary-set-value dict "PARENT" parent))))
+ )
+ ((and (string= it "type")
+ (or (string= name "function") (string= name "method")))
+ ;; If we have a type, but we insert a fcn, then use that type
+ ;; as the function parent.
+ (let ((near (semantic-find-tag-by-overlay-prev)))
+ (when (and near (semantic-tag-of-class-p near 'type))
+ (srecode-dictionary-set-value
+ dict "PARENT" (semantic-tag-name near))))
+ )
+ ((string= ct "code")
+ ;;(let ((analyzer (semantic-analyze-current-context)))
+ ;; @todo - Use the analyze to setup things like local
+ ;; variables we might use or something.
+ nil
+ ;;)
+ )
+ (t
+ nil))
+ (when (member last '("public" "private" "protected"))
+ ;; Hey, fancy that, we can do both.
+ (srecode-dictionary-set-value dict "PROTECTION" parent)
+ (srecode-dictionary-show-section dict "PROTECTION"))
+ ))
+ ))
+
+
+(provide 'srecode/ctxt)
+
+;;; srecode/ctxt.el ends here
Index: cedet/srecode/dictionary.el
===================================================================
RCS file: cedet/srecode/dictionary.el
diff -N cedet/srecode/dictionary.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/srecode/dictionary.el 28 Sep 2009 15:15:11 -0000 1.2
@@ -0,0 +1,565 @@
+;;; srecode-dictionary.el --- Dictionary code for the semantic recoder.
+
+;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Dictionaries contain lists of names and their assocaited values.
+;; These dictionaries are used to fill in macros from recoder templates.
+
+;;; Code:
+
+;;; CLASSES
+
+(require 'eieio)
+(require 'srecode)
+(require 'srecode/table)
+(eval-when-compile (require 'semantic))
+
+(declare-function srecode-compile-parse-inserter "srecode/compile")
+(declare-function srecode-dump-code-list "srecode/compile")
+(declare-function srecode-load-tables-for-mode "srecode/find")
+(declare-function srecode-insert-code-stream "srecode/insert")
+(declare-function data-debug-new-buffer "data-debug")
+(declare-function data-debug-insert-object-slots "eieio-datadebug")
+(declare-function srecode-field "srecode/fields")
+
+(defclass srecode-dictionary ()
+ ((namehash :initarg :namehash
+ :documentation
+ "Hash table containing the names of all the templates.")
+ (buffer :initarg :buffer
+ :documentation
+ "The buffer this dictionary was initialized with.")
+ (parent :initarg :parent
+ :type (or null srecode-dictionary)
+ :documentation
+ "The parent dictionary.
+Symbols not appearing in this dictionary will be checked against the
+parent dictionary.")
+ (origin :initarg :origin
+ :type string
+ :documentation
+ "A string representing the origin of this dictionary.
+Useful only while debugging.")
+ )
+ "Dictionary of symbols and what they mean.
+Dictionaries are used to look up named symbols from
+templates to decide what to do with those symbols.")
+
+(defclass srecode-dictionary-compound-value ()
+ ()
+ "A compound dictionary value.
+Values stored in a dictionary must be a STRING,
+a dictionary for showing sections, or an instance of a subclass
+of this class.
+
+Compound dictionary values derive from this class, and must
+provide a sequence of method implementations to convert into
+a string."
+ :abstract t)
+
+(defclass srecode-dictionary-compound-variable
+ (srecode-dictionary-compound-value)
+ ((value :initarg :value
+ :documentation
+ "The value of this template variable.
+Variables in template files are usually a single string
+which can be inserted into a dictionary directly.
+
+Some variables may be more complex and involve dictionary
+lookups, strings, concatenation, or the like.
+
+The format of VALUE is determined by current template
+formatting rules.")
+ (compiled :initarg :compiled
+ :type list
+ :documentation
+ "The compiled version of VALUE.")
+ )
+ "A compound dictionary value for template file variables.
+You can declare a variable in a template like this:
+
+set NAME \"str\" macro \"OTHERNAME\"
+
+with appending various parts together in a list.")
+
+(defmethod initialize-instance ((this srecode-dictionary-compound-variable)
+ &optional fields)
+ "Initialize the compound variable THIS.
+Makes sure that :value is compiled."
+ (let ((newfields nil)
+ (state nil))
+ (while fields
+ ;; Strip out :state
+ (if (eq (car fields) :state)
+ (setq state (car (cdr fields)))
+ (setq newfields (cons (car (cdr fields))
+ (cons (car fields) newfields))))
+ (setq fields (cdr (cdr fields))))
+
+ (when (not state)
+ (error "Cannot create compound variable without :state"))
+
+ (call-next-method this (nreverse newfields))
+ (when (not (slot-boundp this 'compiled))
+ (let ((val (oref this :value))
+ (comp nil))
+ (while val
+ (let ((nval (car val))
+ )
+ (cond ((stringp nval)
+ (setq comp (cons nval comp)))
+ ((and (listp nval)
+ (equal (car nval) 'macro))
+ (require 'srecode/compile)
+ (setq comp (cons
+ (srecode-compile-parse-inserter
+ (cdr nval)
+ state)
+ comp)))
+ (t
+ (error "Don't know how to handle variable value %S" nval)))
+ )
+ (setq val (cdr val)))
+ (oset this :compiled (nreverse comp))))))
+
+;;; DICTIONARY METHODS
+;;
+
+(defun srecode-create-dictionary (&optional buffer-or-parent)
+ "Create a dictionary for BUFFER.
+If BUFFER-OR-PARENT is not specified, assume a buffer, and
+use the current buffer.
+If BUFFER-OR-PARENT is another dictionary, then remember the
+parent within the new dictionary, and assume that BUFFER
+is the same as belongs to the parent dictionary.
+The dictionary is initialized with variables setup for that
+buffer's table.
+If BUFFER-OR-PARENT is t, then this dictionary should not be
+assocated with a buffer or parent."
+ (save-excursion
+ (let ((parent nil)
+ (buffer nil)
+ (origin nil)
+ (initfrombuff nil))
+ (cond ((bufferp buffer-or-parent)
+ (set-buffer buffer-or-parent)
+ (setq buffer buffer-or-parent
+ origin (buffer-name buffer-or-parent)
+ initfrombuff t))
+ ((srecode-dictionary-child-p buffer-or-parent)
+ (setq parent buffer-or-parent
+ buffer (oref buffer-or-parent buffer)
+ origin (concat (object-name buffer-or-parent) " in "
+ (if buffer (buffer-name buffer)
+ "no buffer")))
+ (when buffer
+ (set-buffer buffer)))
+ ((eq buffer-or-parent t)
+ (setq buffer nil
+ origin "Unspecified Origin"))
+ (t
+ (setq buffer (current-buffer)
+ origin (concat "Unspecified. Assume "
+ (buffer-name buffer))
+ initfrombuff t)
+ )
+ )
+ (let ((dict (srecode-dictionary
+ major-mode
+ :buffer buffer
+ :parent parent
+ :namehash (make-hash-table :test 'equal
+ :size 20)
+ :origin origin)))
+ ;; Only set up the default variables if we are being built
+ ;; directroy for a particular buffer.
+ (when initfrombuff
+ ;; Variables from the table we are inserting from.
+ ;; @todo - get a better tree of tables.
+ (let ((mt (srecode-get-mode-table major-mode))
+ (def (srecode-get-mode-table 'default)))
+ ;; Each table has multiple template tables.
+ ;; Do DEF first so that MT can override any values.
+ (srecode-dictionary-add-template-table dict def)
+ (srecode-dictionary-add-template-table dict mt)
+ ))
+ dict))))
+
+(defmethod srecode-dictionary-add-template-table ((dict srecode-dictionary)
+ tpl)
+ "Insert into DICT the variables found in table TPL.
+TPL is an object representing a compiled template file."
+ (when tpl
+ (let ((tabs (oref tpl :tables)))
+ (while tabs
+ (let ((vars (oref (car tabs) variables)))
+ (while vars
+ (srecode-dictionary-set-value
+ dict (car (car vars)) (cdr (car vars)))
+ (setq vars (cdr vars))))
+ (setq tabs (cdr tabs))))))
+
+
+(defmethod srecode-dictionary-set-value ((dict srecode-dictionary)
+ name value)
+ "In dictionary DICT, set NAME to have VALUE."
+ ;; Validate inputs
+ (if (not (stringp name))
+ (signal 'wrong-type-argument (list name 'stringp)))
+ ;; Add the value.
+ (with-slots (namehash) dict
+ (puthash name value namehash))
+ )
+
+(defmethod srecode-dictionary-add-section-dictionary ((dict srecode-dictionary)
+ name &optional show-only)
+ "In dictionary DICT, add a section dictionary for section macro NAME.
+Return the new dictionary.
+
+You can add several dictionaries to the same section macro.
+For each dictionary added to a macro, the block of codes in the
+template will be repeated.
+
+If optional argument SHOW-ONLY is non-nil, then don't add a new dictionarly
+if there is already one in place. Also, don't add FIRST/LAST entries.
+These entries are not needed when we are just showing a section.
+
+Each dictionary added will automatically get values for positional macros
+which will enable SECTIONS to be enabled.
+
+ * FIRST - The first entry in the table.
+ * NOTFIRST - Not the first entry in the table.
+ * LAST - The last entry in the table
+ * NOTLAST - Not the last entry in the table.
+
+Adding a new dictionary will alter these values in previously
+inserted dictionaries."
+ ;; Validate inputs
+ (if (not (stringp name))
+ (signal 'wrong-type-argument (list name 'stringp)))
+ (let ((new (srecode-create-dictionary dict))
+ (ov (srecode-dictionary-lookup-name dict name)))
+
+ (when (not show-only)
+ ;; Setup the FIRST/NOTFIRST and LAST/NOTLAST entries.
+ (if (null ov)
+ (progn
+ (srecode-dictionary-show-section new "FIRST")
+ (srecode-dictionary-show-section new "LAST"))
+ ;; Not the very first one. Lets clean up CAR.
+ (let ((tail (car (last ov))))
+ (srecode-dictionary-hide-section tail "LAST")
+ (srecode-dictionary-show-section tail "NOTLAST")
+ )
+ (srecode-dictionary-show-section new "NOTFIRST")
+ (srecode-dictionary-show-section new "LAST"))
+ )
+
+ (when (or (not show-only) (null ov))
+ (srecode-dictionary-set-value dict name (append ov (list new))))
+ ;; Return the new sub-dictionary.
+ new))
+
+(defmethod srecode-dictionary-show-section ((dict srecode-dictionary) name)
+ "In dictionary DICT, indicate that the section NAME should be exposed."
+ ;; Validate inputs
+ (if (not (stringp name))
+ (signal 'wrong-type-argument (list name 'stringp)))
+ ;; Showing a section is just like making a section dictionary, but
+ ;; with no dictionary values to add.
+ (srecode-dictionary-add-section-dictionary dict name t)
+ nil)
+
+(defmethod srecode-dictionary-hide-section ((dict srecode-dictionary) name)
+ "In dictionary DICT, indicate that the section NAME should be hidden."
+ ;; We need to find the has value, and then delete it.
+ ;; Validate inputs
+ (if (not (stringp name))
+ (signal 'wrong-type-argument (list name 'stringp)))
+ ;; Add the value.
+ (with-slots (namehash) dict
+ (remhash name namehash))
+ nil)
+
+(defmethod srecode-dictionary-merge ((dict srecode-dictionary) otherdict)
+ "Merge into DICT the dictionary entries from OTHERDICT."
+ (when otherdict
+ (maphash
+ (lambda (key entry)
+ ;; Only merge in the new values if there was no old value.
+ ;; This protects applications from being whacked, and basically
+ ;; makes these new section dictionary entries act like
+ ;; "defaults" instead of overrides.
+ (when (not (srecode-dictionary-lookup-name dict key))
+ (cond ((and (listp entry) (srecode-dictionary-p (car entry)))
+ ;; A list of section dictionaries.
+ ;; We need to merge them in.
+ (while entry
+ (let ((new-sub-dict
+ (srecode-dictionary-add-section-dictionary
+ dict key)))
+ (srecode-dictionary-merge new-sub-dict (car entry)))
+ (setq entry (cdr entry)))
+ )
+
+ (t
+ (srecode-dictionary-set-value dict key entry)))
+ ))
+ (oref otherdict namehash))))
+
+(defmethod srecode-dictionary-lookup-name ((dict srecode-dictionary)
+ name)
+ "Return information about the current DICT's value for NAME."
+ (if (not (slot-boundp dict 'namehash))
+ nil
+ ;; Get the value of this name from the dictionary
+ (or (with-slots (namehash) dict
+ (gethash name namehash))
+ (and (not (member name '("FIRST" "LAST" "NOTFIRST" "NOTLAST")))
+ (oref dict parent)
+ (srecode-dictionary-lookup-name (oref dict parent) name))
+ )))
+
+(defmethod srecode-root-dictionary ((dict srecode-dictionary))
+ "For dictionary DICT, return the root dictionary.
+The root dictionary is usually for a current or active insertion."
+ (let ((ans dict))
+ (while (oref ans parent)
+ (setq ans (oref ans parent)))
+ ans))
+
+;;; COMPOUND VALUE METHODS
+;;
+;; Compound values must provide at least the toStriong method
+;; for use in converting the compound value into sometehing insertable.
+
+(defmethod srecode-compound-toString ((cp srecode-dictionary-compound-value)
+ function
+ dictionary)
+ "Convert the compound dictionary value CP to a string.
+If FUNCTION is non-nil, then FUNCTION is somehow applied to an aspect
+of the compound value. The FUNCTION could be a fraction
+of some function symbol with a logical prefix excluded.
+
+If you subclass `srecode-dictionary-compound-value' then this
+method could return nil, but if it does that, it must insert
+the value itself using `princ', or by detecting if the current
+standard out is a buffer, and using `insert'."
+ (object-name cp))
+
+(defmethod srecode-dump ((cp srecode-dictionary-compound-value)
+ &optional indent)
+ "Display information about this compound value."
+ (princ (object-name cp))
+ )
+
+(defmethod srecode-compound-toString ((cp srecode-dictionary-compound-variable)
+ function
+ dictionary)
+ "Convert the compound dictionary variable value CP into a string.
+FUNCTION and DICTIONARY are as for the baseclass."
+ (require 'srecode/insert)
+ (srecode-insert-code-stream (oref cp compiled) dictionary))
+
+
+(defmethod srecode-dump ((cp srecode-dictionary-compound-variable)
+ &optional indent)
+ "Display information about this compound value."
+ (require 'srecode/compile)
+ (princ "# Compound Variable #\n")
+ (let ((indent (+ 4 (or indent 0)))
+ (cmp (oref cp compiled))
+ )
+ (srecode-dump-code-list cmp (make-string indent ? ))
+ ))
+
+;;; FIELD EDITING COMPOUND VALUE
+;;
+;; This is an interface to using field-editing objects
+;; instead of asking questions. This provides the basics
+;; behind this compound value.
+
+(defclass srecode-field-value (srecode-dictionary-compound-value)
+ ((firstinserter :initarg :firstinserter
+ :documentation
+ "The inserter object for the first occurance of this field.")
+ (defaultvalue :initarg :defaultvalue
+ :documentation
+ "The default value for this inserter.")
+ )
+ "When inserting values with editable field mode, a dictionary value.
+Compound values allow a field to be stored in the dictionary for when
+it is referenced a second time. This compound value can then be
+inserted with a new editable field.")
+
+(defmethod srecode-compound-toString((cp srecode-field-value)
+ function
+ dictionary)
+ "Convert this field into an insertable string."
+ (require 'srecode/fields)
+ ;; If we are not in a buffer, then this is not supported.
+ (when (not (bufferp standard-output))
+ (error "FIELDS invoked while inserting template to non-buffer."))
+
+ (if function
+ (error "@todo: Cannot mix field insertion with functions.")
+
+ ;; No function. Perform a plain field insertion.
+ ;; We know we are in a buffer, so we can perform the insertion.
+ (let* ((dv (oref cp defaultvalue))
+ (sti (oref cp firstinserter))
+ (start (point))
+ (name (oref sti :object-name)))
+
+ (if (or (not dv) (string= dv ""))
+ (insert name)
+ (insert dv))
+
+ (srecode-field name :name name
+ :start start
+ :end (point)
+ :prompt (oref sti prompt)
+ :read-fcn (oref sti read-fcn)
+ )
+ ))
+ ;; Returning nil is a signal that we have done the insertion ourselves.
+ nil)
+
+
+;;; Higher level dictionary functions
+;;
+(defun srecode-create-section-dictionary (sectiondicts STATE)
+ "Create a dictionary with section entries for a template.
+The format for SECTIONDICTS is what is emitted from the template parsers.
+STATE is the current compiler state."
+ (when sectiondicts
+ (let ((new (srecode-create-dictionary t)))
+ ;; Loop over each section. The section is a macro w/in the
+ ;; template.
+ (while sectiondicts
+ (let* ((sect (car (car sectiondicts)))
+ (entries (cdr (car sectiondicts)))
+ (subdict (srecode-dictionary-add-section-dictionary new sect))
+ )
+ ;; Loop over each entry. This is one variable in the
+ ;; section dictionary.
+ (while entries
+ (let ((tname (semantic-tag-name (car entries)))
+ (val (semantic-tag-variable-default (car entries))))
+ (if (eq val t)
+ (srecode-dictionary-show-section subdict tname)
+ (cond
+ ((and (stringp (car val))
+ (= (length val) 1))
+ (setq val (car val)))
+ (t
+ (setq val (srecode-dictionary-compound-variable
+ tname :value val :state STATE))))
+ (srecode-dictionary-set-value
+ subdict tname val))
+ (setq entries (cdr entries))))
+ )
+ (setq sectiondicts (cdr sectiondicts)))
+ new)))
+
+;;; DUMP DICTIONARY
+;;
+;; Make a dictionary, and dump it's contents.
+
+(defun srecode-adebug-dictionary ()
+ "Run data-debug on this mode's dictionary."
+ (interactive)
+ (require 'eieio-datadebug)
+ (require 'semantic)
+ (require 'srecode/find)
+ (let* ((modesym major-mode)
+ (start (current-time))
+ (junk (or (progn (srecode-load-tables-for-mode modesym)
+ (srecode-get-mode-table modesym))
+ (error "No table found for mode %S" modesym)))
+ (dict (srecode-create-dictionary (current-buffer)))
+ (end (current-time))
+ )
+ (message "Creating a dictionary took %.2f seconds."
+ (semantic-elapsed-time start end))
+ (data-debug-new-buffer "*SRECODE ADEBUG*")
+ (data-debug-insert-object-slots dict "*")))
+
+(defun srecode-dictionary-dump ()
+ "Dump a typical fabricated dictionary."
+ (interactive)
+ (require 'srecode/find)
+ (let ((modesym major-mode))
+ ;; This load allows the dictionary access to inherited
+ ;; and stacked dictionary entries.
+ (srecode-load-tables-for-mode modesym)
+ (let ((tmp (srecode-get-mode-table modesym))
+ )
+ (if (not tmp)
+ (error "No table found for mode %S" modesym))
+ ;; Now make the dictionary.
+ (let ((dict (srecode-create-dictionary (current-buffer))))
+ (with-output-to-temp-buffer "*SRECODE DUMP*"
+ (princ "DICTIONARY FOR ")
+ (princ major-mode)
+ (princ "\n--------------------------------------------\n")
+ (srecode-dump dict))
+ ))))
+
+(defmethod srecode-dump ((dict srecode-dictionary) &optional indent)
+ "Dump a dictionary."
+ (if (not indent) (setq indent 0))
+ (maphash (lambda (key entry)
+ (princ (make-string indent ? ))
+ (princ " ")
+ (princ key)
+ (princ " ")
+ (cond ((and (listp entry)
+ (srecode-dictionary-p (car entry)))
+ (let ((newindent (if indent
+ (+ indent 4)
+ 4)))
+ (while entry
+ (princ " --> SUBDICTIONARY ")
+ (princ (object-name dict))
+ (princ "\n")
+ (srecode-dump (car entry) newindent)
+ (setq entry (cdr entry))
+ ))
+ (princ "\n")
+ )
+ ((srecode-dictionary-compound-value-child-p entry)
+ (srecode-dump entry indent)
+ (princ "\n")
+ )
+ (t
+ (prin1 entry)
+ ;(princ "\n")
+ ))
+ (terpri)
+ )
+ (oref dict namehash))
+ )
+
+(provide 'srecode/dictionary)
+
+;;; srecode/dictionary.el ends here
Index: cedet/srecode/document.el
===================================================================
RCS file: cedet/srecode/document.el
diff -N cedet/srecode/document.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/srecode/document.el 28 Sep 2009 15:15:11 -0000 1.2
@@ -0,0 +1,841 @@
+;;; srecode/document.el --- Documentation (comment) generation
+
+;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Routines for fabricating human readable text from function and
+;; variable names as base-text for function comments. Document is not
+;; meant to generate end-text for any function. It is merely meant to
+;; provide some useful base words and text, and as a framework for
+;; managing comments.
+;;
+;;; Origins:
+;;
+;; Document was first written w/ cparse, a custom regexp based c parser.
+;;
+;; Document was then ported to cedet/semantic using sformat (super
+;; format) as the templating engine.
+;;
+;; Document has now been ported to srecode, using the semantic recoder
+;; as the templating engine.
+
+;; This file combines srecode-document.el and srecode-document-vars.el
+;; from the CEDET repository.
+
+(require 'srecode/args)
+(require 'srecode/dictionary)
+(require 'srecode/extract)
+(require 'srecode/insert)
+(require 'srecode/semantic)
+
+(require 'semantic)
+(require 'semantic/tag)
+(require 'semantic/doc)
+(require 'pulse)
+
+;;; Code:
+
+(defgroup document nil
+ "File and tag browser frame."
+ :group 'texinfo
+ :group 'srecode)
+
+(defcustom srecode-document-autocomment-common-nouns-abbrevs
+ '(
+ ("sock\\(et\\)?" . "socket")
+ ("addr\\(ess\\)?" . "address")
+ ("buf\\(f\\(er\\)?\\)?" . "buffer")
+ ("cur\\(r\\(ent\\)?\\)?" . "current")
+ ("dev\\(ice\\)?" . "device")
+ ("doc" . "document")
+ ("i18n" . "internationalization")
+ ("file" . "file")
+ ("line" . "line")
+ ("l10n" . "localization")
+ ("msg\\|message" . "message")
+ ("name" . "name")
+ ("next\\|nxt" . "next")
+ ("num\\(ber\\)?" . "number")
+ ("port" . "port")
+ ("host" . "host")
+ ("obj\\|object" . "object")
+ ("previous\\|prev" . "previous")
+ ("str\\(ing\\)?" . "string")
+ ("use?r" . "user")
+ ("\\(^\\|\\s-\\)id\\($\\|\\s-\\)" . "Identifier") ;complex cause ;common
syllable
+ )
+ "List of common English abbreviations or full words.
+These are nouns (as opposed to verbs) for use in creating expanded
+versions of names.This is an alist with each element of the form:
+ (MATCH . RESULT)
+MATCH is a regexp to match in the type field.
+RESULT is a string."
+ :group 'document
+ :type '(repeat (cons (string :tag "Regexp")
+ (string :tag "Doc Text"))))
+
+(defcustom srecode-document-autocomment-function-alist
+ '(
+ ("abort" . "Aborts the")
+ ;; trick to get re-alloc and alloc to pair into one sentence.
+ ("realloc" . "moves or ")
+ ("alloc\\(ate\\)?" . "Allocates and initializes a new ")
+ ("clean" . "Cleans up the")
+ ("clobber" . "Removes")
+ ("close" . "Cleanly closes")
+ ("check" . "Checks the")
+ ("comp\\(are\\)?" . "Compares the")
+ ("create" . "Creates a new ")
+ ("find" . "Finds ")
+ ("free" . "Frees up space")
+ ("gen\\(erate\\)?" . "Generates a new ")
+ ("get\\|find" . "Looks for the given ")
+ ("gobble" . "Removes")
+ ("he?lp" . "Provides help for")
+ ("li?ste?n" . "Listens for ")
+ ("connect" . "Connects to ")
+ ("acc?e?pt" . "Accepts a ")
+ ("load" . "Loads in ")
+ ("match" . "Check that parameters match")
+ ("name" . "Provides a name which ")
+ ("new" . "Allocates a ")
+ ("parse" . "Parses the parameters and returns ")
+ ("print\\|display" . "Prints out")
+ ("read" . "Reads from")
+ ("reset" . "Resets the parameters and returns")
+ ("scan" . "Scans the ")
+ ("setup\\|init\\(iallize\\)?" . "Initializes the ")
+ ("select" . "Chooses the ")
+ ("send" . "Sends a")
+ ("re?c\\(v\\|ieves?\\)" . "Receives a ")
+ ("to" . "Converts ")
+ ("update" . "Updates the ")
+ ("wait" . "Waits for ")
+ ("write" . "Writes to")
+ )
+ "List of names to string match against the function name.
+This is an alist with each element of the form:
+ (MATCH . RESULT)
+MATCH is a regexp to match in the type field.
+RESULT is a string.
+
+Certain prefixes may always mean the same thing, and the same comment
+can be used as a beginning for the description. Regexp should be
+lower case since the string they are compared to is downcased.
+A string may end in a space, in which case, last-alist is searched to
+see how best to describe what can be returned.
+Doesn't always work correctly, but that is just because English
+doesn't always work correctly."
+ :group 'document
+ :type '(repeat (cons (string :tag "Regexp")
+ (string :tag "Doc Text"))))
+
+(defcustom srecode-document-autocomment-common-nouns-abbrevs
+ '(
+ ("sock\\(et\\)?" . "socket")
+ ("addr\\(ess\\)?" . "address")
+ ("buf\\(f\\(er\\)?\\)?" . "buffer")
+ ("cur\\(r\\(ent\\)?\\)?" . "current")
+ ("dev\\(ice\\)?" . "device")
+ ("file" . "file")
+ ("line" . "line")
+ ("msg\\|message" . "message")
+ ("name" . "name")
+ ("next\\|nxt" . "next")
+ ("port" . "port")
+ ("host" . "host")
+ ("obj\\|object" . "object")
+ ("previous\\|prev" . "previous")
+ ("str\\(ing\\)?" . "string")
+ ("use?r" . "user")
+ ("num\\(ber\\)?" . "number")
+ ("\\(^\\|\\s-\\)id\\($\\|\\s-\\)" . "Identifier") ;complex cause ;commen
sylable
+ )
+ "List of common English abbreviations or full words.
+These are nouns (as opposed to verbs) for use in creating expanded
+versions of names.This is an alist with each element of the form:
+ (MATCH . RESULT)
+MATCH is a regexp to match in the type field.
+RESULT is a string."
+ :group 'document
+ :type '(repeat (cons (string :tag "Regexp")
+ (string :tag "Doc Text"))))
+
+(defcustom srecode-document-autocomment-return-first-alist
+ '(
+ ;; Static must be first in the list to provide the intro to the sentence
+ ("static" . "Locally defined function which ")
+ ("Bool\\|BOOL" . "Status of ")
+ )
+ "List of regexp matches for types.
+They provide a little bit of text when typing information is
+described.
+This is an alist with each element of the form:
+ (MATCH . RESULT)
+MATCH is a regexp to match in the type field.
+RESULT is a string."
+ :group 'document
+ :type '(repeat (cons (string :tag "Regexp")
+ (string :tag "Doc Text"))))
+
+(defcustom srecode-document-autocomment-return-last-alist
+ '(
+ ("static[ \t\n]+struct \\([a-zA-Z0-9_]+\\)" . "%s")
+ ("struct \\([a-zA-Z0-9_]+\\)" . "%s")
+ ("static[ \t\n]+union \\([a-zA-Z0-9_]+\\)" . "%s")
+ ("union \\([a-zA-Z0-9_]+\\)" . "%s")
+ ("static[ \t\n]+enum \\([a-zA-Z0-9_]+\\)" . "%s")
+ ("enum \\([a-zA-Z0-9_]+\\)" . "%s")
+ ("static[ \t\n]+\\([a-zA-Z0-9_]+\\)" . "%s")
+ ("\\([a-zA-Z0-9_]+\\)" . "of type %s")
+ )
+ "List of regexps which provide the type of the return value.
+This is an alist with each element of the form:
+ (MATCH . RESULT)
+MATCH is a regexp to match in the type field.
+RESULT is a string, which can contain %s, whih is replaced with
+`match-string' 1."
+ :group 'document
+ :type '(repeat (cons (string :tag "Regexp")
+ (string :tag "Doc Text"))))
+
+(defcustom srecode-document-autocomment-param-alist
+ '( ("[Cc]txt" . "Context")
+ ("[Ii]d" . "Identifier of")
+ ("[Tt]ype" . "Type of")
+ ("[Nn]ame" . "Name of")
+ ("argc" . "Number of arguments")
+ ("argv" . "Argument vector")
+ ("envp" . "Environment variable vector")
+ )
+ "Alist of common variable names appearing as function parameters.
+This is an alist with each element of the form:
+ (MATCH . RESULT)
+MATCH is a regexp to match in the type field.
+RESULT is a string of text to use to describe MATCH.
+When one is encountered, document-insert-parameters will automatically
+place this comment after the parameter name."
+ :group 'document
+ :type '(repeat (cons (string :tag "Regexp")
+ (string :tag "Doc Text"))))
+
+(defcustom srecode-document-autocomment-param-type-alist
+ '(("const" . "Constant")
+ ("void" . "Empty")
+ ("char[ ]*\\*" . "String ")
+ ("\\*\\*" . "Pointer to ")
+ ("\\*" . "Pointer ")
+ ("char[ ]*\\([^ \t*]\\|$\\)" . "Character")
+ ("int\\|long" . "Number of")
+ ("FILE" . "File of")
+ ("float\\|double" . "Value of")
+ ;; How about some X things?
+ ("Bool\\|BOOL" . "Flag")
+ ("Window" . "Window")
+ ("GC" . "Graphic Context")
+ ("Widget" . "Widget")
+ )
+ "Alist of input parameter types and strings desribing them.
+This is an alist with each element of the form:
+ (MATCH . RESULT)
+MATCH is a regexp to match in the type field.
+RESULT is a string."
+ :group 'document
+ :type '(repeat (cons (string :tag "Regexp")
+ (string :tag "Doc Text"))))
+
+;;;###autoload
+(defun srecode-document-insert-comment ()
+ "Insert some comments.
+Whack any comments that may be in the way and replace them.
+If the region is active, then insert group function comments.
+If the cursor is in a comment, figure out what kind of comment it is
+ and replace it.
+If the cursor is in a function, insert a function comment.
+If the cursor is on a one line prototype, then insert post-fcn comments."
+ (interactive)
+ (semantic-fetch-tags)
+ (let ((ctxt (srecode-calculate-context)))
+ (if ;; Active region stuff.
+ (or srecode-handle-region-when-non-active-flag
+ (eq last-command 'mouse-drag-region)
+ (and transient-mark-mode mark-active))
+ (if (> (point) (mark))
+ (srecode-document-insert-group-comments (mark) (point))
+ (srecode-document-insert-group-comments (point) (mark)))
+ ;; ELSE
+
+ ;; A declaration comment. Find what it documents.
+ (when (equal ctxt '("declaration" "comment"))
+
+ ;; If we are on a one line tag/comment, go to that fcn.
+ (if (save-excursion (back-to-indentation)
+ (semantic-current-tag))
+ (back-to-indentation)
+
+ ;; Else, do we have a fcn following us?
+ (let ((tag (semantic-find-tag-by-overlay-next)))
+ (when tag (semantic-go-to-tag tag))))
+ )
+
+ ;; Now analyze the tag we may be on.
+
+ (if (semantic-current-tag)
+ (cond
+ ;; A one-line variable
+ ((and (semantic-tag-of-class-p (semantic-current-tag) 'variable)
+ (srecode-document-one-line-tag-p (semantic-current-tag)))
+ (srecode-document-insert-variable-one-line-comment))
+ ;; A plain function
+ ((semantic-tag-of-class-p (semantic-current-tag) 'function)
+ (srecode-document-insert-function-comment))
+ ;; Don't know.
+ (t
+ (error "Not sure what to comment"))
+ )
+
+ ;; ELSE, no tag. Perhaps we should just insert a nice section
+ ;; header??
+
+ (let ((title (read-string "Section Title (RET to skip): ")))
+
+ (when (and (stringp title) (not (= (length title) 0)))
+ (srecode-document-insert-section-comment title)))
+
+ ))))
+
+(defun srecode-document-insert-section-comment (&optional title)
+ "Insert a section comment with TITLE."
+ (interactive "sSection Title: ")
+
+ (srecode-load-tables-for-mode major-mode)
+ (srecode-load-tables-for-mode major-mode 'document)
+
+ (if (not (srecode-table))
+ (error "No template table found for mode %s" major-mode))
+
+ (let* ((dict (srecode-create-dictionary))
+ (temp (srecode-template-get-table (srecode-table)
+ "section-comment"
+ "declaration"
+ 'document)))
+ (if (not temp)
+ (error "No templates for inserting section comments"))
+
+ (when title
+ (srecode-dictionary-set-value
+ dict "TITLE" title))
+
+ (srecode-insert-fcn temp dict)
+ ))
+
+
+(defun srecode-document-trim-whitespace (str)
+ "Strip stray whitespace from around STR."
+ (when (string-match "^\\(\\s-\\|\n\\)+" str)
+ (setq str (replace-match "" t t str)))
+ (when (string-match "\\(\\s-\\|\n\\)+$" str)
+ (setq str (replace-match "" t t str)))
+ str)
+
+;;;###autoload
+(defun srecode-document-insert-function-comment (&optional fcn-in)
+ "Insert or replace a function comment.
+FCN-IN is the Semantic tag of the function to add a comment too.
+If FCN-IN is not provied, the current tag is used instead.
+It is assumed that the comment occurs just in front of FCN-IN."
+ (interactive)
+
+ (srecode-load-tables-for-mode major-mode)
+ (srecode-load-tables-for-mode major-mode 'document)
+
+ (if (not (srecode-table))
+ (error "No template table found for mode %s" major-mode))
+
+ (let* ((dict (srecode-create-dictionary))
+ (temp (srecode-template-get-table (srecode-table)
+ "function-comment"
+ "declaration"
+ 'document)))
+ (if (not temp)
+ (error "No templates for inserting function comments"))
+
+ ;; Try to figure out the tag we want to use.
+ (when (not fcn-in)
+ (semantic-fetch-tags)
+ (setq fcn-in (semantic-current-tag)))
+
+ (when (or (not fcn-in)
+ (not (semantic-tag-of-class-p fcn-in 'function)))
+ (error "No tag of class 'function to insert comment for"))
+
+ (if (not (eq (current-buffer) (semantic-tag-buffer fcn-in)))
+ (error "Only insert comments for tags in the current buffer"))
+
+ ;; Find any existing doc strings.
+ (semantic-go-to-tag fcn-in)
+ (beginning-of-line)
+ (forward-char -1)
+
+ (let ((lextok (semantic-documentation-comment-preceeding-tag fcn-in 'lex))
+ (doctext
+ (srecode-document-function-name-comment fcn-in))
+ )
+
+ (when lextok
+ (let* ((s (semantic-lex-token-start lextok))
+ (e (semantic-lex-token-end lextok))
+ (plaintext
+ (srecode-document-trim-whitespace
+ (save-excursion
+ (goto-char s)
+ (semantic-doc-snarf-comment-for-tag nil))))
+ (extract (condition-case nil
+ (srecode-extract temp s e)
+ (error nil))
+ )
+ (distance (count-lines e (semantic-tag-start fcn-in)))
+ (belongelsewhere (save-excursion
+ (goto-char s)
+ (back-to-indentation)
+ (semantic-current-tag)))
+ )
+
+ (when (not belongelsewhere)
+
+ (pulse-momentary-highlight-region s e)
+
+ ;; There are many possible states that comment could be in.
+ ;; Take a guess about what the user would like to do, and ask
+ ;; the right kind of question.
+ (when (or (not (> distance 2))
+ (y-or-n-p "Replace this comment? "))
+
+ (when (> distance 2)
+ (goto-char e)
+ (delete-horizontal-space)
+ (delete-blank-lines))
+
+ (cond
+ ((and plaintext (not extract))
+ (if (y-or-n-p "Convert old-style comment to Template with old
text? ")
+ (setq doctext plaintext))
+ (delete-region s e)
+ (goto-char s))
+ (extract
+ (when (y-or-n-p "Refresh pre-existing comment (recycle old
doc)? ")
+ (delete-region s e)
+ (goto-char s)
+ (setq doctext
+ (srecode-document-trim-whitespace
+ (srecode-dictionary-lookup-name extract "DOC")))))
+ ))
+ )))
+
+ (beginning-of-line)
+
+ ;; Perform the insertion
+ (let ((srecode-semantic-selected-tag fcn-in)
+ (srecode-semantic-apply-tag-augment-hook
+ (lambda (tag dict)
+ (srecode-dictionary-set-value
+ dict "DOC"
+ (if (eq tag fcn-in)
+ doctext
+ (srecode-document-parameter-comment tag))
+ )))
+ )
+ (srecode-insert-fcn temp dict)
+ ))
+ ))
+
+;;;###autoload
+(defun srecode-document-insert-variable-one-line-comment (&optional var-in)
+ "Insert or replace a variable comment.
+VAR-IN is the Semantic tag of the function to add a comment too.
+If VAR-IN is not provied, the current tag is used instead.
+It is assumed that the comment occurs just after VAR-IN."
+ (interactive)
+
+ (srecode-load-tables-for-mode major-mode)
+ (srecode-load-tables-for-mode major-mode 'document)
+
+ (if (not (srecode-table))
+ (error "No template table found for mode %s" major-mode))
+
+ (let* ((dict (srecode-create-dictionary))
+ (temp (srecode-template-get-table (srecode-table)
+ "variable-same-line-comment"
+ "declaration"
+ 'document)))
+ (if (not temp)
+ (error "No templates for inserting variable comments"))
+
+ ;; Try to figure out the tag we want to use.
+ (when (not var-in)
+ (semantic-fetch-tags)
+ (setq var-in (semantic-current-tag)))
+
+ (when (or (not var-in)
+ (not (semantic-tag-of-class-p var-in 'variable)))
+ (error "No tag of class 'variable to insert comment for"))
+
+ (if (not (eq (current-buffer) (semantic-tag-buffer var-in)))
+ (error "Only insert comments for tags in the current buffer"))
+
+ ;; Find any existing doc strings.
+ (goto-char (semantic-tag-end var-in))
+ (skip-syntax-forward "-" (point-at-eol))
+ (let ((lextok (semantic-doc-snarf-comment-for-tag 'lex))
+ )
+
+ (when lextok
+ (let ((s (semantic-lex-token-start lextok))
+ (e (semantic-lex-token-end lextok)))
+
+ (pulse-momentary-highlight-region s e)
+
+ (when (not (y-or-n-p "A comment already exists. Replace? "))
+ (error "Quit"))
+
+ ;; Extract text from the existing comment.
+ (srecode-extract temp s e)
+
+ (delete-region s e)
+ (goto-char s) ;; To avoid adding a CR.
+ ))
+ )
+
+ ;; Clean up the end of the line and use handy comment-column.
+ (end-of-line)
+ (delete-horizontal-space)
+ (move-to-column comment-column t)
+ (when (< (point) (point-at-eol)) (end-of-line))
+
+ ;; Perform the insertion
+ (let ((srecode-semantic-selected-tag var-in)
+ (srecode-semantic-apply-tag-augment-hook
+ (lambda (tag dict)
+ (srecode-dictionary-set-value
+ dict "DOC" (srecode-document-parameter-comment
+ tag))))
+ )
+ (srecode-insert-fcn temp dict)
+ ))
+ )
+
+;;;###autoload
+(defun srecode-document-insert-group-comments (beg end)
+ "Insert group comments around the active between BEG and END.
+If the region includes only parts of some tags, expand out
+to the beginning and end of the tags on the region.
+If there is only one tag in the region, complain."
+ (interactive "r")
+ (srecode-load-tables-for-mode major-mode)
+ (srecode-load-tables-for-mode major-mode 'document)
+
+ (if (not (srecode-table))
+ (error "No template table found for mode %s" major-mode))
+
+ (let* ((dict (srecode-create-dictionary))
+ (context "declaration")
+ (temp-start nil)
+ (temp-end nil)
+ (tag-start (save-excursion
+ (goto-char beg)
+ (or (semantic-current-tag)
+ (semantic-find-tag-by-overlay-next))))
+ (tag-end (save-excursion
+ (goto-char end)
+ (or (semantic-current-tag)
+ (semantic-find-tag-by-overlay-prev))))
+ (parent-tag nil)
+ (first-pos beg)
+ (second-pos end)
+ )
+
+ ;; If beg/end wrapped nothing, then tag-start,end would actually
+ ;; point at some odd stuff that is out of order.
+ (when (or (not tag-start) (not tag-end)
+ (> (semantic-tag-end tag-start)
+ (semantic-tag-start tag-end)))
+ (setq tag-start nil
+ tag-end nil))
+
+ (when tag-start
+ ;; If tag-start and -end are the same, and it is a class or
+ ;; struct, try to find child tags inside the classdecl.
+ (cond
+ ((and (eq tag-start tag-end)
+ tag-start
+ (semantic-tag-of-class-p tag-start 'type))
+ (setq parent-tag tag-start)
+ (setq tag-start (semantic-find-tag-by-overlay-next beg)
+ tag-end (semantic-find-tag-by-overlay-prev end))
+ )
+ ((eq (semantic-find-tag-parent-by-overlay tag-start) tag-end)
+ (setq parent-tag tag-end)
+ (setq tag-end (semantic-find-tag-by-overlay-prev end))
+ )
+ ((eq tag-start (semantic-find-tag-parent-by-overlay tag-end))
+ (setq parent-tag tag-start)
+ (setq tag-start (semantic-find-tag-by-overlay-next beg))
+ )
+ )
+
+ (when parent-tag
+ ;; We are probably in a classdecl
+ ;; @todo -could I really use (srecode-calculate-context) ?
+
+ (setq context "classdecl")
+ )
+
+ ;; Derive start and end locations based on the tags.
+ (setq first-pos (semantic-tag-start tag-start)
+ second-pos (semantic-tag-end tag-end))
+ )
+ ;; Now load the templates
+ (setq temp-start (srecode-template-get-table (srecode-table)
+ "group-comment-start"
+ context
+ 'document)
+ temp-end (srecode-template-get-table (srecode-table)
+ "group-comment-end"
+ context
+ 'document))
+
+ (when (or (not temp-start) (not temp-end))
+ (error "No templates for inserting group comments"))
+
+ ;; Setup the name of this group ahead of time.
+
+ ;; @todo - guess at a name based on common strings
+ ;; of the tags in the group.
+ (srecode-dictionary-set-value
+ dict "GROUPNAME"
+ (read-string "Name of group: "))
+
+ ;; Perform the insertion
+ ;; Do the end first so we don't need to recalculate anything.
+ ;;
+ (goto-char second-pos)
+ (end-of-line)
+ (srecode-insert-fcn temp-end dict)
+
+ (goto-char first-pos)
+ (beginning-of-line)
+ (srecode-insert-fcn temp-start dict)
+
+ ))
+
+
+;;; Document Generation Functions
+;;
+;; Routines for making up English style comments.
+
+(defun srecode-document-function-name-comment (tag)
+ "Create documentation for the function defined in TAG.
+If we can identify a verb in the list followed by some
+name part then check the return value to see if we can use that to
+finish off the sentence. ie. any function with 'alloc' in it will be
+allocating something based on its type."
+ (let ((al srecode-document-autocomment-return-first-alist)
+ (dropit nil)
+ (tailit nil)
+ (news "")
+ (fname (semantic-tag-name tag))
+ (retval (or (semantic-tag-type tag) "")))
+ (if (listp retval)
+ ;; convert a type list into a long string to analyze.
+ (setq retval (car retval)))
+ ;; check for modifiers like static
+ (while al
+ (if (string-match (car (car al)) (downcase retval))
+ (progn
+ (setq news (concat news (cdr (car al))))
+ (setq dropit t)
+ (setq al nil)))
+ (setq al (cdr al)))
+ ;; check for verb parts!
+ (setq al srecode-document-autocomment-function-alist)
+ (while al
+ (if (string-match (car (car al)) (downcase fname))
+ (progn
+ (setq news
+ (concat news (if dropit (downcase (cdr (car al)))
+ (cdr (car al)))))
+ ;; if we end in a space, then we are expecting a potential
+ ;; return value.
+ (if (= ? (aref news (1- (length news))))
+ (setq tailit t))
+ (setq al nil)))
+ (setq al (cdr al)))
+ ;; check for noun parts!
+ (setq al srecode-document-autocomment-common-nouns-abbrevs)
+ (while al
+ (if (string-match (car (car al)) (downcase fname))
+ (progn
+ (setq news
+ (concat news (if dropit (downcase (cdr (car al)))
+ (cdr (car al)))))
+ (setq al nil)))
+ (setq al (cdr al)))
+ ;; add tailers to names which are obviously returning something.
+ (if tailit
+ (progn
+ (setq al srecode-document-autocomment-return-last-alist)
+ (while al
+ (if (string-match (car (car al)) (downcase retval))
+ (progn
+ (setq news
+ (concat news " "
+ ;; this one may use parts of the return value.
+ (format (cdr (car al))
+ (srecode-document-programmer->english
+ (substring retval (match-beginning 1)
+ (match-end 1))))))
+ (setq al nil)))
+ (setq al (cdr al)))))
+ news))
+
+(defun srecode-document-parameter-comment (param &optional commentlist)
+ "Convert tag or string PARAM into a name,comment pair.
+Optional COMMENTLIST is list of previously existing comments to
+use instead in alist form. If the name doesn't appear in the list of
+standard names, then englishify it instead."
+ (let ((cmt "")
+ (aso srecode-document-autocomment-param-alist)
+ (fnd nil)
+ (name (if (stringp param) param (semantic-tag-name param)))
+ (tt (if (stringp param) nil (semantic-tag-type param))))
+ ;; Make sure the type is a string.
+ (if (listp tt)
+ (setq tt (semantic-tag-name tt)))
+ ;; Find name description parts.
+ (while aso
+ (if (string-match (car (car aso)) name)
+ (progn
+ (setq fnd t)
+ (setq cmt (concat cmt (cdr (car aso))))))
+ (setq aso (cdr aso)))
+ (if (/= (length cmt) 0)
+ nil
+ ;; finally check for array parts
+ (if (and (not (stringp param)) (semantic-tag-modifiers param))
+ (setq cmt (concat cmt "array of ")))
+ (setq aso srecode-document-autocomment-param-type-alist)
+ (while (and aso tt)
+ (if (string-match (car (car aso)) tt)
+ (setq cmt (concat cmt (cdr (car aso)))))
+ (setq aso (cdr aso))))
+ ;; Convert from programmer to english.
+ (if (not fnd)
+ (setq cmt (concat cmt " "
+ (srecode-document-programmer->english name))))
+ cmt))
+
+(defun srecode-document-programmer->english (programmer)
+ "Take PROGRAMMER and convert it into English.
+Works with the following rules:
+ 1) convert all _ into spaces.
+ 2) inserts spaces between CamelCasing word breaks.
+ 3) expands noun names based on common programmer nouns.
+
+ This function is designed for variables, not functions. This does
+not account for verb parts."
+ (if (string= "" programmer)
+ ""
+ (let ((ind 0) ;index in string
+ (llow nil) ;lower/upper case flag
+ (newstr nil) ;new string being generated
+ (al nil)) ;autocomment list
+ ;;
+ ;; 1) Convert underscores
+ ;;
+ (while (< ind (length programmer))
+ (setq newstr (concat newstr
+ (if (= (aref programmer ind) ?_)
+ " " (char-to-string (aref programmer ind)))))
+ (setq ind (1+ ind)))
+ (setq programmer newstr
+ newstr nil
+ ind 0)
+ ;;
+ ;; 2) Find word breaks between case changes
+ ;;
+ (while (< ind (length programmer))
+ (setq newstr
+ (concat newstr
+ (let ((tc (aref programmer ind)))
+ (if (and (>= tc ?a) (<= tc ?z))
+ (progn
+ (setq llow t)
+ (char-to-string tc))
+ (if llow
+ (progn
+ (setq llow nil)
+ (concat " " (char-to-string tc)))
+ (char-to-string tc))))))
+ (setq ind (1+ ind)))
+ ;;
+ ;; 3) Expand the words if possible
+ ;;
+ (setq llow nil
+ ind 0
+ programmer newstr
+ newstr nil)
+ (while (string-match (concat "^\\s-*\\([^ \t\n]+\\)") programmer)
+ (let ((ts (substring programmer (match-beginning 1) (match-end 1)))
+ (end (match-end 1)))
+ (setq al srecode-document-autocomment-common-nouns-abbrevs)
+ (setq llow nil)
+ (while al
+ (if (string-match (car (car al)) (downcase ts))
+ (progn
+ (setq newstr (concat newstr (cdr (car al))))
+ ;; don't terminate because we may actuall have 2 words
+ ;; next to eachother we didn't identify before
+ (setq llow t)))
+ (setq al (cdr al)))
+ (if (not llow) (setq newstr (concat newstr ts)))
+ (setq newstr (concat newstr " "))
+ (setq programmer (substring programmer end))))
+ newstr)))
+
+;;; UTILS
+;;
+(defun srecode-document-one-line-tag-p (tag)
+ "Does TAG fit on one line with space on the end?"
+ (save-excursion
+ (semantic-go-to-tag tag)
+ (and (<= (semantic-tag-end tag) (point-at-eol))
+ (goto-char (semantic-tag-end tag))
+ (< (current-column) 70))))
+
+(provide 'srecode/document)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: srecode/loaddefs
+;; generated-autoload-load-name: "srecode/document"
+;; End:
+
+;;; srecode/document.el ends here
Index: cedet/srecode/el.el
===================================================================
RCS file: cedet/srecode/el.el
diff -N cedet/srecode/el.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/srecode/el.el 28 Sep 2009 15:15:11 -0000 1.2
@@ -0,0 +1,113 @@
+;;; srecode/el.el --- Emacs Lisp specific arguments
+
+;; Copyright (C) 2008 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Emacs Lisp specific handlers. To use these handlers in your
+;; template, add the :name part to your template argument list.
+;;
+;; Error if not in a Emacs Lisp mode
+
+;;; Code:
+
+(require 'srecode)
+(require 'srecode/semantic)
+
+(declare-function semanticdb-brute-find-tags-by-class "semantic/db-find")
+
+;;;###autoload
+(defun srecode-semantic-handle-:el (dict)
+ "Add macros into the dictionary DICT based on the current Emacs Lisp file.
+Adds the following:
+ PRENAME - The common name prefix of this file."
+ (let* ((names (append (semantic-find-tags-by-class 'function
(current-buffer))
+ (semantic-find-tags-by-class 'variable
(current-buffer)))
+ )
+ (common (try-completion "" names)))
+
+ (srecode-dictionary-set-value dict "PRENAME" common)
+ ))
+
+;;;###autoload
+(defun srecode-semantic-handle-:el-custom (dict)
+ "Add macros into the dictionary DICT based on the current Emacs Lisp file.
+Adds the following:
+ GROUP - The 'defgroup' name we guess you want for variables.
+ FACEGROUP - The `defgroup' name you might want for faces."
+ (require 'semantic/db-find)
+ (let ((groups (semanticdb-strip-find-results
+ (semanticdb-brute-find-tags-by-class 'customgroup)))
+ (varg nil)
+ (faceg nil)
+ )
+
+ ;; Pick the best group
+ (while groups
+ (cond ((string-match "face" (semantic-tag-name (car groups)))
+ (setq faceg (car groups)))
+ ((not varg)
+ (setq varg (car groups)))
+ (t
+ ;; What about other groups?
+ ))
+ (setq groups (cdr groups)))
+
+ ;; Double check the facegroup.
+ (setq faceg (or faceg varg))
+
+ ;; Setup some variables
+ (srecode-dictionary-set-value dict "GROUP" (semantic-tag-name varg))
+ (srecode-dictionary-set-value dict "FACEGROUP" (semantic-tag-name faceg))
+
+ ))
+
+(define-mode-local-override srecode-semantic-apply-tag-to-dict
+ emacs-lisp-mode (tagobj dict)
+ "Apply Emacs Lisp specific features from TAGOBJ into DICT.
+Calls `srecode-semantic-apply-tag-to-dict-default' first."
+ (srecode-semantic-apply-tag-to-dict-default tagobj dict)
+
+ ;; Pull out the tag for the individual pieces.
+ (let* ((tag (oref tagobj :prime))
+ (doc (semantic-tag-docstring tag)))
+
+ ;; It is much more common to have doc on ELisp.
+ (srecode-dictionary-set-value dict "DOC" doc)
+
+ (cond
+ ;;
+ ;; FUNCTION
+ ;;
+ ((eq (semantic-tag-class tag) 'function)
+ (if (semantic-tag-get-attribute tag :user-visible-flag)
+ (srecode-dictionary-set-value dict "INTERACTIVE" " (interactive)\n
")
+ (srecode-dictionary-set-value dict "INTERACTIVE" ""))))))
+
+
+(provide 'srecode/el)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: srecode/loaddefs
+;; generated-autoload-load-name: "srecode/el"
+;; End:
+
+;;; srecode/el.el ends here
Index: cedet/srecode/expandproto.el
===================================================================
RCS file: cedet/srecode/expandproto.el
diff -N cedet/srecode/expandproto.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/srecode/expandproto.el 28 Sep 2009 15:15:11 -0000 1.2
@@ -0,0 +1,133 @@
+;;; srecode/expandproto.el --- Expanding prototypes.
+
+;; Copyright (C) 2007 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Methods for expanding a prototype into an implementation.
+
+(require 'ring)
+(require 'semantic)
+(require 'semantic/analyze)
+(require 'semantic/senator)
+(require 'srecode/insert)
+(require 'srecode/dictionary)
+
+(declare-function semantic-brute-find-tag-by-attribute-value "semantic/find")
+
+;;; Code:
+(defcustom srecode-expandproto-template-file-alist
+ '( ( c++-mode . "srecode-expandproto-cpp.srt" )
+ )
+ ;; @todo - Make this variable auto-generated from the Makefile.
+ "Associate template files for expanding prototypes to a major mode."
+ :group 'srecode
+ :type '(repeat (cons (sexp :tag "Mode")
+ (sexp :tag "Filename"))
+ ))
+
+;;;###autoload
+(defun srecode-insert-prototype-expansion ()
+ "Insert get/set methods for the current class."
+ (interactive)
+
+ (srecode-load-tables-for-mode major-mode)
+ (srecode-load-tables-for-mode major-mode
+ srecode-expandproto-template-file-alist)
+
+ (if (not (srecode-table))
+ (error "No template table found for mode %s" major-mode))
+
+ (let ((proto
+ ;; Step 1: Find the prototype, or prototype list to expand.
+ (srecode-find-prototype-for-expansion)))
+
+ (if (not proto)
+ (error "Could not find prototype to expand"))
+
+ ;; Step 2: Insert implementations of the prototypes.
+
+
+ ))
+
+(defun srecode-find-prototype-for-expansion ()
+ "Find a prototype to use for expanding into an implementation."
+ ;; We may find a prototype tag in one of several places.
+ ;; Search in order of logical priority.
+ (let ((proto nil)
+ )
+
+ ;; 1) A class full of prototypes under point.
+ (let ((tag (semantic-current-tag)))
+ (when tag
+ (when (not (semantic-tag-of-class-p tag 'type))
+ (setq tag (semantic-current-tag-parent))))
+ (when (and tag (semantic-tag-of-class-p tag 'type))
+ ;; If the current class has prototype members, then
+ ;; we will do the whole class!
+ (require 'semantic/find)
+ (if (semantic-brute-find-tag-by-attribute-value
+ :prototype t
+ (semantic-tag-type-members tag))
+ (setq proto tag)))
+ )
+
+ ;; 2) A prototype under point.
+ (when (not proto)
+ (let ((tag (semantic-current-tag)))
+ (when (and tag
+ (and
+ (semantic-tag-of-class-p tag 'function)
+ (semantic-tag-get-attribute tag :prototype)))
+ (setq proto tag))))
+
+ ;; 3) A tag in the kill ring that is a prototype
+ (when (not proto)
+ (if (ring-empty-p senator-tag-ring)
+ nil ;; Not for us.
+ (let ((tag (ring-ref senator-tag-ring 0))
+ )
+ (when
+ (and tag
+ (or
+ (and
+ (semantic-tag-of-class-p tag 'function)
+ (semantic-tag-get-attribute tag :prototype))
+ (and
+ (semantic-tag-of-class-p tag 'type)
+ (require 'semantic/find)
+ (semantic-brute-find-tag-by-attribute-value
+ :prototype t
+ (semantic-tag-type-members tag))))
+ )
+ (setq proto tag))
+ )))
+
+ proto))
+
+(provide 'srecode-expandproto)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: srecode/loaddefs
+;; generated-autoload-load-name: "srecode/expandproto"
+;; End:
+
+;;; srecode/expandproto.el ends here
Index: cedet/srecode/extract.el
===================================================================
RCS file: cedet/srecode/extract.el
diff -N cedet/srecode/extract.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/srecode/extract.el 28 Sep 2009 15:15:11 -0000 1.2
@@ -0,0 +1,242 @@
+;;; srecode/extract.el --- Extract content from previously inserted macro.
+
+;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Extract content from a previously inserted macro.
+;;
+;; The extraction routines can be handy if you want to extract users
+;; added text from the middle of a template inserted block of text.
+;; This code will not work for all templates. It will only work for
+;; templates with unique static text between all the different insert
+;; macros.
+;;
+;; That said, it will handle include and section templates, so complex
+;; or deep template calls can be extracted.
+;;
+;; This code was specifically written for srecode-document, which
+;; wants to extract user written text, and re-use it in a reformatted
+;; comment.
+
+(require 'srecode)
+(require 'srecode/compile)
+(require 'srecode/insert)
+
+;;; Code:
+
+(defclass srecode-extract-state ()
+ ((anchor :initform nil
+ :documentation
+ "The last known plain-text end location.")
+ (lastinserter :initform nil
+ :documentation
+ "The last inserter with 'later extraction type.")
+ (lastdict :initform nil
+ :documentation
+ "The dictionary associated with lastinserter.")
+ )
+ "The current extraction state.")
+
+(defmethod srecode-extract-state-set ((st srecode-extract-state) ins dict)
+ "Set onto the extract state ST a new inserter INS and dictinary DICT."
+ (oset st lastinserter ins)
+ (oset st lastdict dict))
+
+(defmethod srecode-extract-state-set-anchor ((st srecode-extract-state))
+ "Reset the achor point on extract state ST."
+ (oset st anchor (point)))
+
+(defmethod srecode-extract-state-extract ((st srecode-extract-state)
+ endpoint)
+ "Perform an extraction on the extract state ST with ENDPOITNT.
+If there was no waiting inserter, do nothing."
+ (when (oref st lastinserter)
+ (save-match-data
+ (srecode-inserter-extract (oref st lastinserter)
+ (oref st anchor)
+ endpoint
+ (oref st lastdict)
+ st))
+ ;; Clear state.
+ (srecode-extract-state-set st nil nil)))
+
+;;; Extraction
+;l
+(defun srecode-extract (template start end)
+ "Extract TEMPLATE from between START and END in the current buffer.
+Uses TEMPLATE's constant strings to break up the text and guess what
+the dictionary entries were for that block of text."
+ (save-excursion
+ (save-restriction
+ (narrow-to-region start end)
+ (let ((dict (srecode-create-dictionary t))
+ (state (srecode-extract-state "state"))
+ )
+ (goto-char start)
+ (srecode-extract-method template dict state)
+ dict))))
+
+(defmethod srecode-extract-method ((st srecode-template) dictionary
+ state)
+ "Extract template ST and store extracted text in DICTIONARY.
+Optional STARTRETURN is a symbol in which the start of the first
+plain-text match occured."
+ (srecode-extract-code-stream (oref st code) dictionary state))
+
+(defun srecode-extract-code-stream (code dictionary state)
+ "Extract CODE from buffer text into DICTIONARY.
+Uses string constants in CODE to split up the buffer.
+Uses STATE to maintain the current extraction state."
+ (while code
+ (cond
+
+ ;; constant strings need mark the end of old inserters that
+ ;; need to extract values, or are just there.
+ ((stringp (car code))
+ (srecode-extract-state-set-anchor state)
+ ;; When we have a string, find it in the collection, then extract
+ ;; that start point as the end point of the inserter
+ (unless (re-search-forward (regexp-quote (car code))
+ (point-max) t)
+ (error "Unable to extract all dictionary entries"))
+
+ (srecode-extract-state-extract state (match-beginning 0))
+ (goto-char (match-end 0))
+ )
+
+ ;; Some inserters are simple, and need to be extracted after
+ ;; we find our next block of static text.
+ ((eq (srecode-inserter-do-extract-p (car code)) 'later)
+ (srecode-extract-state-set state (car code) dictionary)
+ )
+
+ ;; Some inserter want to start extraction now, such as sections.
+ ;; We can't predict the end point till we parse out the middle.
+ ((eq (srecode-inserter-do-extract-p (car code)) 'now)
+ (srecode-extract-state-set-anchor state)
+ (srecode-inserter-extract (car code) (point) nil dictionary state))
+ )
+ (setq code (cdr code))
+ ))
+
+;;; Inserter Base Extractors
+;;
+(defmethod srecode-inserter-do-extract-p ((ins srecode-template-inserter))
+ "Return non-nil if this inserter can extract values."
+ nil)
+
+(defmethod srecode-inserter-extract ((ins srecode-template-inserter)
+ start end dict state)
+ "Extract text from START/END and store in DICT.
+Return nil as this inserter will extract nothing."
+ nil)
+
+;;; Variable extractor is simple and can extract later.
+;;
+(defmethod srecode-inserter-do-extract-p ((ins
srecode-template-inserter-variable))
+ "Return non-nil if this inserter can extract values."
+ 'later)
+
+(defmethod srecode-inserter-extract ((ins srecode-template-inserter-variable)
+ start end vdict state)
+ "Extract text from START/END and store in VDICT.
+Return t if something was extracted.
+Return nil if this inserter doesn't need to extract anything."
+ (srecode-dictionary-set-value vdict
+ (oref ins :object-name)
+ (buffer-substring-no-properties
+ start end)
+ )
+ t)
+
+;;; Section Inserter
+;;
+(defmethod srecode-inserter-do-extract-p ((ins
srecode-template-inserter-section-start))
+ "Return non-nil if this inserter can extract values."
+ 'now)
+
+(defmethod srecode-inserter-extract ((ins
srecode-template-inserter-section-start)
+ start end indict state)
+ "Extract text from START/END and store in INDICT.
+Return the starting location of the first plain-text match.
+Return nil if nothing was extracted."
+ (let ((name (oref ins :object-name))
+ (subdict (srecode-create-dictionary indict))
+ (allsubdict nil)
+ )
+
+ ;; Keep extracting till we can extract no more.
+ (while (condition-case nil
+ (progn
+ (srecode-extract-method
+ (oref ins template) subdict state)
+ t)
+ (error nil))
+
+ ;; Success means keep this subdict, and also make a new one for
+ ;; the next iteration.
+ (setq allsubdict (cons subdict allsubdict))
+ (setq subdict (srecode-create-dictionary indict))
+ )
+
+ (srecode-dictionary-set-value indict name (nreverse allsubdict))
+
+ nil))
+
+;;; Include Extractor must extract now.
+;;
+(defmethod srecode-inserter-do-extract-p ((ins
srecode-template-inserter-include))
+ "Return non-nil if this inserter can extract values."
+ 'now)
+
+(defmethod srecode-inserter-extract ((ins srecode-template-inserter-include)
+ start end dict state)
+ "Extract text from START/END and store in DICT.
+Return the starting location of the first plain-text match.
+Return nil if nothing was extracted."
+ (goto-char start)
+ (srecode-insert-include-lookup ins dict)
+ ;; There are two modes for includes. One is with no dict,
+ ;; so it is inserted straight. If the dict has a name, then
+ ;; we need to run once per dictionary occurance.
+ (if (not (string= (oref ins :object-name) ""))
+ ;; With a name, do the insertion.
+ (let ((subdict (srecode-dictionary-add-section-dictionary
+ dict (oref ins :object-name))))
+ (error "Need to implement include w/ name extractor.")
+ ;; Recurse into the new template while no errors.
+ (while (condition-case nil
+ (progn
+ (srecode-extract-method
+ (oref ins includedtemplate) subdict
+ state)
+ t)
+ (error nil))))
+
+ ;; No stream, do the extraction into the current dictionary.
+ (srecode-extract-method (oref ins includedtemplate) dict
+ state))
+ )
+
+
+(provide 'srecode/extract)
+
+;;; srecode/extract.el ends here
Index: cedet/srecode/fields.el
===================================================================
RCS file: cedet/srecode/fields.el
diff -N cedet/srecode/fields.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/srecode/fields.el 28 Sep 2009 15:15:11 -0000 1.2
@@ -0,0 +1,438 @@
+;;; srecode/fields.el --- Handling type-in fields in a buffer.
+;;
+;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Idea courtesy of yasnippets.
+;;
+;; If someone prefers not to type unknown dictionary entries into
+;; mini-buffer prompts, it could instead use in-buffer fields.
+;;
+;; A template-region specifies an area in which the fields exist. If
+;; the cursor exits the region, all fields are cleared.
+;;
+;; Each field is independent, but some are linked together by name.
+;; Typing in one will cause the matching ones to change in step.
+;;
+;; Each field has 2 overlays. The second overlay allows control in
+;; the character just after the field, but does not highlight it.
+
+;; Keep this library independent of SRecode proper.
+(require 'eieio)
+
+;;; Code:
+(defvar srecode-field-archive nil
+ "While inserting a set of fields, collect in this variable.
+Once an insertion set is done, these fields will be activated.")
+
+(defface srecode-field-face
+ '((((class color) (background dark))
+ (:underline "green"))
+ (((class color) (background light))
+ (:underline "green4")))
+ "*Face used to specify editable fields from a template."
+ :group 'semantic-faces)
+
+;;; BASECLASS
+;;
+;; Fields and the template region share some basic overlay features.
+
+(defclass srecode-overlaid ()
+ ((overlay :documentation
+ "Overlay representing this field.
+The overlay will crossreference this object.")
+ )
+ "An object that gets automatically bound to an overlay.
+Has virtual :start and :end initializers.")
+
+(defmethod initialize-instance ((olaid srecode-overlaid) &optional args)
+ "Initialize OLAID, being sure it archived."
+ ;; Extract :start and :end from the olaid list.
+ (let ((newargs nil)
+ (olay nil)
+ start end
+ )
+
+ (while args
+ (cond ((eq (car args) :start)
+ (setq args (cdr args))
+ (setq start (car args))
+ (setq args (cdr args))
+ )
+ ((eq (car args) :end)
+ (setq args (cdr args))
+ (setq end (car args))
+ (setq args (cdr args))
+ )
+ (t
+ (push (car args) newargs)
+ (setq args (cdr args))
+ (push (car args) newargs)
+ (setq args (cdr args)))
+ ))
+
+ ;; Create a temporary overlay now. We have to use an overlay and
+ ;; not a marker becaues of the in-front insertion rules. The rules
+ ;; are backward from what is wanted while typing.
+ (setq olay (make-overlay start end (current-buffer) t nil))
+ (overlay-put olay 'srecode-init-only t)
+
+ (oset olaid overlay olay)
+ (call-next-method olaid (nreverse newargs))
+
+ ))
+
+(defmethod srecode-overlaid-activate ((olaid srecode-overlaid))
+ "Activate the overlaid area."
+ (let* ((ola (oref olaid overlay))
+ (start (overlay-start ola))
+ (end (overlay-end ola))
+ ;; Create a new overlay here.
+ (ol (make-overlay start end (current-buffer) nil t)))
+
+ ;; Remove the old one.
+ (delete-overlay ola)
+
+ (overlay-put ol 'srecode olaid)
+
+ (oset olaid overlay ol)
+
+ ))
+
+(defmethod srecode-delete ((olaid srecode-overlaid))
+ "Delete the overlay from OLAID."
+ (delete-overlay (oref olaid overlay))
+ (slot-makeunbound olaid 'overlay)
+ )
+
+(defmethod srecode-empty-region-p ((olaid srecode-overlaid))
+ "Return non-nil if the region covered by OLAID is of length 0."
+ (= 0 (srecode-region-size olaid)))
+
+(defmethod srecode-region-size ((olaid srecode-overlaid))
+ "Return the length of region covered by OLAID."
+ (let ((start (overlay-start (oref olaid overlay)))
+ (end (overlay-end (oref olaid overlay))))
+ (- end start)))
+
+(defmethod srecode-point-in-region-p ((olaid srecode-overlaid))
+ "Return non-nil if point is in the region of OLAID."
+ (let ((start (overlay-start (oref olaid overlay)))
+ (end (overlay-end (oref olaid overlay))))
+ (and (>= (point) start) (<= (point) end))))
+
+(defun srecode-overlaid-at-point (class)
+ "Return a list of overlaid fields of type CLASS at point."
+ (let ((ol (overlays-at (point)))
+ (ret nil))
+ (while ol
+ (let ((tmp (overlay-get (car ol) 'srecode)))
+ (when (and tmp (object-of-class-p tmp class))
+ (setq ret (cons tmp ret))))
+ (setq ol (cdr ol)))
+ (car (nreverse ret))))
+
+(defmethod srecode-overlaid-text ((olaid srecode-overlaid) &optional set-to)
+ "Return the text under OLAID.
+If SET-TO is a string, then replace the text of OLAID wit SET-TO."
+ (let* ((ol (oref olaid overlay))
+ (start (overlay-start ol)))
+ (if (not (stringp set-to))
+ ;; Just return it.
+ (buffer-substring-no-properties start (overlay-end ol))
+ ;; Replace it.
+ (save-excursion
+ (delete-region start (overlay-end ol))
+ (goto-char start)
+ (insert set-to)
+ (move-overlay ol start (+ start (length set-to))))
+ nil)))
+
+;;; INSERTED REGION
+;;
+;; Managing point-exit, and flushing fields.
+
+(defclass srecode-template-inserted-region (srecode-overlaid)
+ ((fields :documentation
+ "A list of field overlays in this region.")
+ (active-region :allocation :class
+ :initform nil
+ :documentation
+ "The template region currently being handled.")
+ )
+ "Manage a buffer region in which fields exist.")
+
+(defmethod initialize-instance ((ir srecode-template-inserted-region)
+ &rest args)
+ "Initialize IR, capturing the active fields, and creating the overlay."
+ ;; Fill in the fields
+ (oset ir fields srecode-field-archive)
+ (setq srecode-field-archive nil)
+
+ ;; Initailize myself first.
+ (call-next-method)
+ )
+
+(defmethod srecode-overlaid-activate ((ir srecode-template-inserted-region))
+ "Activate the template area for IR."
+ ;; Activate all our fields
+
+ (dolist (F (oref ir fields))
+ (srecode-overlaid-activate F))
+
+ ;; Activate our overlay.
+ (call-next-method)
+
+ ;; Position the cursor at the first field
+ (let ((first (car (oref ir fields))))
+ (goto-char (overlay-start (oref first overlay))))
+
+ ;; Set ourselves up as 'active'
+ (oset ir active-region ir)
+
+ ;; Setup the post command hook.
+ (add-hook 'post-command-hook 'srecode-field-post-command t t)
+ )
+
+(defmethod srecode-delete ((ir srecode-template-inserted-region))
+ "Call into our base, but also clear out the fields."
+ ;; Clear us out of the baseclass.
+ (oset ir active-region nil)
+ ;; Clear our fields.
+ (mapc 'srecode-delete (oref ir fields))
+ ;; Call to our base
+ (call-next-method)
+ ;; Clear our hook.
+ (remove-hook 'post-command-hook 'srecode-field-post-command t)
+ )
+
+(defsubst srecode-active-template-region ()
+ "Return the active region for template fields."
+ (oref srecode-template-inserted-region active-region))
+
+(defun srecode-field-post-command ()
+ "Srecode field handler in the post command hook."
+ (let ((ar (srecode-active-template-region))
+ )
+ (if (not ar)
+ ;; Find a bug and fix it.
+ (remove-hook 'post-command-hook 'srecode-field-post-command t)
+ (if (srecode-point-in-region-p ar)
+ nil ;; Keep going
+ ;; We moved out of the temlate. Cancel the edits.
+ (srecode-delete ar)))
+ ))
+
+;;; FIELDS
+
+(defclass srecode-field (srecode-overlaid)
+ ((tail :documentation
+ "Overlay used on character just after this field.
+Used to provide useful keybindings there.")
+ (name :initarg :name
+ :documentation
+ "The name of this field.
+Usually initialized from the dictionary entry name that
+the users needs to edit.")
+ (prompt :initarg :prompt
+ :documentation
+ "A prompt string to use if this were in the minibuffer.
+Display when the cursor enters this field.")
+ (read-fcn :initarg :read-fcn
+ :documentation
+ "A function that would be used to read a string.
+Try to use this to provide useful completion when available.")
+ )
+ "Representation of one field.")
+
+(defvar srecode-field-keymap
+ (let ((km (make-sparse-keymap)))
+ (define-key km "\C-i" 'srecode-field-next)
+ (define-key km "\M-\C-i" 'srecode-field-prev)
+ (define-key km "\C-e" 'srecode-field-end)
+ (define-key km "\C-a" 'srecode-field-start)
+ (define-key km "\M-m" 'srecode-field-start)
+ (define-key km "\C-c\C-c" 'srecode-field-exit-ask)
+ km)
+ "Keymap applied to field overlays.")
+
+(defmethod initialize-instance ((field srecode-field) &optional args)
+ "Initialize FIELD, being sure it archived."
+ (add-to-list 'srecode-field-archive field t)
+ (call-next-method)
+ )
+
+(defmethod srecode-overlaid-activate ((field srecode-field))
+ "Activate the FIELD area."
+ (call-next-method)
+
+ (let* ((ol (oref field overlay))
+ (end nil)
+ (tail nil))
+ (overlay-put ol 'face 'srecode-field-face)
+ (overlay-put ol 'keymap srecode-field-keymap)
+ (overlay-put ol 'modification-hooks '(srecode-field-mod-hook))
+ (overlay-put ol 'insert-behind-hooks '(srecode-field-behind-hook))
+ (overlay-put ol 'insert-in-front-hooks '(srecode-field-mod-hook))
+
+ (setq end (overlay-end ol))
+ (setq tail (make-overlay end (+ end 1) (current-buffer)))
+
+ (overlay-put tail 'srecode field)
+ (overlay-put tail 'keymap srecode-field-keymap)
+ (overlay-put tail 'face 'srecode-field-face)
+ (oset field tail tail)
+ )
+ )
+
+(defmethod srecode-delete ((olaid srecode-field))
+ "Delete our secondary overlay."
+ ;; Remove our spare overlay
+ (delete-overlay (oref olaid tail))
+ (slot-makeunbound olaid 'tail)
+ ;; Do our baseclass work.
+ (call-next-method)
+ )
+
+(defvar srecode-field-replication-max-size 100
+ "Maximum size of a field before cancelling replication.")
+
+(defun srecode-field-mod-hook (ol after start end &optional pre-len)
+ "Modification hook for the field overlay.
+OL is the overlay.
+AFTER is non-nil if it is called after the change.
+START and END are the bounds of the change.
+PRE-LEN is used in the after mode for the length of the changed text."
+ (when (and after (not undo-in-progress))
+ (let* ((field (overlay-get ol 'srecode))
+ (inhibit-point-motion-hooks t)
+ (inhibit-modification-hooks t)
+ )
+ ;; Sometimes a field is deleted, but we might still get a stray
+ ;; event. Lets just ignore those events.
+ (when (slot-boundp field 'overlay)
+ ;; First, fixup the two overlays, in case they got confused.
+ (let ((main (oref field overlay))
+ (tail (oref field tail)))
+ (move-overlay main
+ (overlay-start main)
+ (1- (overlay-end tail)))
+ (move-overlay tail
+ (1- (overlay-end tail))
+ (overlay-end tail)))
+ ;; Now capture text from the main overlay, and propagate it.
+ (let* ((new-text (srecode-overlaid-text field))
+ (region (srecode-active-template-region))
+ (allfields (when region (oref region fields)))
+ (name (oref field name)))
+ (dolist (F allfields)
+ (when (and (not (eq F field))
+ (string= name (oref F name)))
+ (if (> (length new-text) srecode-field-replication-max-size)
+ (message "Field size too large for replication.")
+ ;; If we find other fields with the same name, then keep
+ ;; then all together. Disable change hooks to make sure
+ ;; we don't get a recursive edit.
+ (srecode-overlaid-text F new-text)
+ ))))
+ ))))
+
+(defun srecode-field-behind-hook (ol after start end &optional pre-len)
+ "Modification hook for the field overlay.
+OL is the overlay.
+AFTER is non-nil if it is called after the change.
+START and END are the bounds of the change.
+PRE-LEN is used in the after mode for the length of the changed text."
+ (when after
+ (let* ((field (overlay-get ol 'srecode))
+ )
+ (move-overlay ol (overlay-start ol) end)
+ (srecode-field-mod-hook ol after start end pre-len))
+ ))
+
+(defmethod srecode-field-goto ((field srecode-field))
+ "Goto the FIELD."
+ (goto-char (overlay-start (oref field overlay))))
+
+(defun srecode-field-next ()
+ "Move to the next field."
+ (interactive)
+ (let* ((f (srecode-overlaid-at-point 'srecode-field))
+ (tr (srecode-overlaid-at-point 'srecode-template-inserted-region))
+ )
+ (when (not f) (error "Not in a field"))
+ (when (not tr) (error "Not in a template region"))
+
+ (let ((fields (oref tr fields)))
+ (while fields
+ ;; Loop over fields till we match. Then move to the next one.
+ (when (eq f (car fields))
+ (if (cdr fields)
+ (srecode-field-goto (car (cdr fields)))
+ (srecode-field-goto (car (oref tr fields))))
+ (setq fields nil)
+ )
+ (setq fields (cdr fields))))
+ ))
+
+(defun srecode-field-prev ()
+ "Move to the prev field."
+ (interactive)
+ (let* ((f (srecode-overlaid-at-point 'srecode-field))
+ (tr (srecode-overlaid-at-point 'srecode-template-inserted-region))
+ )
+ (when (not f) (error "Not in a field"))
+ (when (not tr) (error "Not in a template region"))
+
+ (let ((fields (reverse (oref tr fields))))
+ (while fields
+ ;; Loop over fields till we match. Then move to the next one.
+ (when (eq f (car fields))
+ (if (cdr fields)
+ (srecode-field-goto (car (cdr fields)))
+ (srecode-field-goto (car (oref tr fields))))
+ (setq fields nil)
+ )
+ (setq fields (cdr fields))))
+ ))
+
+(defun srecode-field-end ()
+ "Move to the end of this field."
+ (interactive)
+ (let* ((f (srecode-overlaid-at-point 'srecode-field)))
+ (goto-char (overlay-end (oref f overlay)))))
+
+(defun srecode-field-start ()
+ "Move to the end of this field."
+ (interactive)
+ (let* ((f (srecode-overlaid-at-point 'srecode-field)))
+ (goto-char (overlay-start (oref f overlay)))))
+
+(defun srecode-field-exit-ask ()
+ "Ask if the user wants to exit field-editing mini-mode."
+ (interactive)
+ (when (y-or-n-p "Exit field-editing mode? ")
+ (srecode-delete (srecode-active-template-region))))
+
+
+(provide 'srecode/fields)
+
+;;; srecode/fields.el ends here
Index: cedet/srecode/filters.el
===================================================================
RCS file: cedet/srecode/filters.el
diff -N cedet/srecode/filters.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/srecode/filters.el 28 Sep 2009 15:15:11 -0000 1.2
@@ -0,0 +1,56 @@
+;;; srecode/filters.el --- Filters for use in template variables.
+
+;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Various useful srecoder template functions.
+
+;;; Code:
+
+(require 'newcomment)
+(require 'srecode/table)
+(require 'srecode/insert)
+
+(defun srecode-comment-prefix (str)
+ "Prefix each line of STR with the comment prefix characters."
+ (let* ((dict srecode-inserter-variable-current-dictionary)
+ ;; Derive the comment characters to put in front of each line.
+ (cs (or (and dict
+ (srecode-dictionary-lookup-name dict "comment_prefix"))
+ (and comment-multi-line comment-continue)
+ (and (not comment-multi-line) comment-start)))
+ (strs (split-string str "\n"))
+ (newstr "")
+ )
+ (while strs
+ (cond ((and (not comment-multi-line) (string= (car strs) ""))
+ ; (setq newstr (concat newstr "\n")))
+ )
+ (t
+ (setq newstr (concat newstr cs " " (car strs)))))
+ (setq strs (cdr strs))
+ (when strs (setq newstr (concat newstr "\n"))))
+ newstr))
+
+(provide 'srecode/filters)
+
+;;; srecode/filters.el ends here
+
Index: cedet/srecode/find.el
===================================================================
RCS file: cedet/srecode/find.el
diff -N cedet/srecode/find.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/srecode/find.el 28 Sep 2009 15:15:11 -0000 1.2
@@ -0,0 +1,261 @@
+;;;; srecode/find.el --- Tools for finding templates in the database.
+
+;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Various routines that search through various template tables
+;; in search of the right template.
+
+(require 'srecode/ctxt)
+(require 'srecode/table)
+(require 'srecode/map)
+
+(declare-function srecode-compile-file "srecode/compile")
+
+;;; Code:
+
+(defun srecode-table (&optional mode)
+ "Return the currently active Semantic Recoder table for this buffer.
+Optional argument MODE specifies the mode table to use."
+ (let* ((modeq (or mode major-mode))
+ (table (srecode-get-mode-table modeq)))
+
+ ;; If there isn't one, keep searching backwards for a table.
+ (while (and (not table) (setq modeq (get-mode-local-parent modeq)))
+ (setq table (srecode-get-mode-table modeq)))
+
+ ;; Last ditch effort.
+ (when (not table)
+ (setq table (srecode-get-mode-table 'default)))
+
+ table))
+
+;;; TRACKER
+;;
+;; Template file tracker for between sessions.
+;;
+(defun srecode-load-tables-for-mode (mmode &optional appname)
+ "Load all the template files for MMODE.
+Templates are found in the SRecode Template Map.
+See `srecode-get-maps' for more.
+APPNAME is the name of an application. In this case,
+all template files for that application will be loaded."
+ (require 'srecode/compile)
+ (let ((files
+ (if appname
+ (apply 'append
+ (mapcar
+ (lambda (map)
+ (srecode-map-entries-for-app-and-mode map appname mmode))
+ (srecode-get-maps)))
+ (apply 'append
+ (mapcar
+ (lambda (map)
+ (srecode-map-entries-for-mode map mmode))
+ (srecode-get-maps)))))
+ )
+ ;; Don't recurse if we are already the 'default state.
+ (when (not (eq mmode 'default))
+ ;; Are we a derived mode? If so, get the parent mode's
+ ;; templates loaded too.
+ (if (get-mode-local-parent mmode)
+ (srecode-load-tables-for-mode (get-mode-local-parent mmode)
+ appname)
+ ;; No parent mode, all templates depend on the defaults being
+ ;; loaded in, so get that in instead.
+ (srecode-load-tables-for-mode 'default appname)))
+
+ ;; Load in templates for our major mode.
+ (dolist (f files)
+ (let ((mt (srecode-get-mode-table mmode))
+ )
+ (when (or (not mt) (not (srecode-mode-table-find mt (car f))))
+ (srecode-compile-file (car f)))
+ ))
+ ))
+
+;;; SEARCH
+;;
+;; Find a given template based on name, and features of the current
+;; buffer.
+(defmethod srecode-template-get-table ((tab srecode-template-table)
+ template-name &optional
+ context application)
+ "Find in the template in table TAB, the template with TEMPLATE-NAME.
+Optional argument CONTEXT specifies that the template should part
+of a particular context.
+The APPLICATION argument is unused."
+ (if context
+ ;; If a context is specified, then look it up there.
+ (let ((ctxth (gethash context (oref tab contexthash))))
+ (when ctxth
+ (gethash template-name ctxth)))
+ ;; No context, perhaps a merged name?
+ (gethash template-name (oref tab namehash))))
+
+(defmethod srecode-template-get-table ((tab srecode-mode-table)
+ template-name &optional
+ context application)
+ "Find in the template in mode table TAB, the template with TEMPLATE-NAME.
+Optional argument CONTEXT specifies a context a particular template
+would belong to.
+Optional argument APPLICATION restricts searches to only template tables
+belonging to a specific application. If APPLICATION is nil, then only
+tables that do not belong to an application will be searched."
+ (let* ((mt tab)
+ (tabs (oref mt :tables))
+ (ans nil))
+ (while (and (not ans) tabs)
+ (let ((app (oref (car tabs) :application)))
+ (when (or (and (not application) (null app))
+ (and application (eq app application)))
+ (setq ans (srecode-template-get-table (car tabs) template-name
+ context)))
+ (setq tabs (cdr tabs))))
+ (or ans
+ ;; Recurse to the default.
+ (when (not (equal (oref tab :major-mode) 'default))
+ (srecode-template-get-table (srecode-get-mode-table 'default)
+ template-name context application)))))
+
+;;
+;; Find a given template based on a key binding.
+;;
+(defmethod srecode-template-get-table-for-binding
+ ((tab srecode-template-table) binding &optional context)
+ "Find in the template name in table TAB, the template with BINDING.
+Optional argument CONTEXT specifies that the template should part
+of a particular context."
+ (let* ((keyout nil)
+ (hashfcn (lambda (key value)
+ (when (and (slot-boundp value 'binding)
+ (oref value binding)
+ (= (aref (oref value binding) 0) binding))
+ (setq keyout key))))
+ (contextstr (cond ((listp context)
+ (car-safe context))
+ ((stringp context)
+ context)
+ (t nil)))
+ )
+ (if context
+ (let ((ctxth (gethash contextstr (oref tab contexthash))))
+ (when ctxth
+ ;; If a context is specified, then look it up there.
+ (maphash hashfcn ctxth)
+ ;; Context hashes EXCLUDE the context prefix which
+ ;; we need to include, so concat it here
+ (when keyout
+ (setq keyout (concat contextstr ":" keyout)))
+ )))
+ (when (not keyout)
+ ;; No context, or binding in context. Try full hash.
+ (maphash hashfcn (oref tab namehash)))
+ keyout))
+
+(defmethod srecode-template-get-table-for-binding
+ ((tab srecode-mode-table) binding &optional context application)
+ "Find in the template name in mode table TAB, the template with BINDING.
+Optional argument CONTEXT specifies a context a particular template
+would belong to.
+Optional argument APPLICATION restricts searches to only template tables
+belonging to a specific application. If APPLICATION is nil, then only
+tables that do not belong to an application will be searched."
+ (let* ((mt tab)
+ (tabs (oref mt :tables))
+ (ans nil))
+ (while (and (not ans) tabs)
+ (let ((app (oref (car tabs) :application)))
+ (when (or (and (not application) (null app))
+ (and application (eq app application)))
+ (setq ans (srecode-template-get-table-for-binding
+ (car tabs) binding context)))
+ (setq tabs (cdr tabs))))
+ (or ans
+ ;; Recurse to the default.
+ (when (not (equal (oref tab :major-mode) 'default))
+ (srecode-template-get-table-for-binding
+ (srecode-get-mode-table 'default) binding context)))))
+;;; Interactive
+;;
+;; Interactive queries into the template data.
+;;
+(defvar srecode-read-template-name-history nil
+ "History for completing reads for template names.")
+
+(defun srecode-all-template-hash (&optional mode hash)
+ "Create a hash table of all the currently available templates.
+Optional argument MODE is the major mode to look for.
+Optional argument HASH is the hash table to fill in."
+ (let* ((mhash (or hash (make-hash-table :test 'equal)))
+ (mmode (or mode major-mode))
+ (mp (get-mode-local-parent mmode))
+ )
+ ;; Get the parent hash table filled into our current hash.
+ (when (not (eq mode 'default))
+ (if mp
+ (srecode-all-template-hash mp mhash)
+ (srecode-all-template-hash 'default mhash)))
+ ;; Load up the hash table for our current mode.
+ (let* ((mt (srecode-get-mode-table mmode))
+ (tabs (when mt (oref mt :tables)))
+ )
+ (while tabs
+ ;; Exclude templates for a perticular application.
+ (when (not (oref (car tabs) :application))
+ (maphash (lambda (key temp)
+ (puthash key temp mhash)
+ )
+ (oref (car tabs) namehash)))
+ (setq tabs (cdr tabs)))
+ mhash)))
+
+(defun srecode-calculate-default-template-string (hash)
+ "Calculate the name of the template to use as a DEFAULT.
+Templates are read from HASH.
+Context into which the template is inserted is calculated
+with `srecode-calculate-context'."
+ (let* ((ctxt (srecode-calculate-context))
+ (ans (concat (nth 0 ctxt) ":" (nth 1 ctxt))))
+ (if (gethash ans hash)
+ ans
+ ;; No hash at the specifics, at least offer
+ ;; the prefix for the completing read
+ (concat (nth 0 ctxt) ":"))))
+
+(defun srecode-read-template-name (prompt &optional initial hist default)
+ "Completing read for Semantic Recoder template names.
+PROMPT is used to query for the name of the template desired.
+INITIAL is the initial string to use.
+HIST is a history variable to use.
+DEFAULT is what to use if the user presses RET."
+ (srecode-load-tables-for-mode major-mode)
+ (let* ((hash (srecode-all-template-hash))
+ (def (or initial
+ (srecode-calculate-default-template-string hash))))
+ (completing-read prompt hash
+ nil t def
+ (or hist
+ 'srecode-read-template-name-history))))
+
+(provide 'srecode/find)
+
+;;; srecode/find.el ends here
Index: cedet/srecode/getset.el
===================================================================
RCS file: cedet/srecode/getset.el
diff -N cedet/srecode/getset.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/srecode/getset.el 28 Sep 2009 15:15:11 -0000 1.2
@@ -0,0 +1,366 @@
+;;; srecode/getset.el --- Package for inserting new get/set methods.
+
+;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; SRecoder application for inserting new get/set methods into a class.
+
+(require 'semantic)
+(require 'semantic/analyze)
+(require 'semantic/find)
+(require 'srecode/insert)
+(require 'srecode/dictionary)
+
+;;; Code:
+(defvar srecode-insert-getset-fully-automatic-flag nil
+ "Non-nil means accept choices srecode comes up with without asking.")
+
+;;;###autoload
+(defun srecode-insert-getset (&optional class-in field-in)
+ "Insert get/set methods for the current class.
+CLASS-IN is the semantic tag of the class to update.
+FIELD-IN is the semantic tag, or string name, of the field to add.
+If you do not specify CLASS-IN or FIELD-IN then a class and field
+will be derived."
+ (interactive)
+
+ (srecode-load-tables-for-mode major-mode)
+ (srecode-load-tables-for-mode major-mode 'getset)
+
+ (if (not (srecode-table))
+ (error "No template table found for mode %s" major-mode))
+
+ (if (not (srecode-template-get-table (srecode-table)
+ "getset-in-class"
+ "declaration"
+ 'getset))
+ (error "No templates for inserting get/set"))
+
+ ;; Step 1: Try to derive the tag for the class we will use
+ (let* ((class (or class-in (srecode-auto-choose-class (point))))
+ (tagstart (semantic-tag-start class))
+ (inclass (eq (semantic-current-tag-of-class 'type) class))
+ (field nil)
+ )
+
+ (when (not class)
+ (error "Move point to a class and try again"))
+
+ ;; Step 2: Select a name for the field we will use.
+ (when field-in
+ (setq field field-in))
+
+ (when (and inclass (not field))
+ (setq field (srecode-auto-choose-field (point))))
+
+ (when (not field)
+ (setq field (srecode-query-for-field class)))
+
+ ;; Step 3: Insert a new field if needed
+ (when (stringp field)
+
+ (goto-char (point))
+ (srecode-position-new-field class inclass)
+
+ (let* ((dict (srecode-create-dictionary))
+ (temp (srecode-template-get-table (srecode-table)
+ "getset-field"
+ "declaration"
+ 'getset))
+ )
+ (when (not temp)
+ (error "Getset templates for %s not loaded!" major-mode))
+ (srecode-resolve-arguments temp dict)
+ (srecode-dictionary-set-value dict "NAME" field)
+ (when srecode-insert-getset-fully-automatic-flag
+ (srecode-dictionary-set-value dict "TYPE" "int"))
+ (srecode-insert-fcn temp dict)
+
+ (semantic-fetch-tags)
+ (save-excursion
+ (goto-char tagstart)
+ ;; Refresh our class tag.
+ (setq class (srecode-auto-choose-class (point)))
+ )
+
+ (let ((tmptag (semantic-deep-find-tags-by-name-regexp
+ field (current-buffer))))
+ (setq tmptag (semantic-find-tags-by-class 'variable tmptag))
+
+ (if tmptag
+ (setq field (car tmptag))
+ (error "Could not find new field %s" field)))
+ )
+
+ ;; Step 3.5: Insert an initializer if needed.
+ ;; ...
+
+
+ ;; Set up for the rest.
+ )
+
+ (if (not (semantic-tag-p field))
+ (error "Must specify field for get/set. (parts may not be impl'd
yet.)"))
+
+ ;; Set 4: Position for insertion of methods
+ (srecode-position-new-methods class field)
+
+ ;; Step 5: Insert the get/set methods
+ (if (not (eq (semantic-current-tag) class))
+ ;; We are positioned on top of something else.
+ ;; insert a /n
+ (insert "\n"))
+
+ (let* ((dict (srecode-create-dictionary))
+ (srecode-semantic-selected-tag field)
+ (temp (srecode-template-get-table (srecode-table)
+ "getset-in-class"
+ "declaration"
+ 'getset))
+ )
+ (if (not temp)
+ (error "Getset templates for %s not loaded!" major-mode))
+ (srecode-resolve-arguments temp dict)
+ (srecode-dictionary-set-value dict "GROUPNAME"
+ (concat (semantic-tag-name field)
+ " Accessors"))
+ (srecode-dictionary-set-value dict "NICENAME"
+ (srecode-strip-fieldname
+ (semantic-tag-name field)))
+ (srecode-insert-fcn temp dict)
+ )))
+
+(defun srecode-strip-fieldname (name)
+ "Strip the fieldname NAME of polish notation things."
+ (cond ((string-match "[a-z]\\([A-Z]\\w+\\)" name)
+ (substring name (match-beginning 1)))
+ ;; Add more rules here.
+ (t
+ name)))
+
+(defun srecode-position-new-methods (class field)
+ "Position the cursor in CLASS where new getset methods should go.
+FIELD is the field for the get sets.
+INCLASS specifies if the cursor is already in CLASS or not."
+ (semantic-go-to-tag field)
+
+ (let ((prev (semantic-find-tag-by-overlay-prev))
+ (next (semantic-find-tag-by-overlay-next))
+ (setname nil)
+ (aftertag nil)
+ )
+ (cond
+ ((and prev (semantic-tag-of-class-p prev 'variable))
+ (setq setname
+ (concat "set"
+ (srecode-strip-fieldname (semantic-tag-name prev))))
+ )
+ ((and next (semantic-tag-of-class-p next 'variable))
+ (setq setname
+ (concat "set"
+ (srecode-strip-fieldname (semantic-tag-name prev)))))
+ (t nil))
+
+ (setq aftertag (semantic-find-first-tag-by-name
+ setname (semantic-tag-type-members class)))
+
+ (when (not aftertag)
+ (setq aftertag (car-safe
+ (semantic--find-tags-by-macro
+ (semantic-tag-get-attribute (car tags) :destructor-flag)
+ (semantic-tag-type-members class))))
+ ;; Make sure the tag is public
+ (when (not (eq (semantic-tag-protection aftertag class) 'public))
+ (setq aftertag nil))
+ )
+
+ (if (not aftertag)
+ (setq aftertag (car-safe
+ (semantic--find-tags-by-macro
+ (semantic-tag-get-attribute (car tags)
:constructor-flag)
+ (semantic-tag-type-members class))))
+ ;; Make sure the tag is public
+ (when (not (eq (semantic-tag-protection aftertag class) 'public))
+ (setq aftertag nil))
+ )
+
+ (when (not aftertag)
+ (setq aftertag (semantic-find-first-tag-by-name
+ "public" (semantic-tag-type-members class))))
+
+ (when (not aftertag)
+ (setq aftertag (car (semantic-tag-type-members class))))
+
+ (if aftertag
+ (let ((te (semantic-tag-end aftertag)))
+ (when (not te)
+ (message "Unknown location for tag-end in %s:" (semantic-tag-name
aftertag)))
+ (goto-char te)
+ ;; If there is a comment immediatly after aftertag, skip over it.
+ (when (looking-at (concat "\\s-*\n?\\s-*" semantic-lex-comment-regex))
+ (let ((pos (point))
+ (rnext (semantic-find-tag-by-overlay-next (point))))
+ (forward-comment 1)
+ ;; Make sure the comment we skipped didn't say anything about
+ ;; the rnext tag.
+ (when (and rnext
+ (re-search-backward
+ (regexp-quote (semantic-tag-name rnext)) pos t))
+ ;; It did mention rnext, so go back to our starting position.
+ (goto-char pos)
+ )
+ ))
+ )
+
+ ;; At the very beginning of the class.
+ (goto-char (semantic-tag-end class))
+ (forward-sexp -1)
+ (forward-char 1)
+
+ )
+
+ (end-of-line)
+ (forward-char 1)
+ ))
+
+(defun srecode-position-new-field (class inclass)
+ "Select a position for a new field for CLASS.
+If INCLASS is non-nil, then the cursor is already in the class
+and should not be moved during point selection."
+
+ ;; If we aren't in the class, get the cursor there, pronto!
+ (when (not inclass)
+
+ (error "You must position the cursor where to insert the new field")
+
+ (let ((kids (semantic-find-tags-by-class
+ 'variable (semantic-tag-type-members class))))
+ (cond (kids
+ (semantic-go-to-tag (car kids) class))
+ (t
+ (semantic-go-to-tag class)))
+ )
+
+ (switch-to-buffer (current-buffer))
+
+ ;; Once the cursor is in our class, ask the user to position
+ ;; the cursor to keep going.
+ )
+
+ (if (or srecode-insert-getset-fully-automatic-flag
+ (y-or-n-p "Insert new field here? "))
+ nil
+ (error "You must position the cursor where to insert the new field first"))
+ )
+
+
+
+(defun srecode-auto-choose-field (point)
+ "Choose a field for the get/set methods.
+Base selection on the field related to POINT."
+ (save-excursion
+ (when point
+ (goto-char point))
+
+ (let ((field (semantic-current-tag-of-class 'variable)))
+
+ ;; If we get a field, make sure the user gets a chance to choose.
+ (when field
+ (if srecode-insert-getset-fully-automatic-flag
+ nil
+ (when (not (y-or-n-p
+ (format "Use field %s? " (semantic-tag-name field))))
+ (setq field nil))
+ ))
+ field)))
+
+(defun srecode-query-for-field (class)
+ "Query for a field in CLASS."
+ (let* ((kids (semantic-find-tags-by-class
+ 'variable (semantic-tag-type-members class)))
+ (sel (completing-read "Use Field: " kids))
+ )
+
+ (or (semantic-find-tags-by-name sel kids)
+ sel)
+ ))
+
+(defun srecode-auto-choose-class (point)
+ "Choose a class based on locatin of POINT."
+ (save-excursion
+ (when point
+ (goto-char point))
+
+ (let ((tag (semantic-current-tag-of-class 'type)))
+
+ (when (or (not tag)
+ (not (string= (semantic-tag-type tag) "class")))
+ ;; The current tag is not a class. Are we in a fcn
+ ;; that is a method?
+ (setq tag (semantic-current-tag-of-class 'function))
+
+ (when (and tag
+ (semantic-tag-function-parent tag))
+ (let ((p (semantic-tag-function-parent tag)))
+ ;; @TODO : Copied below out of semantic-analyze
+ ;; Turn into a routine.
+
+ (let* ((searchname (cond ((stringp p) p)
+ ((semantic-tag-p p)
+ (semantic-tag-name p))
+ ((and (listp p) (stringp (car p)))
+ (car p))))
+ (ptag (semantic-analyze-find-tag searchname
+ 'type nil)))
+ (when ptag (setq tag ptag ))
+ ))))
+
+ (when (or (not tag)
+ (not (semantic-tag-of-class-p tag 'type))
+ (not (string= (semantic-tag-type tag) "class")))
+ ;; We are not in a class that needs a get/set method.
+ ;; Analyze the current context, and derive a class name.
+ (let* ((ctxt (semantic-analyze-current-context))
+ (pfix nil)
+ (ans nil))
+ (when ctxt
+ (setq pfix (reverse (oref ctxt prefix)))
+ (while (and (not ans) pfix)
+ ;; Start at the end and back up to the first class.
+ (when (and (semantic-tag-p (car pfix))
+ (semantic-tag-of-class-p (car pfix) 'type)
+ (string= (semantic-tag-type (car pfix))
+ "class"))
+ (setq ans (car pfix)))
+ (setq pfix (cdr pfix))))
+ (setq tag ans)))
+
+ tag)))
+
+(provide 'srecode/getset)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: srecode/loaddefs
+;; generated-autoload-load-name: "srecode/getset"
+;; End:
+
+;;; srecode/getset.el ends here
Index: cedet/srecode/insert.el
===================================================================
RCS file: cedet/srecode/insert.el
diff -N cedet/srecode/insert.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/srecode/insert.el 28 Sep 2009 15:15:11 -0000 1.2
@@ -0,0 +1,983 @@
+;;; srecode/insert --- Insert srecode templates to an output stream.
+
+;;; Copyright (C) 2005, 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Define and implements specific inserter objects.
+;;
+;; Manage the insertion process for a template.
+;;
+
+(require 'srecode/compile)
+(require 'srecode/find)
+(require 'srecode/dictionary)
+
+(defvar srecode-template-inserter-point)
+(declare-function srecode-overlaid-activate "srecode/fields")
+(declare-function srecode-template-inserted-region "srecode/fields")
+
+;;; Code:
+
+(defcustom srecode-insert-ask-variable-method 'ask
+ "Determine how to ask for a dictionary value when inserting a template.
+Only the ASK style inserter will query the user for a value.
+Dictionary value references that ask begin with the ? character.
+Possible values are:
+ 'ask - Prompt in the minibuffer as the value is inserted.
+ 'field - Use the dictionary macro name as the inserted value,
+ and place a field there. Matched fields change together.
+
+NOTE: The field feature does not yet work with XEmacs."
+ :group 'srecode
+ :type '(choice (const :tag "Ask" ask)
+ (cons :tag "Field" field)))
+
+(defvar srecode-insert-with-fields-in-progress nil
+ "Non-nil means that we are actively inserting a template with fields.")
+
+;;; INSERTION COMMANDS
+;;
+;; User level commands for inserting stuff.
+(defvar srecode-insertion-start-context nil
+ "The context that was at point at the beginning of the template insertion.")
+
+(defun srecode-insert-again ()
+ "Insert the previously inserted template (by name) again."
+ (interactive)
+ (let ((prev (car srecode-read-template-name-history)))
+ (if prev
+ (srecode-insert prev)
+ (call-interactively 'srecode-insert))))
+
+;;;###autoload
+(defun srecode-insert (template-name &rest dict-entries)
+ "Inesrt the template TEMPLATE-NAME into the current buffer at point.
+DICT-ENTRIES are additional dictionary values to add."
+ (interactive (list (srecode-read-template-name "Template Name: ")))
+ (if (not (srecode-table))
+ (error "No template table found for mode %s" major-mode))
+ (let ((newdict (srecode-create-dictionary))
+ (temp (srecode-template-get-table (srecode-table) template-name))
+ (srecode-insertion-start-context (srecode-calculate-context))
+ )
+ (if (not temp)
+ (error "No Template named %s" template-name))
+ (while dict-entries
+ (srecode-dictionary-set-value newdict
+ (car dict-entries)
+ (car (cdr dict-entries)))
+ (setq dict-entries (cdr (cdr dict-entries))))
+ ;;(srecode-resolve-arguments temp newdict)
+ (srecode-insert-fcn temp newdict)
+ ;; Don't put code here. We need to return the end-mark
+ ;; for this insertion step.
+ ))
+
+(defun srecode-insert-fcn (template dictionary &optional stream skipresolver)
+ "Insert TEMPLATE using DICTIONARY into STREAM.
+Optional SKIPRESOLVER means to avoid refreshing the tag list,
+or resolving any template arguments. It is assumed the caller
+has set everything up already."
+ ;; Perform the insertion.
+ (let ((standard-output (or stream (current-buffer)))
+ (end-mark nil))
+ (unless skipresolver
+ ;; Make sure the semantic tags are up to date.
+ (semantic-fetch-tags)
+ ;; Resolve the arguments
+ (srecode-resolve-arguments template dictionary))
+ ;; Insert
+ (if (bufferp standard-output)
+ ;; If there is a buffer, turn off various hooks. This will cause
+ ;; the mod hooks to be buffered up during the insert, but
+ ;; prevent tools like font-lock from fontifying mid-template.
+ ;; Especialy important during insertion of complex comments that
+ ;; cause the new font-lock to comment-color stuff after the inserted
+ ;; comment.
+ ;;
+ ;; I'm not sure about the motion hooks. It seems like a good
+ ;; idea though.
+ ;;
+ ;; Borrowed these concepts out of font-lock.
+ ;;
+ ;; I tried `combine-after-change-calls', but it did not have
+ ;; the effect I wanted.
+ (let ((start (point)))
+ (let ((inhibit-point-motion-hooks t)
+ (inhibit-modification-hooks t)
+ )
+ (srecode--insert-into-buffer template dictionary)
+ )
+ ;; Now call those after change functions.
+ (run-hook-with-args 'after-change-functions
+ start (point) 0)
+ )
+ (srecode-insert-method template dictionary))
+ ;; Handle specialization of the POINT inserter.
+ (when (and (bufferp standard-output)
+ (slot-boundp 'srecode-template-inserter-point 'point)
+ )
+ (set-buffer standard-output)
+ (setq end-mark (point-marker))
+ (goto-char (oref srecode-template-inserter-point point)))
+ (oset-default 'srecode-template-inserter-point point eieio-unbound)
+
+ ;; Return the end-mark.
+ (or end-mark (point)))
+ )
+
+(defun srecode--insert-into-buffer (template dictionary)
+ "Insert a TEMPLATE with DICTIONARY into a buffer.
+Do not call this function yourself. Instead use:
+ `srecode-insert' - Inserts by name.
+ `srecode-insert-fcn' - Insert with objects.
+This function handles the case from one of the above functions when
+the template is inserted into a buffer. It looks
+at `srecode-insert-ask-variable-method' to decide if unbound dictionary
+entries ask questions or insert editable fields.
+
+Buffer based features related to change hooks is handled one level up."
+ ;; This line prevents the field archive from being let bound
+ ;; while the field insert tool is loaded via autoloads during
+ ;; the insert.
+ (when (eq srecode-insert-ask-variable-method 'field)
+ (require 'srecode/fields))
+
+ (let ((srecode-field-archive nil) ; Prevent field leaks during insert
+ (start (point)) ; Beginning of the region.
+ )
+ ;; This sub-let scopes the 'in-progress' piece so we know
+ ;; when to setup the end-template.
+ (let ((srecode-insert-with-fields-in-progress
+ (if (eq srecode-insert-ask-variable-method 'field) t nil))
+ )
+ (srecode-insert-method template dictionary)
+ )
+ ;; If we are not in-progress, and we insert fields, then
+ ;; create the end-template with fields editable area.
+ (when (and (not srecode-insert-with-fields-in-progress)
+ (eq srecode-insert-ask-variable-method 'field) ; Only if user
asked
+ srecode-field-archive ; Only if there were fields created
+ )
+ (let ((reg
+ ;; Create the field-driven editable area.
+ (srecode-template-inserted-region
+ "TEMPLATE" :start start :end (point))))
+ (srecode-overlaid-activate reg))
+ )
+ ;; We return with 'point being the end of the template insertion
+ ;; area. Return value is not important.
+ ))
+
+;;; TEMPLATE ARGUMENTS
+;;
+;; Some templates have arguments. Each argument is assocaited with
+;; a function that can resolve the inputs needed.
+(defun srecode-resolve-arguments (temp dict)
+ "Resolve all the arguments needed by the template TEMP.
+Apply anything learned to the dictionary DICT."
+ (srecode-resolve-argument-list (oref temp args) dict temp))
+
+(defun srecode-resolve-argument-list (args dict &optional temp)
+ "Resolve arguments in the argument list ARGS.
+ARGS is a list of symbols, such as :blank, or :file.
+Apply values to DICT.
+Optional argument TEMP is the template that is getting it's arguments
resolved."
+ (let ((fcn nil))
+ (while args
+ (setq fcn (intern-soft (concat "srecode-semantic-handle-"
+ (symbol-name (car args)))))
+ (if (not fcn)
+ (error "Error resolving template argument %S" (car args)))
+ (if temp
+ (condition-case nil
+ ;; Allow some to accept a 2nd argument optionally.
+ ;; They throw an error if not available, so try again.
+ (funcall fcn dict temp)
+ (wrong-number-of-arguments (funcall fcn dict)))
+ (funcall fcn dict))
+ (setq args (cdr args)))
+ ))
+
+;;; INSERTION STACK & METHOD
+;;
+;; Code managing the top-level insert method and the current
+;; insertion stack.
+;;
+(defmethod srecode-push ((st srecode-template))
+ "Push the srecoder template ST onto the active stack."
+ (oset st active (cons st (oref st active))))
+
+(defmethod srecode-pop :STATIC ((st srecode-template))
+ "Pop the srecoder template ST onto the active stack.
+ST can be a class, or an object."
+ (oset st active (cdr (oref st active))))
+
+(defmethod srecode-peek :STATIC ((st srecode-template))
+ "Fetch the topmost active template record. ST can be a class."
+ (car (oref st active)))
+
+(defmethod srecode-insert-method ((st srecode-template) dictionary)
+ "Insert the srecoder template ST."
+ ;; Merge any template entries into the input dictionary.
+ (when (slot-boundp st 'dictionary)
+ (srecode-dictionary-merge dictionary (oref st dictionary)))
+ ;; Do an insertion.
+ (unwind-protect
+ (let ((c (oref st code)))
+ (srecode-push st)
+ (srecode-insert-code-stream c dictionary))
+ ;; Poping the stack is protected
+ (srecode-pop st)))
+
+(defun srecode-insert-code-stream (code dictionary)
+ "Insert the CODE from a template into `standard-output'.
+Use DICTIONARY to resolve any macros."
+ (while code
+ (cond ((stringp (car code))
+ (princ (car code)))
+ (t
+ (srecode-insert-method (car code) dictionary)))
+ (setq code (cdr code))))
+
+;;; INSERTERS
+;;
+;; Specific srecode inserters.
+;; The base class is from srecode-compile.
+;;
+;; Each inserter handles various macro codes from the temlate.
+;; The `code' slot specifies a character used to identify which
+;; inserter is to be created.
+;;
+(defclass srecode-template-inserter-newline (srecode-template-inserter)
+ ((key :initform "\n"
+ :allocation :class
+ :documentation
+ "The character code used to identify inserters of this style.")
+ (hard :initform nil
+ :initarg :hard
+ :documentation
+ "Is this a hard newline (always inserted) or optional?
+Optional newlines don't insert themselves if they are on a blank line
+by themselves.")
+ )
+ "Insert a newline, and possibly do indenting.
+Specify the :indent argument to enable automatic indentation when newlines
+occur in your template.")
+
+(defmethod srecode-insert-method ((sti srecode-template-inserter-newline)
+ dictionary)
+ "Insert the STI inserter."
+ ;; To be safe, indent the previous line since the template will
+ ;; change what is there to indent
+ (let ((i (srecode-dictionary-lookup-name dictionary "INDENT"))
+ (inbuff (bufferp standard-output))
+ (doit t)
+ (pm (point-marker)))
+ (when (and inbuff (not (oref sti hard)))
+ ;; If this is not a hard newline, we need do the calculation
+ ;; and set "doit" to nil.
+ (beginning-of-line)
+ (save-restriction
+ (narrow-to-region (point) pm)
+ (when (looking-at "\\s-*$")
+ (setq doit nil)))
+ (goto-char pm)
+ )
+ ;; Do indentation reguardless of the newline.
+ (when (and (eq i t) inbuff)
+ (indent-according-to-mode)
+ (goto-char pm))
+
+ (when doit
+ (princ "\n")
+ ;; Indent after the newline, particularly for numeric indents.
+ (cond ((and (eq i t) (bufferp standard-output))
+ ;; WARNING - indent according to mode requires that standard-output
+ ;; is a buffer!
+ ;; @todo - how to indent in a string???
+ (setq pm (point-marker))
+ (indent-according-to-mode)
+ (goto-char pm))
+ ((numberp i)
+ (princ (make-string i " ")))
+ ((stringp i)
+ (princ i))))))
+
+(defmethod srecode-dump ((ins srecode-template-inserter-newline) indent)
+ "Dump the state of the SRecode template inserter INS."
+ (call-next-method)
+ (when (oref ins hard)
+ (princ " : hard")
+ ))
+
+(defclass srecode-template-inserter-blank (srecode-template-inserter)
+ ((key :initform "\r"
+ :allocation :class
+ :documentation
+ "The character represeinting this inserter style.
+Can't be blank, or it might be used by regular variable insertion.")
+ (where :initform 'begin
+ :initarg :where
+ :documentation
+ "This should be 'begin or 'end, indicating where to insrt a CR.
+When set to 'begin, it will insert a CR if we are not at 'bol'.
+When set to 'end it will insert a CR if we are not at 'eol'")
+ ;; @TODO - Add slot and control for the number of blank
+ ;; lines before and after point.
+ )
+ "Insert a newline before and after a template, and possibly do indenting.
+Specify the :blank argument to enable this inserter.")
+
+(defmethod srecode-insert-method ((sti srecode-template-inserter-blank)
+ dictionary)
+ "Make sure there is no text before or after point."
+ (let ((i (srecode-dictionary-lookup-name dictionary "INDENT"))
+ (inbuff (bufferp standard-output))
+ (pm (point-marker)))
+ (when (and inbuff
+ ;; Don't do this if we are not the active template.
+ (= (length (oref srecode-template active)) 1))
+
+ (when (and (eq i t) inbuff (not (eq (oref sti where) 'begin)))
+ (indent-according-to-mode)
+ (goto-char pm))
+
+ (cond ((and (eq (oref sti where) 'begin) (not (bolp)))
+ (princ "\n"))
+ ((eq (oref sti where) 'end)
+ ;; If there is whitespace after pnt, then clear it out.
+ (when (looking-at "\\s-*$")
+ (delete-region (point) (point-at-eol)))
+ (when (not (eolp))
+ (princ "\n")))
+ )
+ (setq pm (point-marker))
+ (when (and (eq i t) inbuff (not (eq (oref sti where) 'end)))
+ (indent-according-to-mode)
+ (goto-char pm))
+ )))
+
+(defclass srecode-template-inserter-comment (srecode-template-inserter)
+ ((key :initform ?!
+ :allocation :class
+ :documentation
+ "The character code used to identify inserters of this style.")
+ )
+ "Allow comments within template coding. This inserts nothing.")
+
+(defmethod srecode-inserter-prin-example :STATIC ((ins
srecode-template-inserter-comment)
+ escape-start escape-end)
+ "Insert an example using inserter INS.
+Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
+ (princ " ")
+ (princ escape-start)
+ (princ "! Miscellaneous text commenting in your template. ")
+ (princ escape-end)
+ (terpri)
+ )
+
+(defmethod srecode-insert-method ((sti srecode-template-inserter-comment)
+ dictionary)
+ "Don't insert anything for comment macros in STI."
+ nil)
+
+
+(defclass srecode-template-inserter-variable (srecode-template-inserter)
+ ((key :initform nil
+ :allocation :class
+ :documentation
+ "The character code used to identify inserters of this style."))
+ "Insert the value of a dictionary entry
+If there is no entry, insert nothing.")
+
+(defvar srecode-inserter-variable-current-dictionary nil
+ "The active dictionary when calling a variable filter.")
+
+(defmethod srecode-insert-variable-secondname-handler
+ ((sti srecode-template-inserter-variable) dictionary value secondname)
+ "For VALUE handle SECONDNAME behaviors for this variable inserter.
+Return the result as a string.
+By default, treat as a function name.
+If SECONDNAME is nil, return VALUE."
+ (if secondname
+ (let ((fcnpart (read secondname)))
+ (if (fboundp fcnpart)
+ (let ((srecode-inserter-variable-current-dictionary dictionary))
+ (funcall fcnpart value))
+ ;; Else, warn.
+ (error "Variable insertion second arg %s is not a function."
+ secondname)))
+ value))
+
+(defmethod srecode-insert-method ((sti srecode-template-inserter-variable)
+ dictionary)
+ "Insert the STI inserter."
+ ;; Convert the name into a name/fcn pair
+ (let* ((name (oref sti :object-name))
+ (fcnpart (oref sti :secondname))
+ (val (srecode-dictionary-lookup-name
+ dictionary name))
+ (do-princ t)
+ )
+ ;; Alert if a macro wasn't found.
+ (when (not val)
+ (message "Warning: macro %S was not found in the dictionary." name)
+ (setq val ""))
+ ;; If there was a functional part, call that function.
+ (cond ;; Strings
+ ((stringp val)
+ (setq val (srecode-insert-variable-secondname-handler
+ sti dictionary val fcnpart)))
+ ;; Compound data value
+ ((srecode-dictionary-compound-value-child-p val)
+ ;; Force FCN to be a symbol
+ (when fcnpart (setq fcnpart (read fcnpart)))
+ ;; Convert compound value to a string with the fcn.
+ (setq val (srecode-compound-toString val fcnpart dictionary))
+ ;; If the value returned is nil, then it may be a special
+ ;; field inserter that requires us to set do-princ to nil.
+ (when (not val)
+ (setq do-princ nil)
+ )
+ )
+ ;; Dictionaries... not allowed in this style
+ ((srecode-dictionary-child-p val)
+ (error "Macro %s cannot insert a dictionary. Use section macros
instead."
+ name))
+ ;; Other stuff... convert
+ (t
+ (error "Macro %s cannot insert arbitrary data." name)
+ ;;(if (and val (not (stringp val)))
+ ;; (setq val (format "%S" val))))
+ ))
+ ;; Output the dumb thing unless the type of thing specifically
+ ;; did the inserting forus.
+ (when do-princ
+ (princ val))))
+
+(defclass srecode-template-inserter-ask (srecode-template-inserter-variable)
+ ((key :initform ??
+ :allocation :class
+ :documentation
+ "The character code used to identify inserters of this style.")
+ (prompt :initarg :prompt
+ :initform nil
+ :documentation
+ "The prompt used to query for this dictionary value.")
+ (defaultfcn :initarg :defaultfcn
+ :initform nil
+ :documentation
+ "The function which can calculate a default value.")
+ (read-fcn :initarg :read-fcn
+ :initform 'read-string
+ :documentation
+ "The function used to read in the text for this prompt.")
+ )
+ "Insert the value of a dictionary entry
+If there is no entry, prompt the user for the value to use.
+The prompt text used is derived from the previous PROMPT command in the
+template file.")
+
+(defmethod srecode-inserter-apply-state ((ins srecode-template-inserter-ask)
STATE)
+ "For the template inserter INS, apply information from STATE.
+Loop over the prompts to see if we have a match."
+ (let ((prompts (oref STATE prompts))
+ )
+ (while prompts
+ (when (string= (semantic-tag-name (car prompts))
+ (oref ins :object-name))
+ (oset ins :prompt
+ (semantic-tag-get-attribute (car prompts) :text))
+ (oset ins :defaultfcn
+ (semantic-tag-get-attribute (car prompts) :default))
+ (oset ins :read-fcn
+ (or (semantic-tag-get-attribute (car prompts) :read)
+ 'read-string))
+ )
+ (setq prompts (cdr prompts)))
+ ))
+
+(defmethod srecode-insert-method ((sti srecode-template-inserter-ask)
+ dictionary)
+ "Insert the STI inserter."
+ (let ((val (srecode-dictionary-lookup-name
+ dictionary (oref sti :object-name))))
+ (if val
+ ;; Does some extra work. Oh well.
+ (call-next-method)
+
+ ;; How is our -ask value determined?
+ (if srecode-insert-with-fields-in-progress
+ ;; Setup editable fields.
+ (setq val (srecode-insert-method-field sti dictionary))
+ ;; Ask the question...
+ (setq val (srecode-insert-method-ask sti dictionary)))
+
+ ;; After asking, save in the dictionary so that
+ ;; the user can use the same name again later.
+ (srecode-dictionary-set-value
+ (srecode-root-dictionary dictionary)
+ (oref sti :object-name) val)
+
+ ;; Now that this value is safely stowed in the dictionary,
+ ;; we can do what regular inserters do.
+ (call-next-method))))
+
+(defmethod srecode-insert-ask-default ((sti srecode-template-inserter-ask)
+ dictionary)
+ "Derive the default value for an askable inserter STI.
+DICTIONARY is used to derive some values."
+ (let ((defaultfcn (oref sti :defaultfcn)))
+ (cond ((stringp defaultfcn)
+ defaultfcn)
+ ((functionp defaultfcn)
+ (funcall defaultfcn))
+ ((and (listp defaultfcn)
+ (eq (car defaultfcn) 'macro))
+ (srecode-dictionary-lookup-name
+ dictionary (cdr defaultfcn)))
+ ((null defaultfcn)
+ "")
+ (t
+ (error "Unknown default for prompt: %S"
+ defaultfcn)))))
+
+(defmethod srecode-insert-method-ask ((sti srecode-template-inserter-ask)
+ dictionary)
+ "Do the \"asking\" for the template inserter STI.
+Use DICTIONARY to resolve values."
+ (let* ((prompt (oref sti prompt))
+ (default (srecode-insert-ask-default sti dictionary))
+ (reader (oref sti :read-fcn))
+ (val nil)
+ )
+ (cond ((eq reader 'y-or-n-p)
+ (if (y-or-n-p (or prompt
+ (format "%s? "
+ (oref sti :object-name))))
+ (setq val default)
+ (setq val "")))
+ ((eq reader 'read-char)
+ (setq val (format
+ "%c"
+ (read-char (or prompt
+ (format "Char for %s: "
+ (oref sti :object-name))))))
+ )
+ (t
+ (save-excursion
+ (setq val (funcall reader
+ (or prompt
+ (format "Specify %s: "
+ (oref sti :object-name)))
+ default
+ )))))
+ ;; Return our derived value.
+ val)
+ )
+
+(defmethod srecode-insert-method-field ((sti srecode-template-inserter-ask)
+ dictionary)
+ "Create an editable field for the template inserter STI.
+Use DICTIONARY to resolve values."
+ (let* ((default (srecode-insert-ask-default sti dictionary))
+ (compound-value
+ (srecode-field-value (oref sti :object-name)
+ :firstinserter sti
+ :defaultvalue default))
+ )
+ ;; Return this special compound value as the thing to insert.
+ ;; This special compound value will repeat our asked question
+ ;; across multiple locations.
+ compound-value))
+
+(defmethod srecode-dump ((ins srecode-template-inserter-ask) indent)
+ "Dump the state of the SRecode template inserter INS."
+ (call-next-method)
+ (princ " : \"")
+ (princ (oref ins prompt))
+ (princ "\"")
+ )
+
+(defclass srecode-template-inserter-width (srecode-template-inserter-variable)
+ ((key :initform ?|
+ :allocation :class
+ :documentation
+ "The character code used to identify inserters of this style.")
+ )
+ "Inserts the value of a dictionary variable with a specific width.
+The second argument specifies the width, and a pad, seperated by a colon.
+thus a specification of `10:left' will insert the value of A
+to 10 characters, with spaces added to the left. Use `right' for adding
+spaces to the right.")
+
+(defmethod srecode-insert-variable-secondname-handler
+ ((sti srecode-template-inserter-width) dictionary value width)
+ "For VALUE handle WIDTH behaviors for this variable inserter.
+Return the result as a string.
+By default, treat as a function name."
+ (if width
+ ;; Trim or pad to new length
+ (let* ((split (split-string width ":"))
+ (width (string-to-number (nth 0 split)))
+ (second (nth 1 split))
+ (pad (cond ((or (null second) (string= "right" second))
+ 'right)
+ ((string= "left" second)
+ 'left)
+ (t
+ (error "Unknown pad type %s" second)))))
+ (if (>= (length value) width)
+ ;; Simple case - too long.
+ (substring value 0 width)
+ ;; We need to pad on one side or the other.
+ (let ((padchars (make-string (- width (length value)) ? )))
+ (if (eq pad 'left)
+ (concat padchars value)
+ (concat value padchars)))))
+ (error "Width not specified for variable/width inserter.")))
+
+(defmethod srecode-inserter-prin-example :STATIC ((ins
srecode-template-inserter-width)
+ escape-start escape-end)
+ "Insert an example using inserter INS.
+Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
+ (princ " ")
+ (princ escape-start)
+ (princ "|A:10:right")
+ (princ escape-end)
+ (terpri)
+ )
+
+(defvar srecode-template-inserter-point-override nil
+ "When non-nil, the point inserter will do this functin instead.")
+
+(defclass srecode-template-inserter-point (srecode-template-inserter)
+ ((key :initform ?^
+ :allocation :class
+ :documentation
+ "The character code used to identify inserters of this style.")
+ (point :type (or null marker)
+ :allocation :class
+ :documentation
+ "Record the value of (point) in this class slot.
+It is the responsibility of the inserter algorithm to clear this
+after a successful insertion."))
+ "Record the value of (point) when inserted.
+The cursor is placed at the ^ macro after insertion.
+Some inserter macros, such as `srecode-template-inserter-include-wrap'
+will place text at the ^ macro from the included macro.")
+
+(defmethod srecode-inserter-prin-example :STATIC ((ins
srecode-template-inserter-point)
+ escape-start escape-end)
+ "Insert an example using inserter INS.
+Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
+ (princ " ")
+ (princ escape-start)
+ (princ "^")
+ (princ escape-end)
+ (terpri)
+ )
+
+(defmethod srecode-insert-method ((sti srecode-template-inserter-point)
+ dictionary)
+ "Insert the STI inserter.
+Save point in the class allocated 'point' slot.
+If `srecode-template-inserter-point-override' then this generalized
+marker will do something else. See `srecode-template-inserter-include-wrap'
+as an example."
+ (if srecode-template-inserter-point-override
+ ;; Disable the old override while we do this.
+ (let ((over srecode-template-inserter-point-override)
+ (srecode-template-inserter-point-override nil))
+ (funcall over dictionary)
+ )
+ (oset sti point (point-marker))
+ ))
+
+(defclass srecode-template-inserter-subtemplate (srecode-template-inserter)
+ ()
+ "Wrap a section of a template under the control of a macro."
+ :abstract t)
+
+(defmethod srecode-inserter-prin-example :STATIC ((ins
srecode-template-inserter-subtemplate)
+ escape-start escape-end)
+ "Insert an example using inserter INS.
+Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
+ (call-next-method)
+ (princ " Template Text to control")
+ (terpri)
+ (princ " ")
+ (princ escape-start)
+ (princ "/VARNAME")
+ (princ escape-end)
+ (terpri)
+ )
+
+(defmethod srecode-insert-subtemplate ((sti
srecode-template-inserter-subtemplate)
+ dict slot)
+ "Insert a subtemplate for the inserter STI with dictionary DICT."
+ ;; make sure that only dictionaries are used.
+ (when (not (srecode-dictionary-child-p dict))
+ (error "Only section dictionaries allowed for %s"
+ (object-name-string sti)))
+ ;; Output the code from the sub-template.
+ (srecode-insert-method (slot-value sti slot) dict)
+ )
+
+(defmethod srecode-insert-method-helper ((sti
srecode-template-inserter-subtemplate)
+ dictionary slot)
+ "Do the work for inserting the STI inserter.
+Loops over the embedded CODE which was saved here during compilation.
+The template to insert is stored in SLOT."
+ (let ((dicts (srecode-dictionary-lookup-name
+ dictionary (oref sti :object-name))))
+ ;; If there is no section dictionary, then don't output anything
+ ;; from this section.
+ (while dicts
+ (srecode-insert-subtemplate sti (car dicts) slot)
+ (setq dicts (cdr dicts)))))
+
+(defmethod srecode-insert-method ((sti srecode-template-inserter-subtemplate)
+ dictionary)
+ "Insert the STI inserter.
+Calls back to `srecode-insert-method-helper' for this class."
+ (srecode-insert-method-helper sti dictionary 'template))
+
+
+(defclass srecode-template-inserter-section-start
(srecode-template-inserter-subtemplate)
+ ((key :initform ?#
+ :allocation :class
+ :documentation
+ "The character code used to identify inserters of this style.")
+ (template :initarg :template
+ :documentation
+ "A Template used to frame the codes from this inserter.")
+ )
+ "Apply values from a sub-dictionary to a template section.
+The dictionary saved at the named dictionary entry will be
+applied to the text between the section start and the
+`srecode-template-inserter-section-end' macro.")
+
+(defmethod srecode-parse-input ((ins srecode-template-inserter-section-start)
+ tag input STATE)
+ "For the section inserter INS, parse INPUT.
+Shorten input until the END token is found.
+Return the remains of INPUT."
+ (let* ((out (srecode-compile-split-code tag input STATE
+ (oref ins :object-name))))
+ (oset ins template (srecode-template
+ (object-name-string ins)
+ :context nil
+ :args nil
+ :code (cdr out)))
+ (car out)))
+
+(defmethod srecode-dump ((ins srecode-template-inserter-section-start) indent)
+ "Dump the state of the SRecode template inserter INS."
+ (call-next-method)
+ (princ "\n")
+ (srecode-dump-code-list (oref (oref ins template) code)
+ (concat indent " "))
+ )
+
+(defclass srecode-template-inserter-section-end (srecode-template-inserter)
+ ((key :initform ?/
+ :allocation :class
+ :documentation
+ "The character code used to identify inserters of this style.")
+ )
+ "All template segments between the secion-start and section-end
+are treated specially.")
+
+(defmethod srecode-insert-method ((sti srecode-template-inserter-section-end)
+ dictionary)
+ "Insert the STI inserter."
+ )
+
+(defmethod srecode-match-end ((ins srecode-template-inserter-section-end) name)
+
+ "For the template inserter INS, do I end a section called NAME?"
+ (string= name (oref ins :object-name)))
+
+(defclass srecode-template-inserter-include
(srecode-template-inserter-subtemplate)
+ ((key :initform ?>
+ :allocation :class
+ :documentation
+ "The character code used to identify inserters of this style.")
+ (includedtemplate
+ :initarg :includedtemplate
+ :documentation
+ "The template included for this inserter."))
+ "Include a different template into this one.
+The included template will have additional dictionary entries from the
subdictionary
+stored specified by this macro.")
+
+(defmethod srecode-inserter-prin-example :STATIC ((ins
srecode-template-inserter-include)
+ escape-start escape-end)
+ "Insert an example using inserter INS.
+Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
+ (princ " ")
+ (princ escape-start)
+ (princ ">DICTNAME:contextname:templatename")
+ (princ escape-end)
+ (terpri)
+ )
+
+(defmethod srecode-insert-include-lookup ((sti
srecode-template-inserter-include)
+ dictionary)
+ "For the template inserter STI, lookup the template to include.
+Finds the template with this macro function part and stores it in
+this template instance."
+ (let* ((templatenamepart (oref sti :secondname))
+ )
+ ;; If there was no template name, throw an error
+ (if (not templatenamepart)
+ (error "Include macro %s needs a template name." (oref sti
:object-name)))
+ ;; Find the template by name, and save it.
+ (if (or (not (slot-boundp sti 'includedtemplate))
+ (not (oref sti includedtemplate)))
+ (let ((tmpl (srecode-template-get-table (srecode-table)
+ templatenamepart))
+ (active (oref srecode-template active))
+ ctxt)
+ (when (not tmpl)
+ ;; If it isn't just available, scan back through
+ ;; the active template stack, searching for a matching
+ ;; context.
+ (while (and (not tmpl) active)
+ (setq ctxt (oref (car active) context))
+ (setq tmpl (srecode-template-get-table (srecode-table)
+ templatenamepart
+ ctxt))
+ (when (not tmpl)
+ (when (slot-boundp (car active) 'table)
+ (let ((app (oref (oref (car active) table) application)))
+ (when app
+ (setq tmpl (srecode-template-get-table
+ (srecode-table)
+ templatenamepart
+ ctxt app)))
+ )))
+ (setq active (cdr active)))
+ (when (not tmpl)
+ ;; If it wasn't in this context, look to see if it
+ ;; defines it's own context
+ (setq tmpl (srecode-template-get-table (srecode-table)
+ templatenamepart)))
+ )
+ (oset sti :includedtemplate tmpl)))
+
+ (if (not (oref sti includedtemplate))
+ ;; @todo - Call into a debugger to help find the template in question.
+ (error "No template \"%s\" found for include macro `%s'"
+ templatenamepart (oref sti :object-name)))
+ ))
+
+(defmethod srecode-insert-method ((sti srecode-template-inserter-include)
+ dictionary)
+ "Insert the STI inserter.
+Finds the template with this macro function part, and inserts it
+with the dictionaries found in the dictinary."
+ (srecode-insert-include-lookup sti dictionary)
+ ;; Insert the template.
+ ;; Our baseclass has a simple way to do this.
+ (if (srecode-dictionary-lookup-name dictionary (oref sti :object-name))
+ ;; If we have a value, then call the next method
+ (srecode-insert-method-helper sti dictionary 'includedtemplate)
+ ;; If we don't have a special dictitonary, then just insert with the
+ ;; current dictionary.
+ (srecode-insert-subtemplate sti dictionary 'includedtemplate))
+ )
+
+;;
+;; This template combines the include template and the sectional template.
+;; It will first insert the included template, then insert the embedded
+;; template wherever the $^$ in the included template was.
+;;
+;; Since it uses dual inheretance, it will magically get the end-matching
+;; behavior of #, with the including feature of >.
+;;
+(defclass srecode-template-inserter-include-wrap
(srecode-template-inserter-include srecode-template-inserter-section-start)
+ ((key :initform ?<
+ :allocation :class
+ :documentation
+ "The character code used to identify inserters of this style.")
+ )
+ "Include a different template into this one, and add text at the ^ macro.
+The included template will have additional dictionary entries from the
subdictionary
+stored specified by this macro. If the included macro includes a ^ macro,
+then the text between this macro and the end macro will be inserted at
+the ^ macro.")
+
+(defmethod srecode-inserter-prin-example :STATIC ((ins
srecode-template-inserter-include-wrap)
+ escape-start escape-end)
+ "Insert an example using inserter INS.
+Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
+ (princ " ")
+ (princ escape-start)
+ (princ "<DICTNAME:contextname:templatename")
+ (princ escape-end)
+ (terpri)
+ (princ " Template Text to insert at ^ macro")
+ (terpri)
+ (princ " ")
+ (princ escape-start)
+ (princ "/DICTNAME")
+ (princ escape-end)
+ (terpri)
+ )
+
+(defmethod srecode-insert-method ((sti srecode-template-inserter-include-wrap)
+ dictionary)
+ "Insert the template STI.
+This will first insert the include part via inheritance, then
+insert the section it wraps into the location in the included
+template where a ^ inserter occurs."
+ ;; Step 1: Look up the included inserter
+ (srecode-insert-include-lookup sti dictionary)
+ ;; Step 2: Temporarilly override the point inserter.
+ (let* ((vaguely-unique-name sti)
+ (srecode-template-inserter-point-override
+ (lambda (dict2)
+ (if (srecode-dictionary-lookup-name
+ dict2 (oref vaguely-unique-name :object-name))
+ ;; Insert our sectional part with looping.
+ (srecode-insert-method-helper
+ vaguely-unique-name dict2 'template)
+ ;; Insert our sectional part just once.
+ (srecode-insert-subtemplate vaguely-unique-name
+ dict2 'template))
+ )))
+ ;; Do a regular insertion for an include, but with our override in
+ ;; place.
+ (call-next-method)
+ ))
+
+(provide 'srecode/insert)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: srecode/loaddefs
+;; generated-autoload-load-name: "srecode/insert"
+;; End:
+
+;;; srecode/insert.el ends here
Index: cedet/srecode/java.el
===================================================================
RCS file: cedet/srecode/java.el
diff -N cedet/srecode/java.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/srecode/java.el 28 Sep 2009 15:15:11 -0000 1.2
@@ -0,0 +1,62 @@
+;;; srecode-java.el --- Srecode Java support
+
+;; Copyright (C) 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Special support for the Java language.
+
+;;; Code:
+
+(require 'srecode/dictionary)
+
+;;;###autoload
+(defun srecode-semantic-handle-:java (dict)
+ "Add macros into the dictionary DICT based on the current java file.
+Adds the following:
+FILENAME_AS_PACKAGE - file/dir converted into a java package name.
+FILENAME_AS_CLASS - file converted to a Java class name."
+ ;; A symbol representing
+ (let* ((fsym (file-name-nondirectory (buffer-file-name)))
+ (fnox (file-name-sans-extension fsym))
+ (dir (file-name-directory (buffer-file-name)))
+ (fpak fsym)
+ )
+ (while (string-match "\\.\\| " fpak)
+ (setq fpak (replace-match "_" t t fpak)))
+ (if (string-match "src/" dir)
+ (setq dir (substring dir (match-end 0)))
+ (setq dir (file-name-nondirectory (directory-file-name dir))))
+ (while (string-match "/" dir)
+ (setq dir (replace-match "_" t t dir)))
+ (srecode-dictionary-set-value dict "FILENAME_AS_PACKAGE"
+ (concat dir "." fpak))
+ (srecode-dictionary-set-value dict "FILENAME_AS_CLASS" fnox)
+ ))
+
+(provide 'srecode/java)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: srecode/loaddefs
+;; generated-autoload-load-name: "srecode/java"
+;; End:
+
+;;; srecode/java.el ends here
Index: cedet/srecode/map.el
===================================================================
RCS file: cedet/srecode/map.el
diff -N cedet/srecode/map.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/srecode/map.el 28 Sep 2009 15:15:11 -0000 1.2
@@ -0,0 +1,415 @@
+;;; srecode/map.el --- Manage a template file map
+
+;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Read template files, and build a map of where they can be found.
+;; Save the map to disk, and refer to it when bootstrapping a new
+;; Emacs session with srecode.
+
+(require 'semantic)
+(require 'eieio-base)
+(require 'srecode)
+
+;;; Code:
+
+;; The defcustom is given at the end of the file.
+(defvar srecode-map-load-path)
+
+(defun srecode-map-base-template-dir ()
+ "Find the base template directory for SRecode."
+ (let* ((lib (locate-library "srecode.el"))
+ (dir (file-name-directory lib)))
+ (expand-file-name "templates/" dir)
+ ))
+
+;;; Current MAP
+;;
+
+(defvar srecode-current-map nil
+ "The current map for global SRecode templtes.")
+
+(defcustom srecode-map-save-file (expand-file-name "~/.srecode/srecode-map")
+ "The save location for SRecode's map file.
+If the save file is nil, then the MAP is not saved between sessions."
+ :group 'srecode
+ :type 'file)
+
+(defclass srecode-map (eieio-persistent)
+ ((fileheaderline :initform ";; SRECODE TEMPLATE MAP")
+ (files :initarg :files
+ :initform nil
+ :type list
+ :documentation
+ "An alist of files and the major-mode that they cover.")
+ (apps :initarg :apps
+ :initform nil
+ :type list
+ :documentation
+ "An alist of applications.
+Each app keys to an alist of files and modes (as above.)")
+ )
+ "A map of srecode templates.")
+
+(defmethod srecode-map-entry-for-file ((map srecode-map) file)
+ "Return the entry in MAP for FILE."
+ (assoc file (oref map files)))
+
+(defmethod srecode-map-entries-for-mode ((map srecode-map) mode)
+ "Return the entries in MAP for major MODE."
+ (let ((ans nil))
+ (dolist (f (oref map files))
+ (when (mode-local-use-bindings-p mode (cdr f))
+ (setq ans (cons f ans))))
+ ans))
+
+(defmethod srecode-map-entry-for-app ((map srecode-map) app)
+ "Return the entry in MAP for APP'lication."
+ (assoc app (oref map apps))
+ )
+
+(defmethod srecode-map-entries-for-app-and-mode ((map srecode-map) app mode)
+ "Return the entries in MAP for major MODE."
+ (let ((ans nil)
+ (appentry (srecode-map-entry-for-app map app)))
+ (dolist (f (cdr appentry))
+ (when (eq (cdr f) mode)
+ (setq ans (cons f ans))))
+ ans))
+
+(defmethod srecode-map-entry-for-file-anywhere ((map srecode-map) file)
+ "Search in all entry points in MAP for FILE.
+Return a list ( APP . FILE-ASSOC ) where APP is nil
+in the global map."
+ (or
+ ;; Look in the global entry
+ (let ((globalentry (srecode-map-entry-for-file map file)))
+ (when globalentry
+ (cons nil globalentry)))
+ ;; Look in each app.
+ (let ((match nil))
+ (dolist (app (oref map apps))
+ (let ((appmatch (assoc file (cdr app))))
+ (when appmatch
+ (setq match (cons app appmatch)))))
+ match)
+ ;; Other?
+ ))
+
+(defmethod srecode-map-delete-file-entry ((map srecode-map) file)
+ "Update MAP to exclude FILE from the file list."
+ (let ((entry (srecode-map-entry-for-file map file)))
+ (when entry
+ (object-remove-from-list map 'files entry))))
+
+(defmethod srecode-map-update-file-entry ((map srecode-map) file mode)
+ "Update a MAP entry for FILE to be used with MODE.
+Return non-nil if the MAP was changed."
+ (let ((entry (srecode-map-entry-for-file map file))
+ (dirty t))
+ (cond
+ ;; It is already a match.. do nothing.
+ ((and entry (eq (cdr entry) mode))
+ (setq dirty nil))
+ ;; We have a non-matching entry. Change the cdr.
+ (entry
+ (setcdr entry mode))
+ ;; No entry, just add it to the list.
+ (t
+ (object-add-to-list map 'files (cons file mode))
+ ))
+ dirty))
+
+(defmethod srecode-map-delete-file-entry-from-app ((map srecode-map) file app)
+ "Delete from MAP the FILE entry within the APP'lication."
+ (let* ((appe (srecode-map-entry-for-app map app))
+ (fentry (assoc file (cdr appe))))
+ (setcdr appe (delete fentry (cdr appe))))
+ )
+
+(defmethod srecode-map-update-app-file-entry ((map srecode-map) file mode app)
+ "Update the MAP entry for FILE to be used with MODE within APP.
+Return non-nil if the map was changed."
+ (let* ((appentry (srecode-map-entry-for-app map app))
+ (appfileentry (assoc file (cdr appentry)))
+ (dirty t)
+ )
+ (cond
+ ;; Option 1 - We have this file in this application already
+ ;; with the correct mode.
+ ((and appfileentry (eq (cdr appfileentry) mode))
+ (setq dirty nil)
+ )
+ ;; Option 2 - We have a non-matching entry. Change Cdr.
+ (appfileentry
+ (setcdr appfileentry mode))
+ (t
+ ;; For option 3 & 4 - remove the entry from any other lists
+ ;; we can find.
+ (let ((any (srecode-map-entry-for-file-anywhere map file)))
+ (when any
+ (if (null (car any))
+ ;; Global map entry
+ (srecode-map-delete-file-entry map file)
+ ;; Some app
+ (let ((appentry (srecode-map-entry-for-app map app)))
+ (setcdr appentry (delete (cdr any) (cdr appentry))))
+ )))
+ ;; Now do option 3 and 4
+ (cond
+ ;; Option 3 - No entry for app. Add to the list.
+ (appentry
+ (setcdr appentry (cons (cons file mode) (cdr appentry)))
+ )
+ ;; Option 4 - No app entry. Add app to list with this file.
+ (t
+ (object-add-to-list map 'apps (list app (cons file mode)))
+ )))
+ )
+ dirty))
+
+
+;;; MAP Updating
+;;
+;;;###autoload
+(defun srecode-get-maps (&optional reset)
+ "Get a list of maps relevant to the current buffer.
+Optional argument RESET forces a reset of the current map."
+ (interactive "P")
+ ;; Always update the map, but only do a full reset if
+ ;; the user asks for one.
+ (srecode-map-update-map (not reset))
+
+ (if (interactive-p)
+ ;; Dump this map.
+ (with-output-to-temp-buffer "*SRECODE MAP*"
+ (princ " -- SRecode Global map --\n")
+ (srecode-maps-dump-file-list (oref srecode-current-map files))
+ (princ "\n -- Application Maps --\n")
+ (dolist (ap (oref srecode-current-map apps))
+ (let ((app (car ap))
+ (files (cdr ap)))
+ (princ app)
+ (princ " :\n")
+ (srecode-maps-dump-file-list files))
+ (princ "\n"))
+ (princ "\nUse:\n\n M-x customize-variable RET srecode-map-load-path
RET")
+ (princ "\n To change the path where SRecode loads templates from.")
+ )
+ ;; Eventually, I want to return many maps to search through.
+ (list srecode-current-map)))
+
+(eval-when-compile (require 'data-debug))
+
+(defun srecode-adebug-maps ()
+ "Run ADEBUG on the output of `srecode-get-maps'."
+ (interactive)
+ (require 'data-debug)
+ (let ((start (current-time))
+ (p (srecode-get-maps t)) ;; Time the reset.
+ (end (current-time))
+ )
+ (message "Updating the map took %.2f seconds."
+ (semantic-elapsed-time start end))
+ (data-debug-new-buffer "*SRECODE ADEBUG*")
+ (data-debug-insert-stuff-list p "*")))
+
+(defun srecode-maps-dump-file-list (flist)
+ "Dump a file list FLIST to `standard-output'."
+ (princ "Mode\t\t\tFilename\n")
+ (princ "------\t\t\t------------------\n")
+ (dolist (fe flist)
+ (prin1 (cdr fe))
+ (princ "\t")
+ (when (> (* 2 8) (length (symbol-name (cdr fe))))
+ (princ "\t"))
+ (when (> 8 (length (symbol-name (cdr fe))))
+ (princ "\t"))
+ (princ (car fe))
+ (princ "\n")
+ ))
+
+(defun srecode-map-file-still-valid-p (filename map)
+ "Return t if FILENAME should be in MAP still."
+ (let ((valid nil))
+ (and (file-exists-p filename)
+ (progn
+ (dolist (p srecode-map-load-path)
+ (when (and (< (length p) (length filename))
+ (string= p (substring filename 0 (length p))))
+ (setq valid t))
+ )
+ valid))
+ ))
+
+(defun srecode-map-update-map (&optional fast)
+ "Update the current map from `srecode-map-load-path'.
+Scans all the files on the path, and makes sure we have entries
+for them.
+If option FAST is non-nil, then only parse a file for the mode-string
+if that file is NEW, otherwise assume the mode has not changed."
+ (interactive)
+
+ ;; When no map file, we are configured to not use a save file.
+ (if (not srecode-map-save-file)
+ ;; 0) Create a MAP when in no save file mode.
+ (when (not srecode-current-map)
+ (setq srecode-current-map (srecode-map "SRecode Map"))
+ (message "SRecode map created in non-save mode.")
+ )
+
+ ;; 1) Do we even have a MAP or save file?
+ (when (and (not srecode-current-map)
+ (not (file-exists-p srecode-map-save-file)))
+ (when (not (file-exists-p (file-name-directory srecode-map-save-file)))
+ ;; Only bother with this interactively, not during a build
+ ;; or test.
+ (when (not noninteractive)
+ ;; No map, make the dir?
+ (if (y-or-n-p (format "Create dir %s? "
+ (file-name-directory srecode-map-save-file)))
+ (make-directory (file-name-directory srecode-map-save-file))
+ ;; No make, change save file
+ (customize-variable 'srecode-map-save-file)
+ (error "Change your SRecode map file"))))
+ ;; Have a dir. Make the object.
+ (setq srecode-current-map
+ (srecode-map "SRecode Map"
+ :file srecode-map-save-file)))
+
+ ;; 2) Do we not have a current map? If so load.
+ (when (not srecode-current-map)
+ (setq srecode-current-map
+ (eieio-persistent-read srecode-map-save-file))
+ )
+
+ )
+
+ ;;
+ ;; We better have a MAP object now.
+ ;;
+ (let ((dirty nil))
+ ;; 3) - Purge dead files from the file list.
+ (dolist (entry (copy-sequence (oref srecode-current-map files)))
+ (when (not (srecode-map-file-still-valid-p
+ (car entry) srecode-current-map))
+ (srecode-map-delete-file-entry srecode-current-map (car entry))
+ (setq dirty t)
+ ))
+ (dolist (app (copy-sequence (oref srecode-current-map apps)))
+ (dolist (entry (copy-sequence (cdr app)))
+ (when (not (srecode-map-file-still-valid-p
+ (car entry) srecode-current-map))
+ (srecode-map-delete-file-entry-from-app
+ srecode-current-map (car entry) (car app))
+ (setq dirty t)
+ )))
+ ;; 4) - Find new files and add them to the map.
+ (dolist (dir srecode-map-load-path)
+ (when (file-exists-p dir)
+ (dolist (f (directory-files dir t "\\.srt$"))
+ (when (and (not (backup-file-name-p f))
+ (not (auto-save-file-name-p f))
+ (file-readable-p f))
+ (let ((fdirty (srecode-map-validate-file-for-mode f fast)))
+ (setq dirty (or dirty fdirty))))
+ )))
+ ;; Only do the save if we are dirty, or if we are in an interactive
+ ;; Emacs.
+ (when (and dirty (not noninteractive)
+ (slot-boundp srecode-current-map :file))
+ (eieio-persistent-save srecode-current-map))
+ ))
+
+(defun srecode-map-validate-file-for-mode (file fast)
+ "Read and validate FILE via the parser. Return the mode.
+Argument FAST implies that the file should not be reparsed if there
+is already an entry for it.
+Return non-nil if the map changed."
+ (when (or (not fast)
+ (not (srecode-map-entry-for-file-anywhere srecode-current-map
file)))
+ (let ((buff-orig (get-file-buffer file))
+ (dirty nil))
+ (save-excursion
+ (if buff-orig
+ (set-buffer buff-orig)
+ (set-buffer (get-buffer-create " *srecode-map-tmp*"))
+ (insert-file-contents file nil nil nil t)
+ ;; Force it to be ready to parse.
+ (srecode-template-mode)
+ (let ((semantic-init-hook nil))
+ (semantic-new-buffer-fcn))
+ )
+
+ (semantic-fetch-tags)
+ (let* ((mode-tag
+ (semantic-find-first-tag-by-name "mode" (current-buffer)))
+ (val nil)
+ (app-tag
+ (semantic-find-first-tag-by-name "application"
(current-buffer)))
+ (app nil))
+ (if mode-tag
+ (setq val (car (semantic-tag-variable-default mode-tag)))
+ (error "There should be a mode declaration in %s" file))
+ (when app-tag
+ (setq app (car (semantic-tag-variable-default app-tag))))
+
+ (setq dirty
+ (if app
+ (srecode-map-update-app-file-entry srecode-current-map
+ file
+ (read val)
+ (read app))
+ (srecode-map-update-file-entry srecode-current-map
+ file
+ (read val))))
+ )
+ )
+ dirty)))
+
+
+;;; THE PATH
+;;
+;; We need to do this last since the setter needs the above code.
+
+(defun srecode-map-load-path-set (sym val)
+ "Set SYM to the new VAL, then update the srecode map."
+ (set-default sym val)
+ (srecode-map-update-map t))
+
+(defcustom srecode-map-load-path
+ (list (srecode-map-base-template-dir)
+ (expand-file-name "~/.srecode/")
+ )
+ "*Global load path for SRecode template files."
+ :group 'srecode
+ :type '(repeat file)
+ :set 'srecode-map-load-path-set)
+
+(provide 'srecode/map)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: srecode/loaddefs
+;; generated-autoload-load-name: "srecode/map"
+;; End:
+
+;;; srecode/map.el ends here
Index: cedet/srecode/mode.el
===================================================================
RCS file: cedet/srecode/mode.el
diff -N cedet/srecode/mode.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/srecode/mode.el 28 Sep 2009 15:15:12 -0000 1.2
@@ -0,0 +1,419 @@
+;;; srecode/mode.el --- Minor mode for managing and using SRecode templates
+
+;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Minor mode for working with SRecode template files.
+;;
+;; Depends on Semantic for minor-mode convenience functions.
+
+(require 'mode-local)
+(require 'srecode)
+(require 'srecode/insert)
+(require 'srecode/find)
+(require 'srecode/map)
+(require 'semantic/decorate)
+(require 'semantic/wisent)
+
+(eval-when-compile (require 'semantic/find))
+
+;;; Code:
+
+(defcustom global-srecode-minor-mode nil
+ "Non-nil in buffers with Semantic Recoder macro keybindings."
+ :group 'srecode
+ :type 'boolean
+ :require 'srecode/mode
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (global-srecode-minor-mode (if val 1 -1))))
+
+(defvar srecode-minor-mode nil
+ "Non-nil in buffers with Semantic Recoder macro keybindings.")
+(make-variable-buffer-local 'srecode-minor-mode)
+
+(defcustom srecode-minor-mode-hook nil
+ "Hook run at the end of the function `srecode-minor-mode'."
+ :group 'srecode
+ :type 'hook)
+
+;; We don't want to waste space. There is a menu after all.
+;;(add-to-list 'minor-mode-alist '(srecode-minor-mode ""))
+
+(defvar srecode-prefix-key [(control ?c) ?/]
+ "The common prefix key in srecode minor mode.")
+
+(defvar srecode-prefix-map
+ (let ((km (make-sparse-keymap)))
+ ;; Basic template codes
+ (define-key km "/" 'srecode-insert)
+ (define-key km [insert] 'srecode-insert)
+ (define-key km "." 'srecode-insert-again)
+ (define-key km "E" 'srecode-edit)
+ ;; Template indirect binding
+ (let ((k ?a))
+ (while (<= k ?z)
+ (define-key km (format "%c" k) 'srecode-bind-insert)
+ (setq k (1+ k))))
+ km)
+ "Keymap used behind the srecode prefix key in in srecode minor mode.")
+
+(defvar srecode-menu-bar
+ (list
+ "SRecoder"
+ (semantic-menu-item
+ ["Insert Template"
+ srecode-insert
+ :active t
+ :help "Insert a template by name."
+ ])
+ (semantic-menu-item
+ ["Insert Template Again"
+ srecode-insert-again
+ :active t
+ :help "Run the same template as last time again."
+ ])
+ (semantic-menu-item
+ ["Edit Template"
+ srecode-edit
+ :active t
+ :help "Edit a template for this language by name."
+ ])
+ "---"
+ '( "Insert ..." :filter srecode-minor-mode-templates-menu )
+ `( "Generate ..." :filter srecode-minor-mode-generate-menu )
+ "---"
+ (semantic-menu-item
+ ["Customize..."
+ (customize-group "srecode")
+ :active t
+ :help "Customize SRecode options"
+ ])
+ (list
+ "Debugging Tools..."
+ (semantic-menu-item
+ ["Dump Template MAP"
+ srecode-get-maps
+ :active t
+ :help "Calculate (if needed) and display the current template file map."
+ ])
+ (semantic-menu-item
+ ["Dump Tables"
+ srecode-dump-templates
+ :active t
+ :help "Dump the current template table."
+ ])
+ (semantic-menu-item
+ ["Dump Dictionary"
+ srecode-dictionary-dump
+ :active t
+ :help "Calculate a dump a dictionary for point."
+ ])
+ )
+ )
+ "Menu for srecode minor mode.")
+
+(defvar srecode-minor-menu nil
+ "Menu keymap build from `srecode-menu-bar'.")
+
+(defcustom srecode-takeover-INS-key nil
+ "Use the insert key for inserting templates."
+ :group 'srecode
+ :type 'boolean)
+
+(defvar srecode-mode-map
+ (let ((km (make-sparse-keymap)))
+ (define-key km srecode-prefix-key srecode-prefix-map)
+ (easy-menu-define srecode-minor-menu km "Srecode Minor Mode Menu"
+ srecode-menu-bar)
+ (when srecode-takeover-INS-key
+ (define-key km [insert] srecode-prefix-map))
+ km)
+ "Keymap for srecode minor mode.")
+
+;;;###autoload
+(defun srecode-minor-mode (&optional arg)
+ "Toggle srecode minor mode.
+With prefix argument ARG, turn on if positive, otherwise off. The
+minor mode can be turned on only if semantic feature is available and
+the current buffer was set up for parsing. Return non-nil if the
+minor mode is enabled.
+
+\\{srecode-mode-map}"
+ (interactive
+ (list (or current-prefix-arg
+ (if srecode-minor-mode 0 1))))
+ ;; Flip the bits.
+ (setq srecode-minor-mode
+ (if arg
+ (>
+ (prefix-numeric-value arg)
+ 0)
+ (not srecode-minor-mode)))
+ ;; If we are turning things on, make sure we have templates for
+ ;; this mode first.
+ (when srecode-minor-mode
+ (when (not (apply
+ 'append
+ (mapcar (lambda (map)
+ (srecode-map-entries-for-mode map major-mode))
+ (srecode-get-maps))))
+ (setq srecode-minor-mode nil))
+ )
+ ;; Run hooks if we are turning this on.
+ (when srecode-minor-mode
+ (run-hooks 'srecode-minor-mode-hook))
+ srecode-minor-mode)
+
+;;;###autoload
+(defun global-srecode-minor-mode (&optional arg)
+ "Toggle global use of srecode minor mode.
+If ARG is positive, enable, if it is negative, disable.
+If ARG is nil, then toggle."
+ (interactive "P")
+ (setq global-srecode-minor-mode
+ (semantic-toggle-minor-mode-globally
+ 'srecode-minor-mode arg)))
+
+;; Use the semantic minor mode magic stuff.
+(semantic-add-minor-mode 'srecode-minor-mode "" srecode-mode-map)
+
+;;; Menu Filters
+;;
+(defun srecode-minor-mode-templates-menu (menu-def)
+ "Create a menu item of cascading filters active for this mode.
+MENU-DEF is the menu to bind this into."
+ ;; Doing this SEGVs Emacs on windows.
+ ;;(srecode-load-tables-for-mode major-mode)
+
+ (let* ((modetable (srecode-get-mode-table major-mode))
+ (subtab (when modetable (oref modetable :tables)))
+ (context nil)
+ (active nil)
+ (ltab nil)
+ (temp nil)
+ (alltabs nil)
+ )
+ (if (not subtab)
+ ;; No tables, show a "load the tables" option.
+ (list (vector "Load Mode Tables..."
+ (lambda ()
+ (interactive)
+ (srecode-load-tables-for-mode major-mode))
+ ))
+ ;; Build something
+ (setq context (car-safe (srecode-calculate-context)))
+
+ (while subtab
+ (setq ltab (oref (car subtab) templates))
+ (while ltab
+ (setq temp (car ltab))
+
+ ;; Do something with this template.
+
+ (let* ((ctxt (oref temp context))
+ (ctxtcons (assoc ctxt alltabs))
+ (bind (if (slot-boundp temp 'binding)
+ (oref temp binding)))
+ (name (object-name-string temp)))
+
+ (when (not ctxtcons)
+ (if (string= context ctxt)
+ ;; If this context is not in the current list of contexts
+ ;; is equal to the current context, then manage the
+ ;; active list instead
+ (setq active
+ (setq ctxtcons (or active (cons ctxt nil))))
+ ;; This is not an active context, add it to alltabs.
+ (setq ctxtcons (cons ctxt nil))
+ (setq alltabs (cons ctxtcons alltabs))))
+
+ (let ((new (vector
+ (if bind
+ (concat name " (" bind ")")
+ name)
+ `(lambda () (interactive)
+ (srecode-insert (concat ,ctxt ":" ,name)))
+ t)))
+
+ (setcdr ctxtcons (cons
+ new
+ (cdr ctxtcons)))))
+
+ (setq ltab (cdr ltab)))
+ (setq subtab (cdr subtab)))
+
+ ;; Now create the menu
+ (easy-menu-filter-return
+ (easy-menu-create-menu
+ "Semantic Recoder Filters"
+ (append (cdr active)
+ alltabs)
+ ))
+ )))
+
+(defvar srecode-minor-mode-generators nil
+ "List of code generators to be displayed in the srecoder menu.")
+
+(defun srecode-minor-mode-generate-menu (menu-def)
+ "Create a menu item of cascading filters active for this mode.
+MENU-DEF is the menu to bind this into."
+ ;; Doing this SEGVs Emacs on windows.
+ ;;(srecode-load-tables-for-mode major-mode)
+ (let ((allgeneratorapps nil))
+
+ (dolist (gen srecode-minor-mode-generators)
+ (setq allgeneratorapps
+ (cons (vector (cdr gen) (car gen))
+ allgeneratorapps))
+ (message "Adding %S to srecode menu" (car gen))
+ )
+
+ (easy-menu-filter-return
+ (easy-menu-create-menu
+ "Semantic Recoder Generate Filters"
+ allgeneratorapps)))
+ )
+
+;;; Minor Mode commands
+;;
+(defun srecode-bind-insert ()
+ "Bound insert for Srecode macros.
+This command will insert whichever srecode template has a binding
+to the current key."
+ (interactive)
+ (let* ((k last-command-event)
+ (ctxt (srecode-calculate-context))
+ ;; Find the template with the binding K
+ (template (srecode-template-get-table-for-binding
+ (srecode-table) k ctxt)))
+ ;; test it.
+ (when (not template)
+ (error "No template bound to %c" k))
+ ;; insert
+ (srecode-insert template)
+ ))
+
+(defun srecode-edit (template-name)
+ "Switch to the template buffer for TEMPLATE-NAME.
+Template is chosen based on the mode of the starting buffer."
+ ;; @todo - Get a template stack from the last run template, and show
+ ;; those too!
+ (interactive (list (srecode-read-template-name
+ "Template Name: "
+ (car srecode-read-template-name-history))))
+ (if (not (srecode-table))
+ (error "No template table found for mode %s" major-mode))
+ (let ((temp (srecode-template-get-table (srecode-table) template-name)))
+ (if (not temp)
+ (error "No Template named %s" template-name))
+ ;; We need a template specific table, since tables chain.
+ (let ((tab (oref temp :table))
+ (names nil)
+ )
+ (find-file (oref tab :file))
+ (setq names (semantic-find-tags-by-name (oref temp :object-name)
+ (current-buffer)))
+ (cond ((= (length names) 1)
+ (semantic-go-to-tag (car names))
+ (semantic-momentary-highlight-tag (car names)))
+ ((> (length names) 1)
+ (let* ((ctxt (semantic-find-tags-by-name (oref temp :context)
+ (current-buffer)))
+ (cls (semantic-find-tags-by-class 'context ctxt))
+ )
+ (while (and names
+ (< (semantic-tag-start (car names))
+ (semantic-tag-start (car cls))))
+ (setq names (cdr names)))
+ (if names
+ (progn
+ (semantic-go-to-tag (car names))
+ (semantic-momentary-highlight-tag (car names)))
+ (error "Can't find template %s" template-name))
+ ))
+ (t (error "Can't find template %s" template-name)))
+ )))
+
+(defun srecode-add-code-generator (function name &optional binding)
+ "Add the srecoder code generator FUNCTION with NAME to the menu.
+Optional BINDING specifies the keybinding to use in the srecoder map.
+BINDING should be a capital letter. Lower case letters are reserved
+for individual templates.
+Optional MODE specifies a major mode this function applies to.
+Do not specify a mode if this function could be applied to most
+programming modes."
+ ;; Update the menu generating part.
+ (let ((remloop nil))
+ (while (setq remloop (assoc function srecode-minor-mode-generators))
+ (setq srecode-minor-mode-generators
+ (remove remloop srecode-minor-mode-generators))))
+
+ (add-to-list 'srecode-minor-mode-generators
+ (cons function name))
+
+ ;; Remove this function from any old bindings.
+ (when binding
+ (let ((oldkey (where-is-internal function
+ (list srecode-prefix-map)
+ t t t)))
+ (if (or (not oldkey)
+ (and (= (length oldkey) 1)
+ (= (length binding) 1)
+ (= (aref oldkey 0) (aref binding 0))))
+ ;; Its the same.
+ nil
+ ;; Remove the old binding
+ (define-key srecode-prefix-map oldkey nil)
+ )))
+
+ ;; Update Keybings
+ (let ((oldbinding (lookup-key srecode-prefix-map binding)))
+
+ ;; During development, allow overrides.
+ (when (and oldbinding
+ (not (eq oldbinding function))
+ (or (eq this-command 'eval-defun) (eq this-command
'checkdoc-eval-defun))
+ (y-or-n-p (format "Override old binding %s? " oldbinding)))
+ (setq oldbinding nil))
+
+ (if (not oldbinding)
+ (define-key srecode-prefix-map binding function)
+ (if (eq function oldbinding)
+ nil
+ ;; Not the same.
+ (message "Conflict binding %S binding to srecode map."
+ binding))))
+ )
+
+;; Add default code generators:
+(srecode-add-code-generator 'srecode-document-insert-comment "Comments" "C")
+(srecode-add-code-generator 'srecode-insert-getset "Get/Set" "G")
+
+(provide 'srecode/mode)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: srecode/loaddefs
+;; generated-autoload-load-name: "srecode/mode"
+;; End:
+
+;;; srecode/mode.el ends here
Index: cedet/srecode/semantic.el
===================================================================
RCS file: cedet/srecode/semantic.el
diff -N cedet/srecode/semantic.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/srecode/semantic.el 28 Sep 2009 15:15:12 -0000 1.2
@@ -0,0 +1,431 @@
+;;; srecode/semantic.el --- Semantic specific extensions to SRecode.
+
+;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Semantic specific extensions to the Semantic Recoder.
+;;
+;; I realize it is the "Semantic Recoder", but most of srecode
+;; is a template library and set of user interfaces unrelated to
+;; semantic in the specific.
+;;
+;; This file defines the following:
+;; - :tag argument handling.
+;; - <more goes here>
+
+;;; Code:
+
+(require 'srecode/insert)
+(require 'srecode/dictionary)
+(require 'semantic/find)
+(require 'semantic/format)
+(require 'semantic/senator)
+(require 'ring)
+
+
+;;; The SEMANTIC TAG inserter
+;;
+;; Put a tag into the dictionary that can be used w/ arbitrary
+;; lisp expressions.
+
+(defclass srecode-semantic-tag (srecode-dictionary-compound-value)
+ ((prime :initarg :prime
+ :type semantic-tag
+ :documentation
+ "This is the primary insertion tag.")
+ )
+ "Wrap up a collection of semantic tag information.
+This class will be used to derive dictionary values.")
+
+(defmethod srecode-compound-toString((cp srecode-semantic-tag)
+ function
+ dictionary)
+ "Convert the compound dictionary value CP to a string.
+If FUNCTION is non-nil, then FUNCTION is somehow applied to an
+aspect of the compound value."
+ (if (not function)
+ ;; Just format it in some handy dandy way.
+ (semantic-format-tag-prototype (oref cp :prime))
+ ;; Otherwise, apply the function to the tag itself.
+ (funcall function (oref cp :prime))
+ ))
+
+
+;;; Managing the `current' tag
+;;
+
+(defvar srecode-semantic-selected-tag nil
+ "The tag selected by a :tag template argument.
+If this is nil, then `senator-tag-ring' is used.")
+
+(defun srecode-semantic-tag-from-kill-ring ()
+ "Create an `srecode-semantic-tag' from the senator kill ring."
+ (if (ring-empty-p senator-tag-ring)
+ (error "You must use `senator-copy-tag' to provide a tag to this
template"))
+ (ring-ref senator-tag-ring 0))
+
+
+;;; TAG in a DICTIONARY
+;;
+(defvar srecode-semantic-apply-tag-augment-hook nil
+ "A function called for each tag added to a dictionary.
+The hook is called with two arguments, the TAG and DICT
+to be augmented.")
+
+(define-overload srecode-semantic-apply-tag-to-dict (tagobj dict)
+ "Insert fewatures of TAGOBJ into the dictionary DICT.
+TAGOBJ is an object of class `srecode-semantic-tag'. This class
+is a compound inserter value.
+DICT is a dictionary object.
+At a minimum, this function will create dictionary macro for NAME.
+It is also likely to create macros for TYPE (data type), function arguments,
+variable default values, and other things."
+ )
+
+(defun srecode-semantic-apply-tag-to-dict-default (tagobj dict)
+ "Insert features of TAGOBJ into dictionary DICT."
+ ;; Store the sst into the dictionary.
+ (srecode-dictionary-set-value dict "TAG" tagobj)
+
+ ;; Pull out the tag for the individual pieces.
+ (let ((tag (oref tagobj :prime)))
+
+ (srecode-dictionary-set-value dict "NAME" (semantic-tag-name tag))
+ (srecode-dictionary-set-value dict "TYPE" (semantic-format-tag-type tag
nil))
+
+ (run-hook-with-args 'srecode-semantic-apply-tag-augment-hook tag dict)
+
+ (cond
+ ;;
+ ;; FUNCTION
+ ;;
+ ((eq (semantic-tag-class tag) 'function)
+ ;; FCN ARGS
+ (let ((args (semantic-tag-function-arguments tag)))
+ (while args
+ (let ((larg (car args))
+ (subdict (srecode-dictionary-add-section-dictionary
+ dict "ARGS")))
+ ;; Clean up elements in the arg list.
+ (if (stringp larg)
+ (setq larg (semantic-tag-new-variable
+ larg nil nil)))
+ ;; Apply the sub-argument to the subdictionary.
+ (srecode-semantic-apply-tag-to-dict
+ (srecode-semantic-tag (semantic-tag-name larg)
+ :prime larg)
+ subdict)
+ )
+ ;; Next!
+ (setq args (cdr args))))
+ ;; PARENTS
+ (let ((p (semantic-tag-function-parent tag)))
+ (when p
+ (srecode-dictionary-set-value dict "PARENT" p)
+ ))
+ ;; EXCEPTIONS (java/c++)
+ (let ((exceptions (semantic-tag-get-attribute tag :throws)))
+ (while exceptions
+ (let ((subdict (srecode-dictionary-add-section-dictionary
+ dict "THROWS")))
+ (srecode-dictionary-set-value subdict "NAME" (car exceptions))
+ )
+ (setq exceptions (cdr exceptions)))
+ )
+ )
+ ;;
+ ;; VARIABLE
+ ;;
+ ((eq (semantic-tag-class tag) 'variable)
+ (when (semantic-tag-variable-default tag)
+ (let ((subdict (srecode-dictionary-add-section-dictionary
+ dict "HAVEDEFAULT")))
+ (srecode-dictionary-set-value
+ subdict "VALUE" (semantic-tag-variable-default tag))))
+ )
+ ;;
+ ;; TYPE
+ ;;
+ ((eq (semantic-tag-class tag) 'type)
+ (dolist (p (semantic-tag-type-superclasses tag))
+ (let ((sd (srecode-dictionary-add-section-dictionary
+ dict "PARENTS")))
+ (srecode-dictionary-set-value sd "NAME" p)
+ ))
+ (dolist (i (semantic-tag-type-interfaces tag))
+ (let ((sd (srecode-dictionary-add-section-dictionary
+ dict "INTERFACES")))
+ (srecode-dictionary-set-value sd "NAME" i)
+ ))
+; NOTE : The members are too complicated to do via a template.
+; do it via the insert-tag solution instead.
+;
+; (dolist (mem (semantic-tag-type-members tag))
+; (let ((subdict (srecode-dictionary-add-section-dictionary
+; dict "MEMBERS")))
+; (when (stringp mem)
+; (setq mem (semantic-tag-new-variable mem nil nil)))
+; (srecode-semantic-apply-tag-to-dict
+; (srecode-semantic-tag (semantic-tag-name mem)
+; :prime mem)
+; subdict)))
+ ))))
+
+
+;;; ARGUMENT HANDLERS
+
+;;; :tag ARGUMENT HANDLING
+;;
+;; When a :tag argument is required, identify the current :tag,
+;; and apply it's parts into the dictionary.
+(defun srecode-semantic-handle-:tag (dict)
+ "Add macroes into the dictionary DICT based on the current :tag."
+ ;; We have a tag, start adding "stuff" into the dictionary.
+ (let ((tag (or srecode-semantic-selected-tag
+ (srecode-semantic-tag-from-kill-ring))))
+ (when (not tag)
+ "No tag for current template. Use the semantic kill-ring.")
+ (srecode-semantic-apply-tag-to-dict
+ (srecode-semantic-tag (semantic-tag-name tag)
+ :prime tag)
+ dict)))
+
+;;; :tagtype ARGUMENT HANDLING
+;;
+;; When a :tagtype argument is required, identify the current tag, of
+;; cf class 'type. Apply those parameters to the dictionary.
+
+(defun srecode-semantic-handle-:tagtype (dict)
+ "Add macroes into the dictionary DICT based on a tag of class type at point.
+Assumes the cursor is in a tag of class type. If not, throw an error."
+ (let ((typetag (or srecode-semantic-selected-tag
+ (semantic-current-tag-of-class 'type))))
+ (when (not typetag)
+ (error "Cursor is not in a TAG of class 'type"))
+ (srecode-semantic-apply-tag-to-dict
+ typetag
+ dict)))
+
+
+;;; INSERT A TAG API
+;;
+;; Routines that take a tag, and insert into a buffer.
+(define-overload srecode-semantic-find-template (class prototype ctxt)
+ "Find a template for a tag of class CLASS based on context.
+PROTOTYPE is non-nil if we want a prototype template instead."
+ )
+
+(defun srecode-semantic-find-template-default (class prototype ctxt)
+ "Find a template for tag CLASS based on context.
+PROTOTYPE is non-nil if we need a prototype.
+CTXT is the pre-calculated context."
+ (let* ((top (car ctxt))
+ (tname (if (stringp class)
+ class
+ (symbol-name class)))
+ (temp nil)
+ )
+ ;; Try to find a template.
+ (setq temp (or
+ (when prototype
+ (srecode-template-get-table (srecode-table)
+ (concat tname "-tag-prototype")
+ top))
+ (when prototype
+ (srecode-template-get-table (srecode-table)
+ (concat tname "-prototype")
+ top))
+ (srecode-template-get-table (srecode-table)
+ (concat tname "-tag")
+ top)
+ (srecode-template-get-table (srecode-table)
+ tname
+ top)
+ (when (and (not (string= top "declaration"))
+ prototype)
+ (srecode-template-get-table (srecode-table)
+ (concat tname "-prototype")
+ "declaration"))
+ (when (and (not (string= top "declaration"))
+ prototype)
+ (srecode-template-get-table (srecode-table)
+ (concat tname "-tag-prototype")
+ "declaration"))
+ (when (not (string= top "declaration"))
+ (srecode-template-get-table (srecode-table)
+ (concat tname "-tag")
+ "declaration"))
+ (when (not (string= top "declaration"))
+ (srecode-template-get-table (srecode-table)
+ tname
+ "declaration"))
+ ))
+ temp))
+
+(defun srecode-semantic-insert-tag (tag &optional style-option
+ point-insert-fcn
+ &rest dict-entries)
+ "Insert TAG into a buffer useing srecode templates at point.
+
+Optional STYLE-OPTION is a list of minor configuration of styles,
+such as the symbol 'prototype for prototype functions, or
+'system for system includes, and 'doxygen, for a doxygen style
+comment.
+
+Optional third argument POINT-INSERT-FCN is a hook that is run after
+TAG is inserted that allows an opportunity to fill in the body of
+some thing. This hook function is called with one argument, the TAG
+being inserted.
+
+The rest of the arguments are DICT-ENTRIES. DICT-ENTRIES
+is of the form ( NAME1 VALUE1 NAME2 VALUE2 ... NAMEn VALUEn).
+
+The exact template used is based on the current context.
+The template used is found within the toplevel context as calculated
+by `srecode-calculate-context', such as `declaration', `classdecl',
+or `code'.
+
+For various conditions, this function looks for a template with
+the name CLASS-tag, where CLASS is the tag class. If it cannot
+find that, it will look for that template in the
+`declaration'context (if the current context was not `declaration').
+
+If PROTOTYPE is specified, it will first look for templates with
+the name CLASS-tag-prototype, or CLASS-prototype as above.
+
+See `srecode-semantic-apply-tag-to-dict' for details on what is in
+the dictionary when the templates are called.
+
+This function returns to location in the buffer where the
+inserted tag ENDS, and will leave point inside the inserted
+text based on any occurance of a point-inserter. Templates such
+as `function' will leave point where code might be inserted."
+ (srecode-load-tables-for-mode major-mode)
+ (let* ((ctxt (srecode-calculate-context))
+ (top (car ctxt))
+ (tname (symbol-name (semantic-tag-class tag)))
+ (dict (srecode-create-dictionary))
+ (temp nil)
+ (errtype tname)
+ (prototype (memq 'prototype style-option))
+ )
+ ;; Try some special cases.
+ (cond ((and (semantic-tag-of-class-p tag 'function)
+ (semantic-tag-get-attribute tag :constructor-flag))
+ (setq temp (srecode-semantic-find-template
+ "constructor" prototype ctxt))
+ )
+
+ ((and (semantic-tag-of-class-p tag 'function)
+ (semantic-tag-get-attribute tag :destructor-flag))
+ (setq temp (srecode-semantic-find-template
+ "destructor" prototype ctxt))
+ )
+
+ ((and (semantic-tag-of-class-p tag 'function)
+ (semantic-tag-function-parent tag))
+ (setq temp (srecode-semantic-find-template
+ "method" prototype ctxt))
+ )
+
+ ((and (semantic-tag-of-class-p tag 'variable)
+ (semantic-tag-get-attribute tag :constant-flag))
+ (setq temp (srecode-semantic-find-template
+ "variable-const" prototype ctxt))
+ )
+ )
+
+ (when (not temp)
+ ;; Try the basics
+ (setq temp (srecode-semantic-find-template
+ tname prototype ctxt)))
+
+ ;; Try some backup template names.
+ (when (not temp)
+ (cond
+ ;; Types might split things up based on the type's type.
+ ((and (eq (semantic-tag-class tag) 'type)
+ (semantic-tag-type tag))
+ (setq temp (srecode-semantic-find-template
+ (semantic-tag-type tag) prototype ctxt))
+ (setq errtype (concat errtype " or " (semantic-tag-type tag)))
+ )
+ ;; A function might be an externally declared method.
+ ((and (eq (semantic-tag-class tag) 'function)
+ (semantic-tag-function-parent tag))
+ (setq temp (srecode-semantic-find-template
+ "method" prototype ctxt)))
+ (t
+ nil)
+ ))
+
+ ;; Can't find one? Drat!
+ (when (not temp)
+ (error "Cannot find template %s in %s for inserting tag %S"
+ errtype top (semantic-format-tag-summarize tag)))
+
+ ;; Resolve Arguments
+ (let ((srecode-semantic-selected-tag tag))
+ (srecode-resolve-arguments temp dict))
+
+ ;; Resolve TAG into the dictionary. We may have a :tag arg
+ ;; from the macro such that we don't need to do this.
+ (when (not (srecode-dictionary-lookup-name dict "TAG"))
+ (let ((tagobj (srecode-semantic-tag (semantic-tag-name tag) :prime tag))
+ )
+ (srecode-semantic-apply-tag-to-dict tagobj dict)))
+
+ ;; Insert dict-entries into the dictionary LAST so that previous
+ ;; items can be overriden.
+ (let ((entries dict-entries))
+ (while entries
+ (srecode-dictionary-set-value dict
+ (car entries)
+ (car (cdr entries)))
+ (setq entries (cdr (cdr entries)))))
+
+ ;; Insert the template.
+ (let ((endpt (srecode-insert-fcn temp dict nil t)))
+
+ (run-hook-with-args 'point-insert-fcn tag)
+ ;;(sit-for 1)
+
+ (cond
+ ((semantic-tag-of-class-p tag 'type)
+ ;; Insert all the members at the current insertion point.
+ (dolist (m (semantic-tag-type-members tag))
+
+ (when (stringp m)
+ (setq m (semantic-tag-new-variable m nil nil)))
+
+ ;; We do prototypes w/in the class decl?
+ (let ((me (srecode-semantic-insert-tag m '(prototype))))
+ (goto-char me))
+
+ ))
+ )
+
+ endpt)
+ ))
+
+(provide 'srecode/semantic)
+
+;;; srecode/semantic.el ends here
Index: cedet/srecode/srt-mode.el
===================================================================
RCS file: cedet/srecode/srt-mode.el
diff -N cedet/srecode/srt-mode.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/srecode/srt-mode.el 28 Sep 2009 15:15:12 -0000 1.2
@@ -0,0 +1,751 @@
+;;; srecode/srt-mode.el --- Major mode for writing screcode macros
+
+;; Copyright (C) 2005, 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Originally named srecode-template-mode.el in the CEDET repository.
+
+(require 'srecode/compile)
+(require 'srecode/ctxt)
+(require 'srecode/template)
+
+(require 'semantic)
+(require 'semantic/analyze)
+(require 'semantic/wisent)
+(eval-when-compile
+ (require 'semantic/find))
+
+(declare-function srecode-create-dictionary "srecode/dictionary")
+(declare-function srecode-resolve-argument-list "srecode/insert")
+
+;;; Code:
+(defvar srecode-template-mode-syntax-table
+ (let ((table (make-syntax-table (standard-syntax-table))))
+ (modify-syntax-entry ?\; ". 12" table) ;; SEMI, Comment start ;;
+ (modify-syntax-entry ?\n ">" table) ;; Comment end
+ (modify-syntax-entry ?$ "." table) ;; Punctuation
+ (modify-syntax-entry ?: "." table) ;; Punctuation
+ (modify-syntax-entry ?< "." table) ;; Punctuation
+ (modify-syntax-entry ?> "." table) ;; Punctuation
+ (modify-syntax-entry ?# "." table) ;; Punctuation
+ (modify-syntax-entry ?! "." table) ;; Punctuation
+ (modify-syntax-entry ?? "." table) ;; Punctuation
+ (modify-syntax-entry ?\" "\"" table) ;; String
+ (modify-syntax-entry ?\- "_" table) ;; Symbol
+ (modify-syntax-entry ?\\ "\\" table) ;; Quote
+ (modify-syntax-entry ?\` "'" table) ;; Prefix ` (backquote)
+ (modify-syntax-entry ?\' "'" table) ;; Prefix ' (quote)
+ (modify-syntax-entry ?\, "'" table) ;; Prefix , (comma)
+
+ table)
+ "Syntax table used in semantic recoder macro buffers.")
+
+(defface srecode-separator-face
+ '((t (:weight bold :strike-through t)))
+ "Face used for decorating separators in srecode template mode."
+ :group 'srecode)
+
+(defvar srecode-font-lock-keywords
+ '(
+ ;; Template
+ ("^\\(template\\)\\s-+\\(\\w*\\)\\(\\( \\(:\\w+\\)\\|\\)+\\)$"
+ (1 font-lock-keyword-face)
+ (2 font-lock-function-name-face)
+ (3 font-lock-builtin-face ))
+ ("^\\(sectiondictionary\\)\\s-+\""
+ (1 font-lock-keyword-face))
+ ("^\\(bind\\)\\s-+\""
+ (1 font-lock-keyword-face))
+ ;; Variable type setting
+ ("^\\(set\\)\\s-+\\(\\w+\\)\\s-+"
+ (1 font-lock-keyword-face)
+ (2 font-lock-variable-name-face))
+ ("^\\(show\\)\\s-+\\(\\w+\\)\\s-*$"
+ (1 font-lock-keyword-face)
+ (2 font-lock-variable-name-face))
+ ("\\<\\(macro\\)\\s-+\""
+ (1 font-lock-keyword-face))
+ ;; Context type setting
+ ("^\\(context\\)\\s-+\\(\\w+\\)"
+ (1 font-lock-keyword-face)
+ (2 font-lock-builtin-face))
+ ;; Prompting setting
+ ("^\\(prompt\\)\\s-+\\(\\w+\\)"
+ (1 font-lock-keyword-face)
+ (2 font-lock-variable-name-face))
+ ("\\(default\\(macro\\)?\\)\\s-+\\(\\(\\w\\|\\s_\\)+\\)"
+ (1 font-lock-keyword-face)
+ (3 font-lock-type-face))
+ ("\\<\\(default\\(macro\\)?\\)\\>" (1 font-lock-keyword-face))
+ ("\\<\\(read\\)\\s-+\\(\\(\\w\\|\\s_\\)+\\)"
+ (1 font-lock-keyword-face)
+ (2 font-lock-type-face))
+
+ ;; Macro separators
+ ("^----\n" 0 'srecode-separator-face)
+
+ ;; Macro Matching
+ (srecode-template-mode-macro-escape-match 1 font-lock-string-face)
+ ((lambda (limit)
+ (srecode-template-mode-font-lock-macro-helper
+ limit "\\(\\??\\w+\\)[^ \t\n{}$#@&*()]*"))
+ 1 font-lock-variable-name-face)
+ ((lambda (limit)
+ (srecode-template-mode-font-lock-macro-helper
+ limit "\\([#/]\\w+\\)[^ \t\n{}$#@&*()]*"))
+ 1 font-lock-keyword-face)
+ ((lambda (limit)
+ (srecode-template-mode-font-lock-macro-helper
+ limit "\\([<>]\\w*\\):\\(\\w+\\):\\(\\w+\\)"))
+ (1 font-lock-keyword-face)
+ (2 font-lock-builtin-face)
+ (3 font-lock-type-face))
+ ((lambda (limit)
+ (srecode-template-mode-font-lock-macro-helper
+ limit "\\([<>?]?\\w*\\):\\(\\w+\\)"))
+ (1 font-lock-keyword-face)
+ (2 font-lock-type-face))
+ ((lambda (limit)
+ (srecode-template-mode-font-lock-macro-helper
+ limit "!\\([^{}$]*\\)"))
+ 1 font-lock-comment-face)
+
+ )
+ "Keywords for use with srecode macros and font-lock.")
+
+(defun srecode-template-mode-font-lock-macro-helper (limit expression)
+ "Match against escape characters.
+Don't scan past LIMIT. Match with EXPRESSION."
+ (let* ((done nil)
+ (md nil)
+ (es (regexp-quote (srecode-template-get-escape-start)))
+ (ee (regexp-quote (srecode-template-get-escape-end)))
+ (regex (concat es expression ee))
+ )
+ (while (not done)
+ (save-match-data
+ (if (re-search-forward regex limit t)
+ (when (equal (car (srecode-calculate-context)) "code")
+ (setq md (match-data)
+ done t))
+ (setq done t))))
+ (set-match-data md)
+ ;; (when md (message "Found a match!"))
+ (when md t)))
+
+(defun srecode-template-mode-macro-escape-match (limit)
+ "Match against escape characters.
+Don't scan past LIMIT."
+ (let* ((done nil)
+ (md nil)
+ (es (regexp-quote (srecode-template-get-escape-start)))
+ (ee (regexp-quote (srecode-template-get-escape-end)))
+ (regex (concat "\\(" es "\\|" ee "\\)"))
+ )
+ (while (not done)
+ (save-match-data
+ (if (re-search-forward regex limit t)
+ (when (equal (car (srecode-calculate-context)) "code")
+ (setq md (match-data)
+ done t))
+ (setq done t))))
+ (set-match-data md)
+ ;;(when md (message "Found a match!"))
+ (when md t)))
+
+(defvar srecode-font-lock-macro-keywords nil
+ "Dynamically generated `font-lock' keywords for srecode templates.
+Once the escape_start, and escape_end sequences are known, then
+we can tell font lock about them.")
+
+(defvar srecode-template-mode-map
+ (let ((km (make-sparse-keymap)))
+ (define-key km "\C-c\C-c" 'srecode-compile-templates)
+ (define-key km "\C-c\C-m" 'srecode-macro-help)
+ (define-key km "/" 'srecode-self-insert-complete-end-macro)
+ km)
+ "Keymap used in srecode mode.")
+
+;;;###autoload
+(defun srecode-template-mode ()
+ "Major-mode for writing srecode macros."
+ (interactive)
+ (kill-all-local-variables)
+ (setq major-mode 'srecode-template-mode
+ mode-name "SRecoder"
+ comment-start ";;"
+ comment-end "")
+ (set (make-local-variable 'parse-sexp-ignore-comments) t)
+ (set (make-local-variable 'comment-start-skip)
+ "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *")
+ (set-syntax-table srecode-template-mode-syntax-table)
+ (use-local-map srecode-template-mode-map)
+ (set (make-local-variable 'font-lock-defaults)
+ '(srecode-font-lock-keywords
+ nil ;; perform string/comment fontification
+ nil ;; keywords are case sensitive.
+ ;; This puts _ & - as a word constituant,
+ ;; simplifying our keywords significantly
+ ((?_ . "w") (?- . "w"))))
+ (run-hooks 'srecode-template-mode-hook))
+
+;;;###autoload
+(defalias 'srt-mode 'srecode-template-mode)
+
+;;; Template Commands
+;;
+(defun srecode-self-insert-complete-end-macro ()
+ "Self insert the current key, then autocomplete the end macro."
+ (interactive)
+ (call-interactively 'self-insert-command)
+ (when (and (semantic-current-tag)
+ (semantic-tag-of-class-p (semantic-current-tag) 'function)
+ )
+ (let* ((es (srecode-template-get-escape-start))
+ (ee (srecode-template-get-escape-end))
+ (name (save-excursion
+ (forward-char (- (length es)))
+ (forward-char -1)
+ (if (looking-at (regexp-quote es))
+ (srecode-up-context-get-name (point) t))))
+ )
+ (when name
+ (insert name)
+ (insert ee))))
+ )
+
+
+(defun srecode-macro-help ()
+ "Provide help for working with macros in a tempalte."
+ (interactive)
+ (let* ((root 'srecode-template-inserter)
+ (chl (aref (class-v root) class-children))
+ (ess (srecode-template-get-escape-start))
+ (ees (srecode-template-get-escape-end))
+ )
+ (with-output-to-temp-buffer "*SRecode Macros*"
+ (princ "Description of known SRecode Template Macros.")
+ (terpri)
+ (terpri)
+ (while chl
+ (let* ((C (car chl))
+ (name (symbol-name C))
+ (key (when (slot-exists-p C 'key)
+ (oref C key)))
+ (showexample t)
+ )
+ (setq chl (cdr chl))
+ (setq chl (append (aref (class-v C) class-children) chl))
+
+ (catch 'skip
+ (when (eq C 'srecode-template-inserter-section-end)
+ (throw 'skip nil))
+
+ (when (class-abstract-p C)
+ (throw 'skip nil))
+
+ (princ "`")
+ (princ name)
+ (princ "'")
+ (when (slot-exists-p C 'key)
+ (when key
+ (princ " - Character Key: ")
+ (if (stringp key)
+ (progn
+ (setq showexample nil)
+ (cond ((string= key "\n")
+ (princ "\"\\n\"")
+ )
+ (t
+ (prin1 key)
+ )))
+ (prin1 (format "%c" key))
+ )))
+ (terpri)
+ (princ (documentation-property C 'variable-documentation))
+ (terpri)
+ (when showexample
+ (princ "Example:")
+ (terpri)
+ (srecode-inserter-prin-example C ess ees)
+ )
+
+ (terpri)
+
+ ) ;; catch
+ );; let*
+ ))))
+
+
+;;; Misc Language Overrides
+;;
+(define-mode-local-override semantic-ia-insert-tag
+ srecode-template-mode (tag)
+ "Insert the SRecode TAG into the current buffer."
+ (insert (semantic-tag-name tag)))
+
+
+;;; Local Context Parsing.
+
+(defun srecode-in-macro-p (&optional point)
+ "Non-nil if POINT is inside a macro bounds.
+If the ESCAPE_START and END are different sequences,
+a simple search is used. If ESCAPE_START and END are the same
+characteres, start at the beginning of the line, and find out
+how many occur."
+ (let ((tag (semantic-current-tag))
+ (es (regexp-quote (srecode-template-get-escape-start)))
+ (ee (regexp-quote (srecode-template-get-escape-end)))
+ (start (or point (point)))
+ )
+ (when (and tag (semantic-tag-of-class-p tag 'function))
+ (if (string= es ee)
+ (save-excursion
+ (beginning-of-line)
+ (while (re-search-forward es start t 2))
+ (if (re-search-forward es start t)
+ ;; If there is a single, the the answer is yes.
+ t
+ ;; If there wasn't another, then the answer is no.
+ nil)
+ )
+ ;; ES And EE are not the same.
+ (save-excursion
+ (and (re-search-backward es (semantic-tag-start tag) t)
+ (>= (or (re-search-forward ee (semantic-tag-end tag) t)
+ ;; No end match means an incomplete macro.
+ start)
+ start)))
+ ))))
+
+(defun srecode-up-context-get-name (&optional point find-unmatched)
+ "Move up one context as for `semantic-up-context', and return the name.
+Moves point to the opening characters of the section macro text.
+If there is no upper context, return nil.
+Starts at POINT if provided.
+If FIND-UNMATCHED is specified as non-nil, then we are looking for an unmatched
+section."
+ (when point (goto-char (point)))
+ (let* ((tag (semantic-current-tag))
+ (es (regexp-quote (srecode-template-get-escape-start)))
+ (start (concat es "[#<]\\(\\w+\\)"))
+ (orig (point))
+ (name nil)
+ (res nil))
+ (when (semantic-tag-of-class-p tag 'function)
+ (while (and (not res)
+ (re-search-backward start (semantic-tag-start tag) t))
+ (when (save-excursion
+ (setq name (match-string 1))
+ (let ((endr (concat es "/" name)))
+ (if (re-search-forward endr (semantic-tag-end tag) t)
+ (< orig (point))
+ (if (not find-unmatched)
+ (error "Unmatched Section Template")
+ ;; We found what we want.
+ t))))
+ (setq res (point)))
+ )
+ ;; Restore in no result found.
+ (goto-char (or res orig))
+ name)))
+
+(define-mode-local-override semantic-up-context
+ srecode-template-mode (&optional point)
+ "Move up one context in the current code.
+Moves out one named section."
+ (not (srecode-up-context-get-name point)))
+
+(define-mode-local-override semantic-beginning-of-context
+ srecode-template-mode (&optional point)
+ "Move to the beginning of the current context.
+Moves the the beginning of one named section."
+ (if (semantic-up-context point)
+ t
+ (let ((es (regexp-quote (srecode-template-get-escape-start)))
+ (ee (regexp-quote (srecode-template-get-escape-end))))
+ (re-search-forward es) ;; move over the start chars.
+ (re-search-forward ee) ;; Move after the end chars.
+ nil)))
+
+(define-mode-local-override semantic-end-of-context
+ srecode-template-mode (&optional point)
+ "Move to the beginning of the current context.
+Moves the the beginning of one named section."
+ (let ((name (srecode-up-context-get-name point))
+ (tag (semantic-current-tag))
+ (es (regexp-quote (srecode-template-get-escape-start))))
+ (if (not name)
+ t
+ (unless (re-search-forward (concat es "/" name) (semantic-tag-end tag) t)
+ (error "Section %s has no end" name))
+ (goto-char (match-beginning 0))
+ nil)))
+
+(define-mode-local-override semantic-get-local-variables
+ srecode-template-mode (&optional point)
+ "Get local variables from an SRecode template."
+ (save-excursion
+ (when point (goto-char (point)))
+ (let* ((tag (semantic-current-tag))
+ (name (save-excursion
+ (srecode-up-context-get-name (point))))
+ (subdicts (semantic-tag-get-attribute tag :dictionaries))
+ (global nil)
+ )
+ (dolist (D subdicts)
+ (setq global (cons (semantic-tag-new-variable (car D) nil)
+ global)))
+ (if name
+ ;; Lookup any subdictionaries in TAG.
+ (let ((res nil))
+
+ (while (and (not res) subdicts)
+ ;; Find the subdictionary with the same name. Those variables
+ ;; are now local to this section.
+ (when (string= (car (car subdicts)) name)
+ (setq res (cdr (car subdicts))))
+ (setq subdicts (cdr subdicts)))
+ ;; Pre-pend our global vars.
+ (append global res))
+ ;; If we aren't in a subsection, just do the global variables
+ global
+ ))))
+
+(define-mode-local-override semantic-get-local-arguments
+ srecode-template-mode (&optional point)
+ "Get local arguments from an SRecode template."
+ (require 'srecode/insert)
+ (save-excursion
+ (when point (goto-char (point)))
+ (let* ((tag (semantic-current-tag))
+ (args (semantic-tag-function-arguments tag))
+ (argsym (mapcar 'intern args))
+ (argvars nil)
+ ;; Create a temporary dictionary in which the
+ ;; arguments can be resolved so we can extract
+ ;; the results.
+ (dict (srecode-create-dictionary t))
+ )
+ ;; Resolve args into our temp dictionary
+ (srecode-resolve-argument-list argsym dict)
+
+ (maphash
+ (lambda (key entry)
+ (setq argvars
+ (cons (semantic-tag-new-variable key nil entry)
+ argvars)))
+ (oref dict namehash))
+
+ argvars)))
+
+(define-mode-local-override semantic-ctxt-current-symbol
+ srecode-template-mode (&optional point)
+ "Return the current symbol under POINT.
+Return nil if point is not on/in a template macro."
+ (let ((macro (srecode-parse-this-macro point)))
+ (cdr macro))
+ )
+
+(defun srecode-parse-this-macro (&optional point)
+ "Return the current symbol under POINT.
+Return nil if point is not on/in a template macro.
+The first element is the key for the current macro, such as # for a
+section or ? for an ask variable."
+ (save-excursion
+ (if point (goto-char point))
+ (let ((tag (semantic-current-tag))
+ (es (regexp-quote (srecode-template-get-escape-start)))
+ (ee (regexp-quote (srecode-template-get-escape-end)))
+ (start (point))
+ (macrostart nil)
+ (raw nil)
+ )
+ (when (and tag (semantic-tag-of-class-p tag 'function)
+ (srecode-in-macro-p point)
+ (re-search-backward es (semantic-tag-start tag) t))
+ (setq macrostart (match-end 0))
+ (goto-char macrostart)
+ ;; We have a match
+ (when (not (re-search-forward ee (semantic-tag-end tag) t))
+ (goto-char start) ;; Pretend we are ok for completion
+ (set-match-data (list start start))
+ )
+
+ (if (> start (point))
+ ;; If our starting point is after the found point, that
+ ;; means we are not inside the macro. Retur nil.
+ nil
+ ;; We are inside the macro, extract the text so far.
+ (let* ((macroend (match-beginning 0))
+ (raw (buffer-substring-no-properties
+ macrostart macroend))
+ (STATE (srecode-compile-state "TMP"))
+ (inserter (condition-case nil
+ (srecode-compile-parse-inserter
+ raw STATE)
+ (error nil)))
+ )
+ (when inserter
+ (let ((base
+ (cons (oref inserter :object-name)
+ (if (and (slot-boundp inserter :secondname)
+ (oref inserter :secondname))
+ (split-string (oref inserter :secondname)
+ ":")
+ nil)))
+ (key (oref inserter key)))
+ (cond ((null key)
+ ;; A plain variable
+ (cons nil base))
+ (t
+ ;; A complex variable thingy.
+ (cons (format "%c" key)
+ base)))))
+ )
+ )))
+ ))
+
+(define-mode-local-override semantic-analyze-current-context
+ srecode-template-mode (point)
+ "Provide a Semantic analysis in SRecode template mode."
+ (let* ((context-return nil)
+ (prefixandbounds (semantic-ctxt-current-symbol-and-bounds))
+ (prefix (car prefixandbounds))
+ (bounds (nth 2 prefixandbounds))
+ (key (car (srecode-parse-this-macro (point))))
+ (prefixsym nil)
+ (prefix-var nil)
+ (prefix-context nil)
+ (prefix-function nil)
+ (prefixclass (semantic-ctxt-current-class-list))
+ (globalvar (semantic-find-tags-by-class 'variable (current-buffer)))
+ (argtype 'macro)
+ (scope (semantic-calculate-scope point))
+ )
+
+ (oset scope fullscope (append (oref scope localvar) globalvar))
+
+ (when prefix
+ ;; First, try to find the variable for the first
+ ;; entry in the prefix list.
+ (setq prefix-var (semantic-find-first-tag-by-name
+ (car prefix) (oref scope fullscope)))
+
+ (cond
+ ((and (or (not key) (string= key "?"))
+ (> (length prefix) 1))
+ ;; Variables can have lisp function names.
+ (with-mode-local emacs-lisp-mode
+ (let ((fcns (semanticdb-find-tags-by-name (car (last prefix)))))
+ (setq prefix-function (car (semanticdb-find-result-nth fcns 0)))
+ (setq argtype 'elispfcn)))
+ )
+ ((or (string= key "<") (string= key ">"))
+ ;; Includes have second args that is the template name.
+ (if (= (length prefix) 3)
+ (let ((contexts (semantic-find-tags-by-class
+ 'context (current-buffer))))
+ (setq prefix-context
+ (or (semantic-find-first-tag-by-name
+ (nth 1 prefix) contexts)
+ ;; Calculate from location
+ (semantic-tag
+ (symbol-name
+ (srecode-template-current-context))
+ 'context)))
+ (setq argtype 'template))
+ (setq prefix-context
+ ;; Calculate from location
+ (semantic-tag
+ (symbol-name (srecode-template-current-context))
+ 'context))
+ (setq argtype 'template)
+ )
+ ;; The last one?
+ (when (> (length prefix) 1)
+ (let ((toc (srecode-template-find-templates-of-context
+ (read (semantic-tag-name prefix-context))))
+ )
+ (setq prefix-function
+ (or (semantic-find-first-tag-by-name
+ (car (last prefix)) toc)
+ ;; Not in this buffer? Search the master
+ ;; templates list.
+ nil))
+ ))
+ )
+ )
+
+ (setq prefixsym
+ (cond ((= (length prefix) 3)
+ (list (or prefix-var (nth 0 prefix))
+ (or prefix-context (nth 1 prefix))
+ (or prefix-function (nth 2 prefix))))
+ ((= (length prefix) 2)
+ (list (or prefix-var (nth 0 prefix))
+ (or prefix-function (nth 1 prefix))))
+ ((= (length prefix) 1)
+ (list (or prefix-var (nth 0 prefix)))
+ )))
+
+ (setq context-return
+ (semantic-analyze-context-functionarg
+ "context-for-srecode"
+ :buffer (current-buffer)
+ :scope scope
+ :bounds bounds
+ :prefix (or prefixsym
+ prefix)
+ :prefixtypes nil
+ :prefixclass prefixclass
+ :errors nil
+ ;; Use the functionarg analyzer class so we
+ ;; can save the current key, and the index
+ ;; into the macro part we are completing on.
+ :function (list key)
+ :index (length prefix)
+ :argument (list argtype)
+ ))
+
+ context-return)))
+
+(define-mode-local-override semantic-analyze-possible-completions
+ srecode-template-mode (context)
+ "Return a list of possible completions based on NONTEXT."
+ (save-excursion
+ (set-buffer (oref context buffer))
+ (let* ((prefix (car (last (oref context :prefix))))
+ (prefixstr (cond ((stringp prefix)
+ prefix)
+ ((semantic-tag-p prefix)
+ (semantic-tag-name prefix))))
+; (completetext (cond ((semantic-tag-p prefix)
+; (semantic-tag-name prefix))
+; ((stringp prefix)
+; prefix)
+; ((stringp (car prefix))
+; (car prefix))))
+ (argtype (car (oref context :argument)))
+ (matches nil))
+
+ ;; Depending on what the analyzer is, we have different ways
+ ;; of creating completions.
+ (cond ((eq argtype 'template)
+ (setq matches (semantic-find-tags-for-completion
+ prefixstr (current-buffer)))
+ (setq matches (semantic-find-tags-by-class
+ 'function matches))
+ )
+ ((eq argtype 'elispfcn)
+ (with-mode-local emacs-lisp-mode
+ (setq matches (semanticdb-find-tags-for-completion
+ prefixstr))
+ (setq matches (semantic-find-tags-by-class
+ 'function matches))
+ )
+ )
+ ((eq argtype 'macro)
+ (let ((scope (oref context scope)))
+ (setq matches
+ (semantic-find-tags-for-completion
+ prefixstr (oref scope fullscope))))
+ )
+ )
+
+ matches)))
+
+
+
+;;; Utils
+;;
+(defun srecode-template-get-mode ()
+ "Get the supported major mode for this template file."
+ (let ((m (semantic-find-first-tag-by-name "mode" (current-buffer))))
+ (when m (read (semantic-tag-variable-default m)))))
+
+(defun srecode-template-get-escape-start ()
+ "Get the current escape_start characters."
+ (let ((es (semantic-find-first-tag-by-name "escape_start" (current-buffer)))
+ )
+ (if es (car (semantic-tag-get-attribute es :default-value))
+ "{{")))
+
+(defun srecode-template-get-escape-end ()
+ "Get the current escape_end characters."
+ (let ((ee (semantic-find-first-tag-by-name "escape_end" (current-buffer)))
+ )
+ (if ee (car (semantic-tag-get-attribute ee :default-value))
+ "}}")))
+
+(defun srecode-template-current-context (&optional point)
+ "Calculate the context encompassing POINT."
+ (save-excursion
+ (when point (goto-char (point)))
+ (let ((ct (semantic-current-tag)))
+ (when (not ct)
+ (setq ct (semantic-find-tag-by-overlay-prev)))
+
+ ;; Loop till we find the context.
+ (while (and ct (not (semantic-tag-of-class-p ct 'context)))
+ (setq ct (semantic-find-tag-by-overlay-prev
+ (semantic-tag-start ct))))
+
+ (if ct
+ (read (semantic-tag-name ct))
+ 'declaration))))
+
+(defun srecode-template-find-templates-of-context (context &optional buffer)
+ "Find all the templates belonging to a particular CONTEXT.
+When optional BUFFER is provided, search that buffer."
+ (save-excursion
+ (when buffer (set-buffer buffer))
+ (let ((tags (semantic-fetch-available-tags))
+ (cc 'declaration)
+ (scan nil)
+ (ans nil))
+
+ (when (eq cc context)
+ (setq scan t))
+
+ (dolist (T tags)
+ ;; Handle contexts
+ (when (semantic-tag-of-class-p T 'context)
+ (setq cc (read (semantic-tag-name T)))
+ (when (eq cc context)
+ (setq scan t)))
+
+ ;; Scan
+ (when (and scan (semantic-tag-of-class-p T 'function))
+ (setq ans (cons T ans)))
+ )
+
+ (nreverse ans))))
+
+(provide 'srecode/srt-mode)
+
+;; The autoloads in this file must go into the global loaddefs.el, not
+;; the srecode one, so that srecode-template-mode can be called from
+;; auto-mode-alist.
+
+;; Local variables:
+;; generated-autoload-load-name: "srecode/srt-mode"
+;; End:
+
+;;; srecode/srt-mode.el ends here
Index: cedet/srecode/srt-wy.el
===================================================================
RCS file: cedet/srecode/srt-wy.el
diff -N cedet/srecode/srt-wy.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/srecode/srt-wy.el 28 Sep 2009 15:15:12 -0000 1.2
@@ -0,0 +1,277 @@
+;;; srecode/srt-wy.el --- Generated parser support file
+
+;; Copyright (C) 2005, 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Generated from srecode-template.wy in the CEDET repository.
+
+;;; Code:
+
+(require 'semantic/lex)
+
+
+;;; Prologue
+;;
+
+;;; Declarations
+;;
+(defconst srecode-template-wy--keyword-table
+ (semantic-lex-make-keyword-table
+ '(("set" . SET)
+ ("show" . SHOW)
+ ("macro" . MACRO)
+ ("context" . CONTEXT)
+ ("template" . TEMPLATE)
+ ("sectiondictionary" . SECTIONDICTIONARY)
+ ("prompt" . PROMPT)
+ ("default" . DEFAULT)
+ ("defaultmacro" . DEFAULTMACRO)
+ ("read" . READ)
+ ("bind" . BIND))
+ '(("bind" summary "bind \"<letter>\"")
+ ("read" summary "prompt <symbol> \"Describe Symbol: \" [default[macro]
<lispsym>|\"valuetext\"] [read <lispsym>]")
+ ("defaultmacro" summary "prompt <symbol> \"Describe Symbol: \"
[default[macro] <lispsym>|\"valuetext\"] [read <lispsym>]")
+ ("default" summary "prompt <symbol> \"Describe Symbol: \" [default[macro]
<lispsym>|\"valuetext\"] [read <lispsym>]")
+ ("prompt" summary "prompt <symbol> \"Describe Symbol: \" [default[macro]
<lispsym>|\"valuetext\"] [read <lispsym>]")
+ ("sectiondictionary" summary "sectiondictionary <name>\\n <dictionary
entries>")
+ ("template" summary "template <name>\\n <template definition>")
+ ("context" summary "context <name>")
+ ("macro" summary "... macro \"string\" ...")
+ ("show" summary "show <name> ; to show a section")
+ ("set" summary "set <name> <value>")))
+ "Table of language keywords.")
+
+(defconst srecode-template-wy--token-table
+ (semantic-lex-make-type-table
+ '(("number"
+ (number))
+ ("string"
+ (string))
+ ("symbol"
+ (symbol))
+ ("property"
+ (property))
+ ("separator"
+ (TEMPLATE_BLOCK . "^----"))
+ ("newline"
+ (newline)))
+ '(("number" :declared t)
+ ("string" :declared t)
+ ("symbol" :declared t)
+ ("property" :declared t)
+ ("newline" :declared t)
+ ("punctuation" syntax "\\s.+")
+ ("punctuation" :declared t)
+ ("keyword" :declared t)))
+ "Table of lexical tokens.")
+
+(defconst srecode-template-wy--parse-table
+ (progn
+ (eval-when-compile
+ (require 'semantic/wisent/comp))
+ (wisent-compile-grammar
+ '((SET SHOW MACRO CONTEXT TEMPLATE SECTIONDICTIONARY PROMPT DEFAULT
DEFAULTMACRO READ BIND newline TEMPLATE_BLOCK property symbol string number)
+ nil
+ (template_file
+ ((newline)
+ nil)
+ ((context))
+ ((prompt))
+ ((variable))
+ ((template)))
+ (context
+ ((CONTEXT symbol newline)
+ (wisent-raw-tag
+ (semantic-tag $2 'context))))
+ (prompt
+ ((PROMPT symbol string opt-default-fcn opt-read-fcn newline)
+ (wisent-raw-tag
+ (semantic-tag $2 'prompt :text
+ (read $3)
+ :default $4 :read $5))))
+ (opt-default-fcn
+ ((DEFAULT symbol)
+ (progn
+ (read $2)))
+ ((DEFAULT string)
+ (progn
+ (read $2)))
+ ((DEFAULTMACRO string)
+ (progn
+ (cons 'macro
+ (read $2))))
+ (nil nil))
+ (opt-read-fcn
+ ((READ symbol)
+ (progn
+ (read $2)))
+ (nil nil))
+ (variable
+ ((SET symbol insertable-string-list newline)
+ (wisent-raw-tag
+ (semantic-tag-new-variable $2 nil $3)))
+ ((SHOW symbol newline)
+ (wisent-raw-tag
+ (semantic-tag-new-variable $2 nil t))))
+ (insertable-string-list
+ ((insertable-string)
+ (list $1))
+ ((insertable-string-list insertable-string)
+ (append $1
+ (list $2))))
+ (insertable-string
+ ((string)
+ (read $1))
+ ((MACRO string)
+ (cons 'macro
+ (read $2))))
+ (template
+ ((TEMPLATE templatename opt-dynamic-arguments newline opt-string
opt-section-dictionaries TEMPLATE_BLOCK newline opt-bind)
+ (wisent-raw-tag
+ (semantic-tag-new-function $2 nil $3 :documentation $5 :code $7
:dictionaries $6 :binding $9))))
+ (templatename
+ ((symbol))
+ ((PROMPT))
+ ((CONTEXT))
+ ((TEMPLATE))
+ ((DEFAULT))
+ ((MACRO))
+ ((DEFAULTMACRO))
+ ((READ))
+ ((SET)))
+ (opt-dynamic-arguments
+ ((property opt-dynamic-arguments)
+ (cons $1 $2))
+ (nil nil))
+ (opt-string
+ ((string newline)
+ (read $1))
+ (nil nil))
+ (opt-section-dictionaries
+ (nil nil)
+ ((section-dictionary-list)))
+ (section-dictionary-list
+ ((one-section-dictionary)
+ (list $1))
+ ((section-dictionary-list one-section-dictionary)
+ (append $1
+ (list $2))))
+ (one-section-dictionary
+ ((SECTIONDICTIONARY string newline variable-list)
+ (cons
+ (read $2)
+ $4)))
+ (variable-list
+ ((variable)
+ (wisent-cook-tag $1))
+ ((variable-list variable)
+ (append $1
+ (wisent-cook-tag $2))))
+ (opt-bind
+ ((BIND string newline)
+ (read $2))
+ (nil nil)))
+ '(template_file)))
+ "Parser table.")
+
+(defun srecode-template-wy--install-parser ()
+ "Setup the Semantic Parser."
+ (semantic-install-function-overrides
+ '((parse-stream . wisent-parse-stream)))
+ (setq semantic-parser-name "LALR"
+ semantic--parse-table srecode-template-wy--parse-table
+ semantic-debug-parser-source "srecode-template.wy"
+ semantic-flex-keywords-obarray srecode-template-wy--keyword-table
+ semantic-lex-types-obarray srecode-template-wy--token-table)
+ ;; Collect unmatched syntax lexical tokens
+ (semantic-make-local-hook 'wisent-discarding-token-functions)
+ (add-hook 'wisent-discarding-token-functions
+ 'wisent-collect-unmatched-syntax nil t))
+
+
+;;; Analyzers
+;;
+(define-lex-keyword-type-analyzer
srecode-template-wy--<keyword>-keyword-analyzer
+ "keyword analyzer for <keyword> tokens."
+ "\\(\\sw\\|\\s_\\)+")
+
+(define-lex-regex-type-analyzer srecode-template-wy--<symbol>-regexp-analyzer
+ "regexp analyzer for <symbol> tokens."
+ "\\(\\sw\\|\\s_\\)+"
+ nil
+ 'symbol)
+
+(define-lex-sexp-type-analyzer srecode-template-wy--<string>-sexp-analyzer
+ "sexp analyzer for <string> tokens."
+ "\\s\""
+ 'string)
+
+(define-lex-regex-type-analyzer srecode-template-wy--<number>-regexp-analyzer
+ "regexp analyzer for <number> tokens."
+ semantic-lex-number-expression
+ nil
+ 'number)
+
+(define-lex-string-type-analyzer
srecode-template-wy--<punctuation>-string-analyzer
+ "string analyzer for <punctuation> tokens."
+ "\\s.+"
+ nil
+ 'punctuation)
+
+
+;;; Epilogue
+;;
+(define-lex-simple-regex-analyzer srecode-template-property-analyzer
+ "Detect and create a dynamic argument properties."
+ ":\\(\\w\\|\\s_\\)*" 'property 0)
+
+(define-lex-regex-analyzer srecode-template-separator-block
+ "Detect and create a template quote block."
+ "^----\n"
+ (semantic-lex-push-token
+ (semantic-lex-token
+ 'TEMPLATE_BLOCK
+ (match-end 0)
+ (semantic-lex-unterminated-syntax-protection 'TEMPLATE_BLOCK
+ (goto-char (match-end 0))
+ (re-search-forward "^----$")
+ (match-beginning 0))))
+ (setq semantic-lex-end-point (point)))
+
+
+(define-lex wisent-srecode-template-lexer
+ "Lexical analyzer that handles SRecode Template buffers.
+It ignores whitespace, newlines and comments."
+ semantic-lex-newline
+ semantic-lex-ignore-whitespace
+ semantic-lex-ignore-newline
+ semantic-lex-ignore-comments
+ srecode-template-separator-block
+ srecode-template-wy--<keyword>-keyword-analyzer
+ srecode-template-property-analyzer
+ srecode-template-wy--<symbol>-regexp-analyzer
+ srecode-template-wy--<number>-regexp-analyzer
+ srecode-template-wy--<string>-sexp-analyzer
+ srecode-template-wy--<punctuation>-string-analyzer
+ semantic-lex-default-action
+ )
+
+(provide 'srecode/srt-wy)
+
+;;; srecode/srt-wy.el ends here
Index: cedet/srecode/srt.el
===================================================================
RCS file: cedet/srecode/srt.el
diff -N cedet/srecode/srt.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/srecode/srt.el 28 Sep 2009 15:15:12 -0000 1.2
@@ -0,0 +1,106 @@
+;;; srecode/srt.el --- argument handlers for SRT files
+
+;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Filters for SRT files, the Semantic Recoder template files.
+
+;;; Code:
+
+(require 'eieio)
+(require 'srecode/dictionary)
+(require 'srecode/insert)
+
+(defvar srecode-read-variable-name-history nil
+ "History for `srecode-read-variable-name'.")
+
+(defun srecode-read-variable-name (prompt &optional initial hist default)
+ "Read in the name of a declaired variable in the current SRT file.
+PROMPT is the prompt to use.
+INITIAL is the initial string.
+HIST is the history value, otherwise `srecode-read-variable-name-history'
+ is used.
+DEFAULT is the default if RET is hit."
+ (let* ((newdict (srecode-create-dictionary))
+ (currfcn (semantic-current-tag))
+ )
+ (srecode-resolve-argument-list
+ (mapcar 'read
+ (semantic-tag-get-attribute currfcn :arguments))
+ newdict)
+
+ (with-slots (namehash) newdict
+ (completing-read prompt namehash nil nil initial
+ (or hist 'srecode-read-variable-name-history)
+ default))
+ ))
+
+(defvar srecode-read-major-mode-history nil
+ "History for `srecode-read-variable-name'.")
+
+(defun srecode-read-major-mode-name (prompt &optional initial hist default)
+ "Read in the name of a desired `major-mode'.
+PROMPT is the prompt to use.
+INITIAL is the initial string.
+HIST is the history value, otherwise `srecode-read-variable-name-history'
+ is used.
+DEFAULT is the default if RET is hit."
+ (completing-read prompt obarray
+ (lambda (s) (string-match "-mode$" (symbol-name s)))
+ nil initial (or hist 'srecode-read-major-mode-history))
+ )
+
+(defun srecode-semantic-handle-:srt (dict)
+ "Add macros into the dictionary DICT based on the current SRT file.
+Adds the following:
+ESCAPE_START - This files value of escape_start
+ESCAPE_END - This files value of escape_end
+MODE - The mode of this buffer. If not declared yet, guess."
+ (let* ((es (semantic-find-first-tag-by-name "escape_start" (current-buffer)))
+ (ee (semantic-find-first-tag-by-name "escape_end" (current-buffer)))
+ (mode-var (semantic-find-first-tag-by-name "mode" (current-buffer)))
+ (mode (if mode-var
+ (semantic-tag-variable-default mode-var)
+ nil))
+ )
+ (srecode-dictionary-set-value dict "ESCAPE_START"
+ (if es
+ (car (semantic-tag-variable-default es))
+ "{{"))
+ (srecode-dictionary-set-value dict "ESCAPE_END"
+ (if ee
+ (car (semantic-tag-variable-default ee))
+ "}}"))
+ (when (not mode)
+ (let* ((fname (file-name-nondirectory
+ (buffer-file-name (current-buffer))))
+ )
+ (when (string-match "-\\(\\w+\\)\\.srt" fname)
+ (setq mode (concat (match-string 1 fname) "-mode")))))
+
+ (when mode
+ (srecode-dictionary-set-value dict "MAJORMODE" mode))
+
+ ))
+
+(provide 'srecode/srt)
+
+;;; srecode/srt.el ends here
Index: cedet/srecode/table.el
===================================================================
RCS file: cedet/srecode/table.el
diff -N cedet/srecode/table.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/srecode/table.el 28 Sep 2009 15:15:12 -0000 1.2
@@ -0,0 +1,248 @@
+;;; srecode/table.el --- Tables of Semantic Recoders
+
+;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Semantic Recoder tables manage lists of templates and the major
+;; modes they are associated with.
+;;
+
+(require 'eieio)
+(require 'eieio-base)
+(require 'mode-local)
+(require 'srecode)
+
+(declare-function srecode-load-tables-for-mode "srecode/find")
+
+;;; Code:
+
+;;; TEMPLATE TABLE
+;;
+(defclass srecode-template-table ()
+ (;;
+ ;; Raw file tracking
+ ;;
+ (file :initarg :file
+ :type string
+ :documentation
+ "The name of the file this table was built from.")
+ (filesize :initarg :filesize
+ :type number
+ :documentation
+ "The size of the file when it was parsed.")
+ (filedate :initarg :filedate
+ :type cons
+ :documentation
+ "Date from the inode of the file when it was last edited.
+Format is from the `file-attributes' function.")
+ (major-mode :initarg :major-mode
+ :documentation
+ "The major mode this table of templates is associated with.")
+ ;;
+ ;; Template file sorting data
+ ;;
+ (application :initarg :application
+ :type symbol
+ :documentation
+ "Tracks the name of the application these templates belong to.
+If this is nil, then this template table belongs to a set of generic
+templates that can be used with no additional dictionary values.
+When it is non-nil, it is assumed the template macros need specialized
+Emacs Lisp code to fill in the dictoinary.")
+ (priority :initarg :priority
+ :type number
+ :documentation
+ "For file of this Major Mode, what is the priority of this file.
+When there are multiple template files with similar names, templates with
+the highest priority are scanned last, allowing them to override values in
+previous template files.")
+ ;;
+ ;; Parsed Data from the template file
+ ;;
+ (templates :initarg :templates
+ :type list
+ :documentation
+ "The list of templates compiled into this table.")
+ (namehash :initarg :namehash
+ :documentation
+ "Hash table containing the names of all the templates.")
+ (contexthash :initarg :contexthash
+ :documentation
+ "")
+ (variables :initarg :variables
+ :documentation
+ "AList of variables.
+These variables are used to initialize dictionaries.")
+ )
+ "Semantic recoder template table.
+A Table contains all templates from a single .srt file.
+Tracks various lookup hash tables.")
+
+;;; MODE TABLE
+;;
+(defvar srecode-mode-table-list nil
+ "List of all the SRecode mode table classes that have been built.")
+
+(defclass srecode-mode-table (eieio-instance-tracker)
+ ((tracking-symbol :initform 'srecode-mode-table-list)
+ (major-mode :initarg :major-mode
+ :documentation
+ "Table of template tables for this major-mode.")
+ (tables :initarg :tables
+ :documentation
+ "All the tables that have been defined for this major mode.")
+ )
+ "Track template tables for a particular major mode.
+Tracks all the template-tables for a specific major mode.")
+
+(defun srecode-get-mode-table (mode)
+ "Get the SRecoder mode table for the major mode MODE.
+Optional argument SOFT indicates to not make a new one if a table
+was not found."
+ (let ((ans nil))
+ (while (and (not ans) mode)
+ (setq ans (eieio-instance-tracker-find
+ mode 'major-mode 'srecode-mode-table-list)
+ mode (get-mode-local-parent mode)))
+ ans))
+
+(defun srecode-make-mode-table (mode)
+ "Get the SRecoder mode table for the major mode MODE."
+ (let ((old (eieio-instance-tracker-find
+ mode 'major-mode 'srecode-mode-table-list)))
+ (if old
+ old
+ (let* ((ms (if (stringp mode) mode (symbol-name mode)))
+ (new (srecode-mode-table ms
+ :major-mode mode
+ :tables nil)))
+ ;; Save this new mode table in that mode's variable.
+ (eval `(setq-mode-local ,mode srecode-table ,new))
+
+ new))))
+
+(defmethod srecode-mode-table-find ((mt srecode-mode-table) file)
+ "Look in the mode table MT for a template table from FILE.
+Return nil if there was none."
+ (object-assoc file 'file (oref mt tables)))
+
+(defun srecode-mode-table-new (mode file &rest init)
+ "Create a new template table for MODE in FILE.
+INIT are the initialization parametrs for the new template table."
+ (let* ((mt (srecode-make-mode-table mode))
+ (old (srecode-mode-table-find mt file))
+ (attr (file-attributes file))
+ (new (apply 'srecode-template-table
+ (file-name-nondirectory file)
+ :file file
+ :filesize (nth 7 attr)
+ :filedate (nth 5 attr)
+ :major-mode mode
+ init
+ )))
+ ;; Whack the old table.
+ (when old (object-remove-from-list mt 'tables old))
+ ;; Add the new table
+ (object-add-to-list mt 'tables new)
+ ;; Sort the list in reverse order. When other routines
+ ;; go front-to-back, the highest priority items are put
+ ;; into the search table first, allowing lower priority items
+ ;; to be the items found in the search table.
+ (object-sort-list mt 'tables (lambda (a b)
+ (> (oref a :priority)
+ (oref b :priority))))
+ ;; Return it.
+ new))
+
+(defun object-sort-list (object slot predicate)
+ "Sort the items in OBJECT's SLOT.
+Use PREDICATE is the same as for the `sort' function."
+ (when (slot-boundp object slot)
+ (when (listp (eieio-oref object slot))
+ (eieio-oset object slot (sort (eieio-oref object slot) predicate)))))
+
+;;; DEBUG
+;;
+;; Dump out information about the current srecoder compiled templates.
+;;
+(defun srecode-dump-templates (mode)
+ "Dump a list of the current templates for MODE."
+ (interactive "sMode: ")
+ (require 'srecode/find)
+ (let ((modesym (cond ((string= mode "")
+ major-mode)
+ ((not (string-match "-mode" mode))
+ (intern-soft (concat mode "-mode")))
+ (t
+ (intern-soft mode)))))
+ (srecode-load-tables-for-mode modesym)
+ (let ((tmp (srecode-get-mode-table modesym))
+ )
+ (if (not tmp)
+ (error "No table found for mode %S" modesym))
+ (with-output-to-temp-buffer "*SRECODE DUMP*"
+ (srecode-dump tmp))
+ )))
+
+(defmethod srecode-dump ((tab srecode-mode-table))
+ "Dump the contents of the SRecode mode table TAB."
+ (princ "MODE TABLE FOR ")
+ (princ (oref tab :major-mode))
+ (princ "\n--------------------------------------------\n\nNumber of tables:
")
+ (let ((subtab (oref tab :tables)))
+ (princ (length subtab))
+ (princ "\n\n")
+ (while subtab
+ (srecode-dump (car subtab))
+ (setq subtab (cdr subtab)))
+ ))
+
+(defmethod srecode-dump ((tab srecode-template-table))
+ "Dump the contents of the SRecode template table TAB."
+ (princ "Template Table for ")
+ (princ (object-name-string tab))
+ (princ "\nPriority: ")
+ (prin1 (oref tab :priority))
+ (when (oref tab :application)
+ (princ "\nApplication: ")
+ (princ (oref tab :application)))
+ (princ "\n\nVariables:\n")
+ (let ((vars (oref tab variables)))
+ (while vars
+ (princ (car (car vars)))
+ (princ "\t")
+ (if (< (length (car (car vars))) 9)
+ (princ "\t"))
+ (prin1 (cdr (car vars)))
+ (princ "\n")
+ (setq vars (cdr vars))))
+ (princ "\n\nTemplates:\n")
+ (let ((temp (oref tab templates)))
+ (while temp
+ (srecode-dump (car temp))
+ (setq temp (cdr temp))))
+ )
+
+
+(provide 'srecode/table)
+
+;;; srecode/table.el ends here
+
Index: cedet/srecode/template.el
===================================================================
RCS file: cedet/srecode/template.el
diff -N cedet/srecode/template.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/srecode/template.el 28 Sep 2009 15:15:12 -0000 1.2
@@ -0,0 +1,69 @@
+;;; srecode-template.el --- SRecoder template language parser support.
+
+;;; Copyright (C) 2005, 2007, 2008 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Parser setup for the semantic recoder template parser.
+
+;;; Code:
+(require 'semantic)
+(require 'semantic/ctxt)
+(require 'semantic/wisent)
+(require 'srecode/srt-wy)
+
+(define-mode-local-override semantic-tag-components
+ srecode-template-mode (tag)
+ "Return sectiondictionary tags."
+ (when (semantic-tag-of-class-p tag 'function)
+ (let ((dicts (semantic-tag-get-attribute tag :dictionaries))
+ (ans nil))
+ (while dicts
+ (setq ans (append ans (cdr (car dicts))))
+ (setq dicts (cdr dicts)))
+ ans)
+ ))
+
+(defun srecode-template-setup-parser ()
+ "Setup buffer for parse."
+ (srecode-template-wy--install-parser)
+
+ (setq
+ ;; Lexical Analysis
+ semantic-lex-analyzer 'wisent-srecode-template-lexer
+ ;; Parsing
+ ;; Environment
+ semantic-imenu-summary-function 'semantic-format-tag-name
+ imenu-create-index-function 'semantic-create-imenu-index
+ semantic-command-separation-character "\n"
+ semantic-lex-comment-regex ";;"
+ ;; Speedbar
+ semantic-symbol->name-assoc-list
+ '((function . "Template")
+ (variable . "Variable")
+ )
+ ;; Navigation
+ senator-step-at-tag-classes '(function variable)
+ ))
+
+;;;;###autoload
+(add-hook 'srecode-template-mode-hook 'srecode-template-setup-parser)
+
+(provide 'srecode/template)
+
+;;; srecode/template.el ends here
Index: cedet/srecode/texi.el
===================================================================
RCS file: cedet/srecode/texi.el
diff -N cedet/srecode/texi.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ cedet/srecode/texi.el 28 Sep 2009 15:15:12 -0000 1.2
@@ -0,0 +1,282 @@
+;;; srecode-texi.el --- Srecode texinfo support.
+
+;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Texinfo semantic recoder support.
+;;
+;; Contains some handlers, and a few simple texinfo srecoder applications.
+
+(require 'semantic)
+(require 'semantic/texi)
+(require 'srecode/semantic)
+
+;;; Code:
+
+(defun srecode-texi-add-menu (newnode)
+ "Add an item into the current menu. Add @node statements as well.
+Argument NEWNODE is the name of the new node."
+ (interactive "sName of new node: ")
+ (srecode-load-tables-for-mode major-mode)
+ (semantic-fetch-tags)
+ (let ((currnode (reverse (semantic-find-tag-by-overlay)))
+ (nodebounds nil))
+ (when (not currnode)
+ (error "Cannot find node to put menu item into"))
+ (setq currnode (car currnode))
+ (setq nodebounds (semantic-tag-texi-section-text-bounds currnode))
+ ;; Step 1:
+ ;; Limit search within this node.
+ ;; Step 2:
+ ;; Find the menu. If there isn't one, add one to the end.
+ ;; Step 3:
+ ;; Add new item to end of menu list.
+ ;; Step 4:
+ ;; Find correct node new item should show up after, and stick
+ ;; the new node there.
+ (if (string= (semantic-texi-current-environment) "menu")
+ ;; We are already in a menu, so insert the new item right here.
+ (beginning-of-line)
+ ;; Else, try to find a menu item to append to.
+ (goto-char (car nodebounds))
+ (if (not (re-search-forward "address@hidden" (car (cdr nodebounds)) t))
+ (progn
+ (goto-char (car (cdr nodebounds)))
+ (if (not (y-or-n-p "Add menu here? "))
+ (error "Abort"))
+ (srecode-insert "declaration:menu"))
+ ;; Else, find the end
+ (re-search-forward "@end menu")
+ (beginning-of-line)))
+ ;; At this point, we are in a menu... or not.
+ ;; If we are, do stuff, else error.
+ (when (string= (semantic-texi-current-environment) "menu")
+ (let ((menuname newnode)
+ (returnpoint nil))
+ (srecode-insert "declaration:menuitem" "NAME" menuname)
+ (set-mark (point))
+ (setq returnpoint (make-marker))
+ ;; Update the bound since we added text
+ (setq nodebounds (semantic-tag-texi-section-text-bounds currnode))
+ (beginning-of-line)
+ (forward-char -1)
+ (beginning-of-line)
+ (let ((end nil))
+ (if (not (looking-at "\\* \\([^:]+\\):"))
+ (setq end (car (cdr nodebounds)))
+ (let* ((nname (match-string 1))
+ (tag
+ (semantic-deep-find-tags-by-name nname (current-buffer))))
+ (when tag
+ (setq end (semantic-tag-end (car tag))))
+ ))
+ (when (not end)
+ (goto-char returnpoint)
+ (error "Could not find location for new node" ))
+ (when end
+ (goto-char end)
+ (when (bolp) (forward-char -1))
+ (insert "\n")
+ (if (eq (semantic-current-tag) currnode)
+ (srecode-insert "declaration:subnode" "NAME" menuname)
+ (srecode-insert "declaration:node" "NAME" menuname))
+ )
+ )))
+ ))
+
+;;;###autoload
+(defun srecode-semantic-handle-:texi (dict)
+ "Add macros into the dictionary DICT based on the current texinfo file.
+Adds the following:
+ LEVEL - chapter, section, subsection, etc
+ NEXTLEVEL - One below level"
+
+ ;; LEVEL and NEXTLEVEL calculation
+ (semantic-fetch-tags)
+ (let ((tags (reverse (semantic-find-tag-by-overlay)))
+ (level nil))
+ (while (and tags (not (semantic-tag-of-class-p (car tags) 'section)))
+ (setq tags (cdr tags)))
+ (when tags
+ (save-excursion
+ (goto-char (semantic-tag-start (car tags)))
+ (when (looking-at "@node")
+ (forward-line 1)
+ (beginning-of-line))
+ (when (looking-at "@\\(\\w+\\)")
+ (setq level (match-string 1))
+ )))
+ (srecode-dictionary-set-value dict "LEVEL" (or level "chapter"))
+ (let ((nl (assoc level '( ( nil . "top" )
+ ("top" . "chapter")
+ ("chapter" . "section")
+ ("section" . "subsection")
+ ("subsection" . "subsubsection")
+ ("subsubsection" . "subsubsection")
+ ))))
+ (srecode-dictionary-set-value dict "NEXTLEVEL" (cdr nl))))
+ )
+
+;;;###autoload
+(defun srecode-semantic-handle-:texitag (dict)
+ "Add macros into the dictionary DICT based on the current :tag file.
+Adds the following:
+ TAGDOC - Texinfo formatted doc string for :tag."
+
+ ;; If we also have a TAG, what is the doc?
+ (let ((tag (srecode-dictionary-lookup-name dict "TAG"))
+ (doc nil)
+ )
+
+ ;; If the user didn't apply :tag, then do so now.
+ (when (not tag)
+ (srecode-semantic-handle-:tag dict))
+
+ (setq tag (srecode-dictionary-lookup-name dict "TAG"))
+
+ (when (not tag)
+ (error "No tag to insert for :texitag template argument"))
+
+ ;; Extract the tag out of the compound object.
+ (setq tag (oref tag :prime))
+
+ ;; Extract the doc string
+ (setq doc (semantic-documentation-for-tag tag))
+
+ (when doc
+ (srecode-dictionary-set-value dict "TAGDOC"
+ (srecode-texi-massage-to-texinfo
+ tag (semantic-tag-buffer tag)
+ doc)))
+ ))
+
+;;; OVERRIDES
+;;
+;; Override some semantic and srecode features with texi specific
+;; versions.
+
+(define-mode-local-override semantic-insert-foreign-tag
+ texinfo-mode (foreign-tag)
+ "Insert TAG from a foreign buffer in TAGFILE.
+Assume TAGFILE is a source buffer, and create a documentation
+thingy from it using the `document' tool."
+ (let ((srecode-semantic-selected-tag foreign-tag))
+ ;; @todo - choose of the many types of tags to insert,
+ ;; or put all that logic into srecode.
+ (srecode-insert "declaration:function")))
+
+
+
+;;; Texinfo mangling.
+
+(define-overloadable-function srecode-texi-texify-docstring
+ (docstring)
+ "Texify the doc string DOCSTRING.
+Takes plain text formatting that may exist, and converts it to
+using TeXinfo formatting.")
+
+(defun srecode-texi-texify-docstring-default (docstring)
+ "Texify the doc string DOCSTRING.
+Takes a few very generic guesses as to what the formatting is."
+ (let ((case-fold-search nil)
+ (start 0))
+ (while (string-match
+ "\\(^\\|[^{]\\)\\<\\([A-Z0-9_-]+\\)\\>\\($\\|[^}]\\)"
+ docstring start)
+ (let ((ms (match-string 2 docstring)))
+ ;(when (eq mode 'emacs-lisp-mode)
+ ; (setq ms (downcase ms)))
+
+ (when (not (or (string= ms "A")
+ (string= ms "a")
+ ))
+ (setq docstring (concat (substring docstring 0 (match-beginning 2))
+ "@var{"
+ ms
+ "}"
+ (substring docstring (match-end 2))))))
+ (setq start (match-end 2)))
+ ;; Return our modified doc string.
+ docstring))
+
+(defun srecode-texi-massage-to-texinfo (tag buffer string)
+ "Massage TAG's documentation from BUFFER as STRING.
+This is to take advantage of TeXinfo's markup symbols."
+ (save-excursion
+ (if buffer
+ (progn (set-buffer buffer)
+ (srecode-texi-texify-docstring string))
+ ;; Else, no buffer, so lets do something else
+ (with-mode-local texinfo-mode
+ (srecode-texi-texify-docstring string)))))
+
+(define-mode-local-override srecode-texi-texify-docstring emacs-lisp-mode
+ (string)
+ "Take STRING, (a normal doc string), and convert it into a texinfo string.
+For instances where CLASS is the class being referenced, do not Xref
+that class.
+
+ `function' => @dfn{function}
+ `variable' => @code{variable}
+ `class' => @code{class} @xref{class}
+ `unknown' => @code{unknonwn}
+ \"text\" => ``text''
+ 'quoteme => @code{quoteme}
+ non-nil => address@hidden
+ t => @code{t}
+ :tag => @code{:tag}
+ [ stuff ] => @code{[ stuff ]}
+ Key => @kbd{Key} (key is C\\-h, M\\-h, SPC, RET, TAB and the like)
+ ... => @dots{}"
+ (while (string-match "`\\([-a-zA-Z0-9<>.]+\\)'" string)
+ (let* ((vs (substring string (match-beginning 1) (match-end 1)))
+ (v (intern-soft vs)))
+ (setq string
+ (concat
+ (replace-match (concat
+ (if (fboundp v)
+ "@dfn{" "@code{")
+ vs "}")
+ nil t string)))))
+ (while (string-match "\\(
\\|^\\)\\(nil\\|t\\|'[-a-zA-Z0-9]+\\|:[-a-zA-Z0-9]+\\)\\([. ,]\\|$\\)" string)
+ (setq string (replace-match "@code{\\2}" t nil string 2)))
+ (while (string-match "\\( \\|^\\)\\(\\(non-\\)\\(nil\\)\\)\\([. ,]\\|$\\)"
string)
+ (setq string (replace-match "address@hidden" t nil string 2)))
+ (while (string-match "\\( \\|^\\)\\(\\[[^]]+\\]\\)\\( \\|$\\)" string)
+ (setq string (replace-match "@code{\\2}" t nil string 2)))
+ (while (string-match "\\( \\|^\\)\\(\\(\\(C-\\|M-\\|S-\\)+\\([^
\t\n]\\|RET\\|SPC\\|TAB\\)\\)\\|\\(RET\\|SPC\\|TAB\\)\\)\\( \\|\\s.\\|$\\)"
string)
+ (setq string (replace-match "@kbd{\\2}" t nil string 2)))
+ (while (string-match "\"\\(.+\\)\"" string)
+ (setq string (replace-match "``\\1''" t nil string 0)))
+ (while (string-match "\\.\\.\\." string)
+ (setq string (replace-match "@dots{}" t nil string 0)))
+ ;; Also do base docstring type.
+ (srecode-texi-texify-docstring-default string))
+
+(provide 'srecode/texi)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: srecode/loaddefs
+;; generated-autoload-load-name: "srecode/texi"
+;; End:
+
+;;; srecode/texi.el ends here
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] emacs/lisp ChangeLog cedet/cedet.el cedet/ede.e...,
Chong Yidong <=