summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorChong Yidong <cyd@stupidchicken.com>2009-09-27 21:35:46 +0000
committerChong Yidong <cyd@stupidchicken.com>2009-09-27 21:35:46 +0000
commita2095e2edba95e01f3be50ead7cc4b1c53bd40f3 (patch)
tree150cb59355fd83a2295dbaf07dec1f1a123a5f6f
parent715f35a55d79aa04ed337f601082079d0b5a357f (diff)
downloademacs-a2095e2edba95e01f3be50ead7cc4b1c53bd40f3.tar.gz
* cedet/ede/system.el (ede-upload-html-documentation)old-branches/cedet-branch
(ede-upload-distribution, ede-edit-web-page) (ede-web-browse-home): Autoload. * cedet/ede/proj-elisp.el: Add autoload for semantic-ede-proj-target-grammar. * cedet/semantic.el (navigate-menu): Show menu items only if semantic-mode is enabled. * cedet/ede.el: Remove comments. * cedet/cedet.el (cedet-menu-map): Minor doc fix. * cedet/semantic/grammar.el: * cedet/semantic/grammar-wy.el: * cedet/semantic/ede-grammar.el: New files. * cedet/semantic/db-mode.el (global-semanticdb-minor-mode): Define using define-minor-mode, so that the usual mode variable exists.
Diffstat
-rw-r--r--lisp/ChangeLog23
-rw-r--r--lisp/cedet/cedet.el4
-rw-r--r--lisp/cedet/ede.el12
-rw-r--r--lisp/cedet/ede/proj-elisp.el2
-rw-r--r--lisp/cedet/ede/system.el8
-rw-r--r--lisp/cedet/semantic.el54
-rw-r--r--lisp/cedet/semantic/db-mode.el67
-rw-r--r--lisp/cedet/semantic/ede-grammar.el202
-rw-r--r--lisp/cedet/semantic/grammar-wy.el478
-rw-r--r--lisp/cedet/semantic/grammar.el1912
10 files changed, 2674 insertions, 88 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 43f36484ab8..0739e79cf7a 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,5 +1,28 @@
2009-09-27 Chong Yidong <cyd@stupidchicken.com>
+ * cedet/ede/system.el (ede-upload-html-documentation)
+ (ede-upload-distribution, ede-edit-web-page)
+ (ede-web-browse-home): Autoload.
+
+ * cedet/ede/proj-elisp.el: Add autoload for
+ semantic-ede-proj-target-grammar.
+
+ * cedet/semantic.el (navigate-menu): Show menu items only if
+ semantic-mode is enabled.
+
+ * cedet/ede.el: Remove comments.
+
+ * cedet/cedet.el (cedet-menu-map): Minor doc fix.
+
+ * cedet/semantic/grammar.el:
+ * cedet/semantic/grammar-wy.el:
+ * cedet/semantic/ede-grammar.el: New files.
+
+ * cedet/semantic/db-mode.el (global-semanticdb-minor-mode): Define
+ using define-minor-mode, so that the usual mode variable exists.
+
+2009-09-27 Chong Yidong <cyd@stupidchicken.com>
+
* cedet/ede.el (global-ede-mode-map): Move menu to
global-ede-mode-map.
(ede-minor-mode, global-ede-mode): Use define-minor-mode.
diff --git a/lisp/cedet/cedet.el b/lisp/cedet/cedet.el
index 8dcbfd6a414..c98dc9b8893 100644
--- a/lisp/cedet/cedet.el
+++ b/lisp/cedet/cedet.el
@@ -65,12 +65,12 @@
(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
+ '(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 Projects (EDE)" global-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] '("--"))
diff --git a/lisp/cedet/ede.el b/lisp/cedet/ede.el
index 8240961c257..65da831660e 100644
--- a/lisp/cedet/ede.el
+++ b/lisp/cedet/ede.el
@@ -1981,18 +1981,6 @@ Display the results as a debug list."
;; (def-edebug-spec ede-with-projectfile
;; (form def-body))))
-;; (autoload 'ede-web-browse-home "ede-system" t
-;; "Web browse this project's home page.")
-
-;; (autoload 'ede-edit-web-page "ede-system" t
-;; "Edit the web site for this project.")
-
-;; (autoload 'ede-upload-distribution "ede-system" t
-;; "Upload the dist for this project to the upload site.")
-
-;; (autoload 'ede-upload-html-documentation "ede-system" t
-;; "Upload auto-generated HTML to the web site.")
-
(provide 'ede)
;; Include this last because it depends on ede.
diff --git a/lisp/cedet/ede/proj-elisp.el b/lisp/cedet/ede/proj-elisp.el
index 068daae44de..1838bad00e0 100644
--- a/lisp/cedet/ede/proj-elisp.el
+++ b/lisp/cedet/ede/proj-elisp.el
@@ -29,6 +29,8 @@
(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)
diff --git a/lisp/cedet/ede/system.el b/lisp/cedet/ede/system.el
index ad917cf6b1b..db2b9a2c9a4 100644
--- a/lisp/cedet/ede/system.el
+++ b/lisp/cedet/ede/system.el
@@ -31,7 +31,8 @@
;;; Code:
;;; Web/FTP site node.
-;;
+
+;;;###autoload
(defun ede-web-browse-home ()
"Browse the home page of the current project."
(interactive)
@@ -44,7 +45,7 @@
(browse-url home)
))
-
+;;;###autoload
(defun ede-edit-web-page ()
"Edit the web site for this project."
(interactive)
@@ -62,7 +63,7 @@
(error "No project file found")))
(find-file endfile)))
-
+;;;###autoload
(defun ede-upload-distribution ()
"Upload the current distribution to the correct location.
Use /user@ftp.site.com: file names for FTP sites.
@@ -95,6 +96,7 @@ Download tramp, and use /r:machine: for names on remote sites w/out FTP access."
(message "Done uploading files...")
)
+;;;###autoload
(defun ede-upload-html-documentation ()
"Upload the current distributions documentation as HTML.
Use /user@ftp.site.com: file names for FTP sites.
diff --git a/lisp/cedet/semantic.el b/lisp/cedet/semantic.el
index 81214b4b63f..dfed8a8c194 100644
--- a/lisp/cedet/semantic.el
+++ b/lisp/cedet/semantic.el
@@ -934,42 +934,47 @@ Throw away all the old tags, and recreate the tag database."
;; 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."))
+ :help "Force a full reparse of the current buffer."
+ :visible semantic-mode))
(define-key cedet-menu-map [semantic-edit-menu]
- (cons "Edit Tags" edit-menu))
+ `(menu-item "Edit Tags" ,edit-menu
+ :visible semantic-mode))
(define-key cedet-menu-map [navigate-menu]
- (cons "Navigate Tags" 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-bar-make-mm-toggle
- global-semantic-highlight-func-mode
- "Highlight Current Function"
- "Highlight the tag at point"))
+ '(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-bar-make-mm-toggle
- global-semantic-decoration-mode
- "Decorate Tags"
- "Decorate tags based on various attributes"))
+ '(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-bar-make-mm-toggle
- global-semantic-idle-completions-mode
- "Show Tag Completions"
- "Show tag completions when idle"))
+ '(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-bar-make-mm-toggle
- global-semantic-idle-summary-mode
- "Show Tag Summaries"
- "Show tag summaries when idle"))
+ '(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"
- :button (:toggle . (semanticdb-minor-mode-p))))
+ :visible semantic-mode
+ :button (:toggle . global-semanticdb-minor-mode)))
(define-key cedet-menu-map [global-semantic-idle-scheduler-mode]
- (menu-bar-make-mm-toggle
- global-semantic-idle-scheduler-mode
- "Reparse When Idle"
- "Keep a buffer's parse tree up to date when idle"))
+ '(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] '("--")))
@@ -1064,7 +1069,6 @@ Semantic mode.
(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)))))
diff --git a/lisp/cedet/semantic/db-mode.el b/lisp/cedet/semantic/db-mode.el
index 697a87dac13..ae612217232 100644
--- a/lisp/cedet/semantic/db-mode.el
+++ b/lisp/cedet/semantic/db-mode.el
@@ -37,26 +37,6 @@
(declare-function semantic-lex-spp-set-dynamic-table "semantic/lex-spp")
-(defcustom semanticdb-global-mode nil
- "*If non-nil enable the use of `semanticdb-minor-mode'."
- :group 'semantic
- :type 'boolean
- :require 'semantic/db
- :initialize 'custom-initialize-default
- :set (lambda (sym val)
- (global-semanticdb-minor-mode (if val 1 -1))
- (custom-set-default sym val)))
-
-(defcustom semanticdb-mode-hook nil
- "Hook run whenever `global-semanticdb-minor-mode' is run.
-Use `semanticdb-minor-mode-p' to determine if the mode has been turned
-on or off."
- :group 'semanticdb
- :type 'hook)
-
-(semantic-varalias-obsolete 'semanticdb-mode-hooks
- 'semanticdb-mode-hook)
-
;;; Start/Stop database use
;;
(defvar semanticdb-hooks
@@ -80,32 +60,27 @@ on or off."
(symbol-value (car (cdr (car semanticdb-hooks))))))
;;;###autoload
-(defun global-semanticdb-minor-mode (&optional arg)
- "Toggle the use of `semanticdb-minor-mode'.
-If ARG is positive, enable, if it is negative, disable.
-If ARG is nil, then toggle."
- (interactive "P")
- (if (not arg)
- (if (semanticdb-minor-mode-p)
- (setq arg -1)
- (setq arg 1)))
- (let ((fn 'add-hook)
- (h semanticdb-hooks)
- (changed nil))
- (if (< arg 0)
- (setq changed semanticdb-global-mode
- semanticdb-global-mode nil
- fn 'remove-hook)
- (setq changed (not semanticdb-global-mode)
- semanticdb-global-mode t))
- ;(message "ARG = %d" arg)
- (when changed
- (while h
- (funcall fn (car (cdr (car h))) (car (car h)))
- (setq h (cdr h)))
- ;; Call a hook
- (run-hooks 'semanticdb-mode-hook))
- ))
+(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.
diff --git a/lisp/cedet/semantic/ede-grammar.el b/lisp/cedet/semantic/ede-grammar.el
new file mode 100644
index 00000000000..c23b489c837
--- /dev/null
+++ b/lisp/cedet/semantic/ede-grammar.el
@@ -0,0 +1,202 @@
+;;; semantic/ede-grammar.el --- EDE support for Semantic Grammar Files
+
+;;; Copyright (C) 2003, 2004, 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <zappo@gnu.org>
+;; Keywords: project, make
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Handle .by or .wy files.
+
+(require 'semantic)
+(require 'ede/proj)
+(require 'ede/pmake)
+(require 'ede/pconf)
+(require 'ede/proj-elisp)
+(require 'semantic/grammar)
+
+;;; Code:
+(defclass semantic-ede-proj-target-grammar (ede-proj-target-makefile)
+ ((menu :initform nil)
+ (keybindings :initform nil)
+ (phony :initform t)
+ (sourcetype :initform
+ (semantic-ede-source-grammar-wisent
+ semantic-ede-source-grammar-bovine
+ ))
+ (availablecompilers :initform
+ (semantic-ede-grammar-compiler-wisent
+ semantic-ede-grammar-compiler-bovine
+ ))
+ )
+ "This target consists of a group of grammar files.
+A grammar target consists of grammar files that build Emacs Lisp programs for
+parsing different languages.")
+
+(defvar semantic-ede-source-grammar-wisent
+ (ede-sourcecode "semantic-ede-grammar-source-wisent"
+ :name "Wisent Grammar"
+ :sourcepattern "\\.wy$"
+ )
+ "Semantic Grammar source code definition for wisent.")
+
+(defclass semantic-ede-grammar-compiler-class (ede-compiler)
+ nil
+ "Specialized compiler for semantic grammars.")
+
+(defvar semantic-ede-grammar-compiler-wisent
+ (semantic-ede-grammar-compiler-class
+ "ede-emacs-wisent-compiler"
+ :name "emacs"
+ :variables '(("EMACS" . "emacs"))
+ :commands
+ '(
+ "@echo \"(add-to-list 'load-path nil)\" > grammar-make-script"
+ "@for loadpath in . ${LOADPATH}; do \\"
+ " echo \"(add-to-list 'load-path \\\"$$loadpath\\\")\" >> grammar-make-script; \\"
+ "done;"
+ "@echo \"(require 'semantic-load)\" >> grammar-make-script"
+ "@echo \"(require 'semantic-grammar)\" >> grammar-make-script"
+ ;; "@echo \"(setq debug-on-error t)\" >> grammar-make-script"
+ "\"$(EMACS)\" -batch --no-site-file -l grammar-make-script -f semantic-grammar-batch-build-packages $^"
+ )
+ ;; :autoconf '("AM_PATH_LISPDIR")
+ :sourcetype '(semantic-ede-source-grammar-wisent)
+ :objectextention "-wy.elc"
+ )
+ "Compile Emacs Lisp programs.")
+
+
+(defvar semantic-ede-source-grammar-bovine
+ (ede-sourcecode "semantic-ede-grammar-source-bovine"
+ :name "Bovine Grammar"
+ :sourcepattern "\\.by$"
+ )
+ "Semantic Grammar source code definition for the bovinator.")
+
+(defvar semantic-ede-grammar-compiler-bovine
+ (semantic-ede-grammar-compiler-class
+ "ede-emacs-wisent-compiler"
+ :name "emacs"
+ :variables '(("EMACS" . "emacs"))
+ :commands
+ '(
+ "@echo \"(add-to-list 'load-path nil)\" > grammar-make-script"
+ "@for loadpath in . ${LOADPATH}; do \\"
+ " echo \"(add-to-list 'load-path \\\"$$loadpath\\\")\" >> grammar-make-script; \\"
+ "done;"
+ "@echo \"(require 'semantic-load)\" >> grammar-make-script"
+ "@echo \"(require 'semantic-grammar)\" >> grammar-make-script"
+ ;; "@echo \"(setq debug-on-error t)\" >> grammar-make-script"
+ "\"$(EMACS)\" -batch --no-site-file -l grammar-make-script -f semantic-grammar-batch-build-packages $^"
+ )
+ ;; :autoconf '("AM_PATH_LISPDIR")
+ :sourcetype '(semantic-ede-source-grammar-bovine)
+ :objectextention "-by.elc"
+ )
+ "Compile Emacs Lisp programs.")
+
+;;; Target options.
+(defmethod ede-buffer-mine ((this semantic-ede-proj-target-grammar) buffer)
+ "Return t if object THIS lays claim to the file in BUFFER.
+Lays claim to all -by.el, and -wy.el files."
+ ;; We need to be a little more careful than this, but at the moment it
+ ;; is common to have only one target of this class per directory.
+ (if (string-match "-[bw]y\\.elc?$" (buffer-file-name buffer))
+ t
+ (call-next-method) ; The usual thing.
+ ))
+
+(defmethod project-compile-target ((obj semantic-ede-proj-target-grammar))
+ "Compile all sources in a Lisp target OBJ."
+ (let* ((cb (current-buffer))
+ (proj (ede-target-parent obj))
+ (default-directory (oref proj directory)))
+ (mapc (lambda (src)
+ (save-excursion
+ (set-buffer (find-file-noselect src))
+ (save-excursion
+ (semantic-grammar-create-package))
+ (save-buffer)
+ (let ((cf (concat (semantic-grammar-package) ".el")))
+ (if (or (not (file-exists-p cf))
+ (file-newer-than-file-p src cf))
+ (byte-compile-file cf)))))
+ (oref obj source)))
+ (message "All Semantic Grammar sources are up to date in %s" (object-name obj)))
+
+;;; Makefile generation functions
+;;
+(defmethod ede-proj-makefile-sourcevar ((this semantic-ede-proj-target-grammar))
+ "Return the variable name for THIS's sources."
+ (cond ((ede-proj-automake-p)
+ (error "No Automake support for Semantic Grammars"))
+ (t (concat (ede-pmake-varname this) "_SEMANTIC_GRAMMAR"))))
+
+(defmethod ede-proj-makefile-insert-variables :AFTER ((this semantic-ede-proj-target-grammar))
+ "Insert variables needed by target THIS."
+ (ede-proj-makefile-insert-loadpath-items
+ (ede-proj-elisp-packages-to-loadpath
+ (list "eieio" "semantic" "inversion" "ede")))
+ ;; eieio for object system needed in ede
+ ;; semantic because it is
+ ;; Inversion for versioning system.
+ ;; ede for project regeneration
+ (ede-pmake-insert-variable-shared
+ (concat (ede-pmake-varname this) "_SEMANTIC_GRAMMAR_EL")
+ (insert
+ (mapconcat (lambda (src)
+ (save-excursion
+ (set-buffer (find-file-noselect src))
+ (concat (semantic-grammar-package) ".el")))
+ (oref this source)
+ " ")))
+ )
+
+(defmethod ede-proj-makefile-insert-rules ((this semantic-ede-proj-target-grammar))
+ "Insert rules needed by THIS target."
+ ;; Add in some dependencies.
+;; (mapc (lambda (src)
+;; (let ((nm (file-name-sans-extension src)))
+;; (insert nm "-wy.el: " src "\n"
+;; nm "-wy.elc: " nm "-wy.el\n\n")
+;; ))
+;; (oref this source))
+ ;; Call the normal insertion of rules.
+ (call-next-method)
+ )
+
+(defmethod ede-proj-makefile-insert-dist-dependencies ((this semantic-ede-proj-target-grammar))
+ "Insert dist dependencies, or intermediate targets.
+This makes sure that all grammar lisp files are created before the dist
+runs, so they are always up to date.
+Argument THIS is the target that should insert stuff."
+ (call-next-method)
+ (insert " $(" (ede-pmake-varname this) "_SEMANTIC_GRAMMAR_EL)")
+ )
+
+;; (autoload 'ede-proj-target-elisp "ede/proj-elisp"
+;; "Target class for Emacs/Semantic grammar files." nil nil)
+
+(ede-proj-register-target "semantic grammar"
+ semantic-ede-proj-target-grammar)
+
+(provide 'semantic/ede-grammar)
+
+;;; semantic/ede-grammar.el ends here
diff --git a/lisp/cedet/semantic/grammar-wy.el b/lisp/cedet/semantic/grammar-wy.el
new file mode 100644
index 00000000000..ae1aec7b466
--- /dev/null
+++ b/lisp/cedet/semantic/grammar-wy.el
@@ -0,0 +1,478 @@
+;;; semantic/grammar-wy.el --- Generated parser support file
+
+;; Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
+
+;; Author: David Ponce <david@dponce.com>
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; This file is generated from the grammar file semantic-grammar.wy in
+;; the upstream CEDET repository.
+
+;;; Code:
+
+(require 'semantic/lex)
+(defvar semantic-grammar-lex-c-char-re)
+
+;; Current parsed nonterminal name.
+(defvar semantic-grammar-wy--nterm nil)
+;; Index of rule in a nonterminal clause.
+(defvar semantic-grammar-wy--rindx nil)
+
+;;; Declarations
+;;
+(defconst semantic-grammar-wy--keyword-table
+ (semantic-lex-make-keyword-table
+ '(("%default-prec" . DEFAULT-PREC)
+ ("%no-default-prec" . NO-DEFAULT-PREC)
+ ("%keyword" . KEYWORD)
+ ("%languagemode" . LANGUAGEMODE)
+ ("%left" . LEFT)
+ ("%nonassoc" . NONASSOC)
+ ("%package" . PACKAGE)
+ ("%prec" . PREC)
+ ("%put" . PUT)
+ ("%quotemode" . QUOTEMODE)
+ ("%right" . RIGHT)
+ ("%scopestart" . SCOPESTART)
+ ("%start" . START)
+ ("%token" . TOKEN)
+ ("%type" . TYPE)
+ ("%use-macros" . USE-MACROS))
+ 'nil)
+ "Table of language keywords.")
+
+(defconst semantic-grammar-wy--token-table
+ (semantic-lex-make-type-table
+ '(("punctuation"
+ (GT . ">")
+ (LT . "<")
+ (OR . "|")
+ (SEMI . ";")
+ (COLON . ":"))
+ ("close-paren"
+ (RBRACE . "}")
+ (RPAREN . ")"))
+ ("open-paren"
+ (LBRACE . "{")
+ (LPAREN . "("))
+ ("block"
+ (BRACE_BLOCK . "(LBRACE RBRACE)")
+ (PAREN_BLOCK . "(LPAREN RPAREN)"))
+ ("code"
+ (EPILOGUE . "%%...EOF")
+ (PROLOGUE . "%{...%}"))
+ ("sexp"
+ (SEXP))
+ ("qlist"
+ (PREFIXED_LIST))
+ ("char"
+ (CHARACTER))
+ ("symbol"
+ (PERCENT_PERCENT . "\\`%%\\'")
+ (SYMBOL))
+ ("string"
+ (STRING)))
+ '(("punctuation" :declared t)
+ ("block" :declared t)
+ ("sexp" matchdatatype sexp)
+ ("sexp" syntax "\\=")
+ ("sexp" :declared t)
+ ("qlist" matchdatatype sexp)
+ ("qlist" syntax "\\s'\\s-*(")
+ ("qlist" :declared t)
+ ("char" syntax semantic-grammar-lex-c-char-re)
+ ("char" :declared t)
+ ("symbol" syntax ":?\\(\\sw\\|\\s_\\)+")
+ ("symbol" :declared t)
+ ("string" :declared t)
+ ("keyword" :declared t)))
+ "Table of lexical tokens.")
+
+(defconst semantic-grammar-wy--parse-table
+ (progn
+ (eval-when-compile
+ (require 'semantic/wisent/comp))
+ (wisent-compile-grammar
+ '((DEFAULT-PREC NO-DEFAULT-PREC KEYWORD LANGUAGEMODE LEFT NONASSOC PACKAGE PREC PUT QUOTEMODE RIGHT SCOPESTART START TOKEN TYPE USE-MACROS STRING SYMBOL PERCENT_PERCENT CHARACTER PREFIXED_LIST SEXP PROLOGUE EPILOGUE PAREN_BLOCK BRACE_BLOCK LPAREN RPAREN LBRACE RBRACE COLON SEMI OR LT GT)
+ nil
+ (grammar
+ ((prologue))
+ ((epilogue))
+ ((declaration))
+ ((nonterminal))
+ ((PERCENT_PERCENT)))
+ (prologue
+ ((PROLOGUE)
+ (wisent-raw-tag
+ (semantic-tag-new-code "prologue" nil))))
+ (epilogue
+ ((EPILOGUE)
+ (wisent-raw-tag
+ (semantic-tag-new-code "epilogue" nil))))
+ (declaration
+ ((decl)
+ (eval $1)))
+ (decl
+ ((default_prec_decl))
+ ((no_default_prec_decl))
+ ((languagemode_decl))
+ ((package_decl))
+ ((precedence_decl))
+ ((put_decl))
+ ((quotemode_decl))
+ ((scopestart_decl))
+ ((start_decl))
+ ((keyword_decl))
+ ((token_decl))
+ ((type_decl))
+ ((use_macros_decl)))
+ (default_prec_decl
+ ((DEFAULT-PREC)
+ `(wisent-raw-tag
+ (semantic-tag "default-prec" 'assoc :value
+ '("t")))))
+ (no_default_prec_decl
+ ((NO-DEFAULT-PREC)
+ `(wisent-raw-tag
+ (semantic-tag "default-prec" 'assoc :value
+ '("nil")))))
+ (languagemode_decl
+ ((LANGUAGEMODE symbols)
+ `(wisent-raw-tag
+ (semantic-tag ',(car $2)
+ 'languagemode :rest ',(cdr $2)))))
+ (package_decl
+ ((PACKAGE SYMBOL)
+ `(wisent-raw-tag
+ (semantic-tag-new-package ',$2 nil))))
+ (precedence_decl
+ ((associativity token_type_opt items)
+ `(wisent-raw-tag
+ (semantic-tag ',$1 'assoc :type ',$2 :value ',$3))))
+ (associativity
+ ((LEFT)
+ (progn "left"))
+ ((RIGHT)
+ (progn "right"))
+ ((NONASSOC)
+ (progn "nonassoc")))
+ (put_decl
+ ((PUT put_name put_value)
+ `(wisent-raw-tag
+ (semantic-tag ',$2 'put :value ',(list $3))))
+ ((PUT put_name put_value_list)
+ `(wisent-raw-tag
+ (semantic-tag ',$2 'put :value ',$3)))
+ ((PUT put_name_list put_value)
+ `(wisent-raw-tag
+ (semantic-tag ',(car $2)
+ 'put :rest ',(cdr $2)
+ :value ',(list $3))))
+ ((PUT put_name_list put_value_list)
+ `(wisent-raw-tag
+ (semantic-tag ',(car $2)
+ 'put :rest ',(cdr $2)
+ :value ',$3))))
+ (put_name_list
+ ((BRACE_BLOCK)
+ (mapcar 'semantic-tag-name
+ (semantic-parse-region
+ (car $region1)
+ (cdr $region1)
+ 'put_names 1))))
+ (put_names
+ ((LBRACE)
+ nil)
+ ((RBRACE)
+ nil)
+ ((put_name)
+ (wisent-raw-tag
+ (semantic-tag $1 'put-name))))
+ (put_name
+ ((SYMBOL))
+ ((token_type)))
+ (put_value_list
+ ((BRACE_BLOCK)
+ (mapcar 'semantic-tag-code-detail
+ (semantic-parse-region
+ (car $region1)
+ (cdr $region1)
+ 'put_values 1))))
+ (put_values
+ ((LBRACE)
+ nil)
+ ((RBRACE)
+ nil)
+ ((put_value)
+ (wisent-raw-tag
+ (semantic-tag-new-code "put-value" $1))))
+ (put_value
+ ((SYMBOL any_value)
+ (cons $1 $2)))
+ (scopestart_decl
+ ((SCOPESTART SYMBOL)
+ `(wisent-raw-tag
+ (semantic-tag ',$2 'scopestart))))
+ (quotemode_decl
+ ((QUOTEMODE SYMBOL)
+ `(wisent-raw-tag
+ (semantic-tag ',$2 'quotemode))))
+ (start_decl
+ ((START symbols)
+ `(wisent-raw-tag
+ (semantic-tag ',(car $2)
+ 'start :rest ',(cdr $2)))))
+ (keyword_decl
+ ((KEYWORD SYMBOL string_value)
+ `(wisent-raw-tag
+ (semantic-tag ',$2 'keyword :value ',$3))))
+ (token_decl
+ ((TOKEN token_type_opt SYMBOL string_value)
+ `(wisent-raw-tag
+ (semantic-tag ',$3 ',(if $2 'token 'keyword)
+ :type ',$2 :value ',$4)))
+ ((TOKEN token_type_opt symbols)
+ `(wisent-raw-tag
+ (semantic-tag ',(car $3)
+ 'token :type ',$2 :rest ',(cdr $3)))))
+ (token_type_opt
+ (nil)
+ ((token_type)))
+ (token_type
+ ((LT SYMBOL GT)
+ (progn $2)))
+ (type_decl
+ ((TYPE token_type plist_opt)
+ `(wisent-raw-tag
+ (semantic-tag ',$2 'type :value ',$3))))
+ (plist_opt
+ (nil)
+ ((plist)))
+ (plist
+ ((plist put_value)
+ (append
+ (list $2)
+ $1))
+ ((put_value)
+ (list $1)))
+ (use_name_list
+ ((BRACE_BLOCK)
+ (mapcar 'semantic-tag-name
+ (semantic-parse-region
+ (car $region1)
+ (cdr $region1)
+ 'use_names 1))))
+ (use_names
+ ((LBRACE)
+ nil)
+ ((RBRACE)
+ nil)
+ ((SYMBOL)
+ (wisent-raw-tag
+ (semantic-tag $1 'use-name))))
+ (use_macros_decl
+ ((USE-MACROS SYMBOL use_name_list)
+ `(wisent-raw-tag
+ (semantic-tag "macro" 'macro :type ',$2 :value ',$3))))
+ (string_value
+ ((STRING)
+ (read $1)))
+ (any_value
+ ((SYMBOL))
+ ((STRING))
+ ((PAREN_BLOCK))
+ ((PREFIXED_LIST))
+ ((SEXP)))
+ (symbols
+ ((lifo_symbols)
+ (nreverse $1)))
+ (lifo_symbols
+ ((lifo_symbols SYMBOL)
+ (cons $2 $1))
+ ((SYMBOL)
+ (list $1)))
+ (nonterminal
+ ((SYMBOL
+ (setq semantic-grammar-wy--nterm $1 semantic-grammar-wy--rindx 0)
+ COLON rules SEMI)
+ (wisent-raw-tag
+ (semantic-tag $1 'nonterminal :children $4))))
+ (rules
+ ((lifo_rules)
+ (apply 'nconc
+ (nreverse $1))))
+ (lifo_rules
+ ((lifo_rules OR rule)
+ (cons $3 $1))
+ ((rule)
+ (list $1)))
+ (rule
+ ((rhs)
+ (let*
+ ((nterm semantic-grammar-wy--nterm)
+ (rindx semantic-grammar-wy--rindx)
+ (rhs $1)
+ comps prec action elt)
+ (setq semantic-grammar-wy--rindx
+ (1+ semantic-grammar-wy--rindx))
+ (while rhs
+ (setq elt
+ (car rhs)
+ rhs
+ (cdr rhs))
+ (cond
+ ((vectorp elt)
+ (if prec
+ (error "duplicate %%prec in `%s:%d' rule" nterm rindx))
+ (setq prec
+ (aref elt 0)))
+ ((consp elt)
+ (if
+ (or action comps)
+ (setq comps
+ (cons elt comps)
+ semantic-grammar-wy--rindx
+ (1+ semantic-grammar-wy--rindx))
+ (setq action
+ (car elt))))
+ (t
+ (setq comps
+ (cons elt comps)))))
+ (wisent-cook-tag
+ (wisent-raw-tag
+ (semantic-tag
+ (format "%s:%d" nterm rindx)
+ 'rule :type
+ (if comps "group" "empty")
+ :value comps :prec prec :expr action))))))
+ (rhs
+ (nil)
+ ((rhs item)
+ (cons $2 $1))
+ ((rhs action)
+ (cons
+ (list $2)
+ $1))
+ ((rhs PREC item)
+ (cons
+ (vector $3)
+ $1)))
+ (action
+ ((PAREN_BLOCK))
+ ((PREFIXED_LIST))
+ ((BRACE_BLOCK)
+ (format "(progn\n%s)"
+ (let
+ ((s $1))
+ (if
+ (string-match "^{[ \n ]*" s)
+ (setq s
+ (substring s
+ (match-end 0))))
+ (if
+ (string-match "[ \n ]*}$" s)
+ (setq s
+ (substring s 0
+ (match-beginning 0))))
+ s))))
+ (items
+ ((lifo_items)
+ (nreverse $1)))
+ (lifo_items
+ ((lifo_items item)
+ (cons $2 $1))
+ ((item)
+ (list $1)))
+ (item
+ ((SYMBOL))
+ ((CHARACTER))))
+ '(grammar prologue epilogue declaration nonterminal rule put_names put_values use_names)))
+ "Parser table.")
+
+(defun semantic-grammar-wy--install-parser ()
+ "Setup the Semantic Parser."
+ (semantic-install-function-overrides
+ '((parse-stream . wisent-parse-stream)))
+ (setq semantic-parser-name "LALR"
+ semantic--parse-table semantic-grammar-wy--parse-table
+ semantic-debug-parser-source "semantic-grammar.wy"
+ semantic-flex-keywords-obarray semantic-grammar-wy--keyword-table
+ semantic-lex-types-obarray semantic-grammar-wy--token-table)
+ ;; Collect unmatched syntax lexical tokens
+ (semantic-make-local-hook 'wisent-discarding-token-functions)
+ (add-hook 'wisent-discarding-token-functions
+ 'wisent-collect-unmatched-syntax nil t))
+
+
+;;; Analyzers
+
+(define-lex-sexp-type-analyzer semantic-grammar-wy--<sexp>-sexp-analyzer
+ "sexp analyzer for <sexp> tokens."
+ "\\="
+ 'SEXP)
+
+(define-lex-sexp-type-analyzer semantic-grammar-wy--<qlist>-sexp-analyzer
+ "sexp analyzer for <qlist> tokens."
+ "\\s'\\s-*("
+ 'PREFIXED_LIST)
+
+(define-lex-keyword-type-analyzer semantic-grammar-wy--<keyword>-keyword-analyzer
+ "keyword analyzer for <keyword> tokens."
+ "\\(\\sw\\|\\s_\\)+")
+
+(define-lex-block-type-analyzer semantic-grammar-wy--<block>-block-analyzer
+ "block analyzer for <block> tokens."
+ "\\s(\\|\\s)"
+ '((("(" LPAREN PAREN_BLOCK)
+ ("{" LBRACE BRACE_BLOCK))
+ (")" RPAREN)
+ ("}" RBRACE))
+ )
+
+(define-lex-regex-type-analyzer semantic-grammar-wy--<char>-regexp-analyzer
+ "regexp analyzer for <char> tokens."
+ semantic-grammar-lex-c-char-re
+ nil
+ 'CHARACTER)
+
+(define-lex-sexp-type-analyzer semantic-grammar-wy--<string>-sexp-analyzer
+ "sexp analyzer for <string> tokens."
+ "\\s\""
+ 'STRING)
+
+(define-lex-regex-type-analyzer semantic-grammar-wy--<symbol>-regexp-analyzer
+ "regexp analyzer for <symbol> tokens."
+ ":?\\(\\sw\\|\\s_\\)+"
+ '((PERCENT_PERCENT . "\\`%%\\'"))
+ 'SYMBOL)
+
+(define-lex-string-type-analyzer semantic-grammar-wy--<punctuation>-string-analyzer
+ "string analyzer for <punctuation> tokens."
+ "\\(\\s.\\|\\s$\\|\\s'\\)+"
+ '((GT . ">")
+ (LT . "<")
+ (OR . "|")
+ (SEMI . ";")
+ (COLON . ":"))
+ 'punctuation)
+
+(provide 'semantic/grammar-wy)
+
+;;; semantic/grammar-wy.el ends here
diff --git a/lisp/cedet/semantic/grammar.el b/lisp/cedet/semantic/grammar.el
new file mode 100644
index 00000000000..5d947551d48
--- /dev/null
+++ b/lisp/cedet/semantic/grammar.el
@@ -0,0 +1,1912 @@
+;;; semantic/grammar.el --- Major mode framework for Semantic grammars
+
+;;; Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: David Ponce <david@dponce.com>
+;; Maintainer: David Ponce <david@dponce.com>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Major mode framework for editing Semantic's input grammar files.
+
+;;; History:
+;;
+
+;;; Code:
+
+(require 'semantic)
+(require 'semantic/ctxt)
+(require 'semantic/format)
+(require 'semantic/grammar-wy)
+(require 'semantic/idle)
+(declare-function semantic-momentary-highlight-tag "semantic/decorate")
+(declare-function semantic-analyze-context "semantic/analyze")
+(declare-function semantic-analyze-tags-of-class-list
+ "semantic/analyze/complete")
+
+
+;; (eval-when-compile
+;; (require 'semantic/analyze))
+
+(eval-when-compile
+ (require 'eldoc)
+ (require 'semantic/edit)
+ (require 'semantic/find))
+
+;;(require 'semantic/wisent)
+;; (require 'font-lock)
+;; (require 'pp)
+
+;; (eval-when-compile
+;; ;; (require 'senator)
+;; (require 'semantic/edit)
+;; (require 'semantic/find)
+;; (require 'semantic/format)
+;; (require 'semantic/idle))
+
+
+;;;;
+;;;; Set up lexer
+;;;;
+
+(defconst semantic-grammar-lex-c-char-re "'\\s\\?.'"
+ "Regexp matching C-like character literals.")
+
+;; Most of the analyzers are auto-generated from the grammar, but the
+;; following which need special handling code.
+;;
+(define-lex-regex-analyzer semantic-grammar-lex-prologue
+ "Detect and create a prologue token."
+ "\\<%{"
+ ;; Zing to the end of this brace block.
+ (semantic-lex-push-token
+ (semantic-lex-token
+ 'PROLOGUE (point)
+ (save-excursion
+ (semantic-lex-unterminated-syntax-protection 'PROLOGUE
+ (forward-char)
+ (forward-sexp 1)
+ (point))))))
+
+(defsubst semantic-grammar-epilogue-start ()
+ "Return the start position of the grammar epilogue."
+ (save-excursion
+ (goto-char (point-min))
+ (if (re-search-forward "^\\s-*\\<%%\\>\\s-*$" nil t 2)
+ (match-beginning 0)
+ (1+ (point-max)))))
+
+(define-lex-regex-analyzer semantic-grammar-lex-epilogue
+ "Detect and create an epilogue or percent-percent token."
+ "\\<%%\\>"
+ (let ((start (match-beginning 0))
+ (end (match-end 0))
+ (class 'PERCENT_PERCENT))
+ (when (>= start (semantic-grammar-epilogue-start))
+ (setq class 'EPILOGUE
+ end (point-max)))
+ (semantic-lex-push-token
+ (semantic-lex-token class start end))))
+
+(define-lex semantic-grammar-lexer
+ "Lexical analyzer that handles Semantic grammar buffers.
+It ignores whitespaces, newlines and comments."
+ semantic-lex-ignore-newline
+ semantic-lex-ignore-whitespace
+ ;; Must detect prologue/epilogue before other symbols/keywords!
+ semantic-grammar-lex-prologue
+ semantic-grammar-lex-epilogue
+ semantic-grammar-wy--<keyword>-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
View Lorry Controller Status