Mercurial > emacs
changeset 104524:fbd55cc47b77
* 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.
| author | Chong Yidong <cyd@stupidchicken.com> |
|---|---|
| date | Sun, 27 Sep 2009 21:35:46 +0000 |
| parents | 18ae68cd64bd |
| children | bbd7017a25d9 |
| files | lisp/ChangeLog lisp/cedet/cedet.el lisp/cedet/ede.el lisp/cedet/ede/proj-elisp.el lisp/cedet/ede/system.el lisp/cedet/semantic.el lisp/cedet/semantic/db-mode.el lisp/cedet/semantic/ede-grammar.el lisp/cedet/semantic/grammar-wy.el lisp/cedet/semantic/grammar.el |
| diffstat | 10 files changed, 2674 insertions(+), 88 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Sun Sep 27 17:50:53 2009 +0000 +++ b/lisp/ChangeLog Sun Sep 27 21:35:46 2009 +0000 @@ -1,3 +1,26 @@ +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
--- a/lisp/cedet/cedet.el Sun Sep 27 17:50:53 2009 +0000 +++ b/lisp/cedet/cedet.el Sun Sep 27 21:35:46 2009 +0000 @@ -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] '("--"))
--- a/lisp/cedet/ede.el Sun Sep 27 17:50:53 2009 +0000 +++ b/lisp/cedet/ede.el Sun Sep 27 21:35:46 2009 +0000 @@ -1981,18 +1981,6 @@ ;; (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.
--- a/lisp/cedet/ede/proj-elisp.el Sun Sep 27 17:50:53 2009 +0000 +++ b/lisp/cedet/ede/proj-elisp.el Sun Sep 27 21:35:46 2009 +0000 @@ -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)
--- a/lisp/cedet/ede/system.el Sun Sep 27 17:50:53 2009 +0000 +++ b/lisp/cedet/ede/system.el Sun Sep 27 21:35:46 2009 +0000 @@ -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 @@ (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.
--- a/lisp/cedet/semantic.el Sun Sep 27 17:50:53 2009 +0000 +++ b/lisp/cedet/semantic.el Sun Sep 27 21:35:46 2009 +0000 @@ -934,42 +934,47 @@ ;; 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 @@ (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)))))
--- a/lisp/cedet/semantic/db-mode.el Sun Sep 27 17:50:53 2009 +0000 +++ b/lisp/cedet/semantic/db-mode.el Sun Sep 27 21:35:46 2009 +0000 @@ -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 @@ (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.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/ede-grammar.el Sun Sep 27 21:35:46 2009 +0000 @@ -0,0 +1,202 @@ +;;; semantic/ede-grammar.el --- EDE support for Semantic Grammar Files + +;;; Copyright (C) 2003, 2004, 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/grammar-wy.el Sun Sep 27 21:35:46 2009 +0000 @@ -0,0 +1,478 @@ +;;; semantic/grammar-wy.el --- Generated parser support file + +;; Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc. + +;; Author: David Ponce <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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/grammar.el Sun Sep 27 21:35:46 2009 +0000 @@ -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