aboutsummaryrefslogtreecommitdiffstats
path: root/lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp')
-rw-r--r--lisp/ChangeLog23
-rw-r--r--lisp/cedet/cedet.el4
-rw-r--r--lisp/cedet/ede.el12
-rw-r--r--lisp/cedet/ede/proj-elisp.el2
-rw-r--r--lisp/cedet/ede/system.el8
-rw-r--r--lisp/cedet/semantic.el54
-rw-r--r--lisp/cedet/semantic/db-mode.el67
-rw-r--r--lisp/cedet/semantic/ede-grammar.el202
-rw-r--r--lisp/cedet/semantic/grammar-wy.el478
-rw-r--r--lisp/cedet/semantic/grammar.el1912
10 files changed, 2674 insertions, 88 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 43f36484ab8..0739e79cf7a 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,5 +1,28 @@
12009-09-27 Chong Yidong <cyd@stupidchicken.com> 12009-09-27 Chong Yidong <cyd@stupidchicken.com>
2 2
3 * cedet/ede/system.el (ede-upload-html-documentation)
4 (ede-upload-distribution, ede-edit-web-page)
5 (ede-web-browse-home): Autoload.
6
7 * cedet/ede/proj-elisp.el: Add autoload for
8 semantic-ede-proj-target-grammar.
9
10 * cedet/semantic.el (navigate-menu): Show menu items only if
11 semantic-mode is enabled.
12
13 * cedet/ede.el: Remove comments.
14
15 * cedet/cedet.el (cedet-menu-map): Minor doc fix.
16
17 * cedet/semantic/grammar.el:
18 * cedet/semantic/grammar-wy.el:
19 * cedet/semantic/ede-grammar.el: New files.
20
21 * cedet/semantic/db-mode.el (global-semanticdb-minor-mode): Define
22 using define-minor-mode, so that the usual mode variable exists.
23
242009-09-27 Chong Yidong <cyd@stupidchicken.com>
25
3 * cedet/ede.el (global-ede-mode-map): Move menu to 26 * cedet/ede.el (global-ede-mode-map): Move menu to
4 global-ede-mode-map. 27 global-ede-mode-map.
5 (ede-minor-mode, global-ede-mode): Use define-minor-mode. 28 (ede-minor-mode, global-ede-mode): Use define-minor-mode.
diff --git a/lisp/cedet/cedet.el b/lisp/cedet/cedet.el
index 8dcbfd6a414..c98dc9b8893 100644
--- a/lisp/cedet/cedet.el
+++ b/lisp/cedet/cedet.el
@@ -65,12 +65,12 @@
65 (define-key map [global-semantic-idle-scheduler-mode] 'undefined) 65 (define-key map [global-semantic-idle-scheduler-mode] 'undefined)
66 (define-key map [semantic-menu-separator] '("--")) 66 (define-key map [semantic-menu-separator] '("--"))
67 (define-key map [semantic-mode] 67 (define-key map [semantic-mode]
68 '(menu-item "Enable parsers (Semantic)" semantic-mode 68 '(menu-item "Enable Parsers (Semantic)" semantic-mode
69 :help "Enable language parsers (Semantic)" 69 :help "Enable language parsers (Semantic)"
70 :visible (not (bound-and-true-p semantic-mode)))) 70 :visible (not (bound-and-true-p semantic-mode))))
71 (define-key map [cedet-menu-separator] 'undefined) 71 (define-key map [cedet-menu-separator] 'undefined)
72 (define-key map [ede-mode] 72 (define-key map [ede-mode]
73 '(menu-item "Enable Projects (EDE)" global-ede-mode 73 '(menu-item "Enable Project Support (EDE)" global-ede-mode
74 :help "Enable the Emacs Development Environment (EDE)" 74 :help "Enable the Emacs Development Environment (EDE)"
75 :visible (not (bound-and-true-p global-ede-mode)))) 75 :visible (not (bound-and-true-p global-ede-mode))))
76 (define-key map [ede-menu-separator] '("--")) 76 (define-key map [ede-menu-separator] '("--"))
diff --git a/lisp/cedet/ede.el b/lisp/cedet/ede.el
index 8240961c257..65da831660e 100644
--- a/lisp/cedet/ede.el
+++ b/lisp/cedet/ede.el
@@ -1981,18 +1981,6 @@ Display the results as a debug list."
1981;; (def-edebug-spec ede-with-projectfile 1981;; (def-edebug-spec ede-with-projectfile
1982;; (form def-body)))) 1982;; (form def-body))))
1983 1983
1984;; (autoload 'ede-web-browse-home "ede-system" t
1985;; "Web browse this project's home page.")
1986
1987;; (autoload 'ede-edit-web-page "ede-system" t
1988;; "Edit the web site for this project.")
1989
1990;; (autoload 'ede-upload-distribution "ede-system" t
1991;; "Upload the dist for this project to the upload site.")
1992
1993;; (autoload 'ede-upload-html-documentation "ede-system" t
1994;; "Upload auto-generated HTML to the web site.")
1995
1996(provide 'ede) 1984(provide 'ede)
1997 1985
1998;; Include this last because it depends on ede. 1986;; Include this last because it depends on ede.
diff --git a/lisp/cedet/ede/proj-elisp.el b/lisp/cedet/ede/proj-elisp.el
index 068daae44de..1838bad00e0 100644
--- a/lisp/cedet/ede/proj-elisp.el
+++ b/lisp/cedet/ede/proj-elisp.el
@@ -29,6 +29,8 @@
29(require 'ede/pmake) 29(require 'ede/pmake)
30(require 'ede/pconf) 30(require 'ede/pconf)
31 31
32(autoload 'semantic-ede-proj-target-grammar "semantic/ede-grammar")
33
32;;; Code: 34;;; Code:
33(defclass ede-proj-target-elisp (ede-proj-target-makefile) 35(defclass ede-proj-target-elisp (ede-proj-target-makefile)
34 ((menu :initform nil) 36 ((menu :initform nil)
diff --git a/lisp/cedet/ede/system.el b/lisp/cedet/ede/system.el
index ad917cf6b1b..db2b9a2c9a4 100644
--- a/lisp/cedet/ede/system.el
+++ b/lisp/cedet/ede/system.el
@@ -31,7 +31,8 @@
31;;; Code: 31;;; Code:
32 32
33;;; Web/FTP site node. 33;;; Web/FTP site node.
34;; 34
35;;;###autoload
35(defun ede-web-browse-home () 36(defun ede-web-browse-home ()
36 "Browse the home page of the current project." 37 "Browse the home page of the current project."
37 (interactive) 38 (interactive)
@@ -44,7 +45,7 @@
44 (browse-url home) 45 (browse-url home)
45 )) 46 ))
46 47
47 48;;;###autoload
48(defun ede-edit-web-page () 49(defun ede-edit-web-page ()
49 "Edit the web site for this project." 50 "Edit the web site for this project."
50 (interactive) 51 (interactive)
@@ -62,7 +63,7 @@
62 (error "No project file found"))) 63 (error "No project file found")))
63 (find-file endfile))) 64 (find-file endfile)))
64 65
65 66;;;###autoload
66(defun ede-upload-distribution () 67(defun ede-upload-distribution ()
67 "Upload the current distribution to the correct location. 68 "Upload the current distribution to the correct location.
68Use /user@ftp.site.com: file names for FTP sites. 69Use /user@ftp.site.com: file names for FTP sites.
@@ -95,6 +96,7 @@ Download tramp, and use /r:machine: for names on remote sites w/out FTP access."
95 (message "Done uploading files...") 96 (message "Done uploading files...")
96 ) 97 )
97 98
99;;;###autoload
98(defun ede-upload-html-documentation () 100(defun ede-upload-html-documentation ()
99 "Upload the current distributions documentation as HTML. 101 "Upload the current distributions documentation as HTML.
100Use /user@ftp.site.com: file names for FTP sites. 102Use /user@ftp.site.com: file names for FTP sites.
diff --git a/lisp/cedet/semantic.el b/lisp/cedet/semantic.el
index 81214b4b63f..dfed8a8c194 100644
--- a/lisp/cedet/semantic.el
+++ b/lisp/cedet/semantic.el
@@ -934,42 +934,47 @@ Throw away all the old tags, and recreate the tag database."
934 ;; Top level menu items: 934 ;; Top level menu items:
935 (define-key cedet-menu-map [semantic-force-refresh] 935 (define-key cedet-menu-map [semantic-force-refresh]
936 '(menu-item "Reparse Buffer" semantic-force-refresh 936 '(menu-item "Reparse Buffer" semantic-force-refresh
937 :help "Force a full reparse of the current buffer.")) 937 :help "Force a full reparse of the current buffer."
938 :visible semantic-mode))
938 (define-key cedet-menu-map [semantic-edit-menu] 939 (define-key cedet-menu-map [semantic-edit-menu]
939 (cons "Edit Tags" edit-menu)) 940 `(menu-item "Edit Tags" ,edit-menu
941 :visible semantic-mode))
940 (define-key cedet-menu-map [navigate-menu] 942 (define-key cedet-menu-map [navigate-menu]
941 (cons "Navigate Tags" navigate-menu)) 943 `(menu-item "Navigate Tags" ,navigate-menu
944 :visible semantic-mode))
942 (define-key cedet-menu-map [semantic-options-separator] 945 (define-key cedet-menu-map [semantic-options-separator]
943 '("--")) 946 '("--"))
944 (define-key cedet-menu-map [global-semantic-highlight-func-mode] 947 (define-key cedet-menu-map [global-semantic-highlight-func-mode]
945 (menu-bar-make-mm-toggle 948 '(menu-item "Highlight Current Function" global-semantic-highlight-func-mode
946 global-semantic-highlight-func-mode 949 :help "Highlight the tag at point"
947 "Highlight Current Function" 950 :visible semantic-mode
948 "Highlight the tag at point")) 951 :button (:toggle . global-semantic-highlight-func-mode)))
949 (define-key cedet-menu-map [global-semantic-decoration-mode] 952 (define-key cedet-menu-map [global-semantic-decoration-mode]
950 (menu-bar-make-mm-toggle 953 '(menu-item "Decorate Tags" global-semantic-decoration-mode
951 global-semantic-decoration-mode 954 :help "Decorate tags based on tag attributes"
952 "Decorate Tags" 955 :visible semantic-mode
953 "Decorate tags based on various attributes")) 956 :button (:toggle . (bound-and-true-p
957 global-semantic-decoration-mode))))
954 (define-key cedet-menu-map [global-semantic-idle-completions-mode] 958 (define-key cedet-menu-map [global-semantic-idle-completions-mode]
955 (menu-bar-make-mm-toggle 959 '(menu-item "Show Tag Completions" global-semantic-idle-completions-mode
956 global-semantic-idle-completions-mode 960 :help "Show tag completions when idle"
957 "Show Tag Completions" 961 :visible semantic-mode
958 "Show tag completions when idle")) 962 :button (:toggle . global-semantic-idle-completions-mode)))
959 (define-key cedet-menu-map [global-semantic-idle-summary-mode] 963 (define-key cedet-menu-map [global-semantic-idle-summary-mode]
960 (menu-bar-make-mm-toggle 964 '(menu-item "Show Tag Summaries" global-semantic-idle-summary-mode
961 global-semantic-idle-summary-mode 965 :help "Show tag summaries when idle"
962 "Show Tag Summaries" 966 :visible semantic-mode
963 "Show tag summaries when idle")) 967 :button (:toggle . global-semantic-idle-summary-mode)))
964 (define-key cedet-menu-map [global-semanticdb-minor-mode] 968 (define-key cedet-menu-map [global-semanticdb-minor-mode]
965 '(menu-item "Semantic Database" global-semanticdb-minor-mode 969 '(menu-item "Semantic Database" global-semanticdb-minor-mode
966 :help "Store tag information in a database" 970 :help "Store tag information in a database"
967 :button (:toggle . (semanticdb-minor-mode-p)))) 971 :visible semantic-mode
972 :button (:toggle . global-semanticdb-minor-mode)))
968 (define-key cedet-menu-map [global-semantic-idle-scheduler-mode] 973 (define-key cedet-menu-map [global-semantic-idle-scheduler-mode]
969 (menu-bar-make-mm-toggle 974 '(menu-item "Reparse When Idle" global-semantic-idle-scheduler-mode
970 global-semantic-idle-scheduler-mode 975 :help "Keep a buffer's parse tree up to date when idle"
971 "Reparse When Idle" 976 :visible semantic-mode
972 "Keep a buffer's parse tree up to date when idle")) 977 :button (:toggle . global-semantic-idle-scheduler-mode)))
973 (define-key cedet-menu-map [ede-menu-separator] 'undefined) 978 (define-key cedet-menu-map [ede-menu-separator] 'undefined)
974 (define-key cedet-menu-map [cedet-menu-separator] 'undefined) 979 (define-key cedet-menu-map [cedet-menu-separator] 'undefined)
975 (define-key cedet-menu-map [semantic-menu-separator] '("--"))) 980 (define-key cedet-menu-map [semantic-menu-separator] '("--")))
@@ -1064,7 +1069,6 @@ Semantic mode.
1064 (remove-hook 'html-mode-hook 'semantic-default-html-setup) 1069 (remove-hook 'html-mode-hook 'semantic-default-html-setup)
1065 1070
1066 ;; FIXME: handle semanticdb-load-ebrowse-caches 1071 ;; FIXME: handle semanticdb-load-ebrowse-caches
1067
1068 (dolist (mode semantic-submode-list) 1072 (dolist (mode semantic-submode-list)
1069 (if (and (boundp mode) (eval mode)) 1073 (if (and (boundp mode) (eval mode))
1070 (funcall mode -1))))) 1074 (funcall mode -1)))))
diff --git a/lisp/cedet/semantic/db-mode.el b/lisp/cedet/semantic/db-mode.el
index 697a87dac13..ae612217232 100644
--- a/lisp/cedet/semantic/db-mode.el
+++ b/lisp/cedet/semantic/db-mode.el
@@ -37,26 +37,6 @@
37 37
38(declare-function semantic-lex-spp-set-dynamic-table "semantic/lex-spp") 38(declare-function semantic-lex-spp-set-dynamic-table "semantic/lex-spp")
39 39
40(defcustom semanticdb-global-mode nil
41 "*If non-nil enable the use of `semanticdb-minor-mode'."
42 :group 'semantic
43 :type 'boolean
44 :require 'semantic/db
45 :initialize 'custom-initialize-default
46 :set (lambda (sym val)
47 (global-semanticdb-minor-mode (if val 1 -1))
48 (custom-set-default sym val)))
49
50(defcustom semanticdb-mode-hook nil
51 "Hook run whenever `global-semanticdb-minor-mode' is run.
52Use `semanticdb-minor-mode-p' to determine if the mode has been turned
53on or off."
54 :group 'semanticdb
55 :type 'hook)
56
57(semantic-varalias-obsolete 'semanticdb-mode-hooks
58 'semanticdb-mode-hook)
59
60;;; Start/Stop database use 40;;; Start/Stop database use
61;; 41;;
62(defvar semanticdb-hooks 42(defvar semanticdb-hooks
@@ -80,32 +60,27 @@ on or off."
80 (symbol-value (car (cdr (car semanticdb-hooks)))))) 60 (symbol-value (car (cdr (car semanticdb-hooks))))))
81 61
82;;;###autoload 62;;;###autoload
83(defun global-semanticdb-minor-mode (&optional arg) 63(define-minor-mode global-semanticdb-minor-mode
84 "Toggle the use of `semanticdb-minor-mode'. 64 "Toggle Semantic DB mode.
85If ARG is positive, enable, if it is negative, disable. 65With ARG, turn Semantic DB mode on if ARG is positive, off otherwise.
86If ARG is nil, then toggle." 66
87 (interactive "P") 67In Semantic DB mode, Semantic parsers store results in a
88 (if (not arg) 68database, which can be saved for future Emacs sessions."
89 (if (semanticdb-minor-mode-p) 69 :global t
90 (setq arg -1) 70 :group 'semantic
91 (setq arg 1))) 71 (if global-semanticdb-minor-mode
92 (let ((fn 'add-hook) 72 ;; Enable
93 (h semanticdb-hooks) 73 (dolist (elt semanticdb-hooks)
94 (changed nil)) 74 (add-hook (cadr elt) (car elt)))
95 (if (< arg 0) 75 ;; Disable
96 (setq changed semanticdb-global-mode 76 (dolist (elt semanticdb-hooks)
97 semanticdb-global-mode nil 77 (add-hook (cadr elt) (car elt)))))
98 fn 'remove-hook) 78
99 (setq changed (not semanticdb-global-mode) 79(defvaralias 'semanticdb-mode-hook 'global-semanticdb-minor-mode-hook)
100 semanticdb-global-mode t)) 80(defvaralias 'semanticdb-global-mode 'global-semanticdb-minor-mode)
101 ;(message "ARG = %d" arg) 81(semantic-varalias-obsolete 'semanticdb-mode-hooks
102 (when changed 82 'global-semanticdb-minor-mode-hook)
103 (while h 83
104 (funcall fn (car (cdr (car h))) (car (car h)))
105 (setq h (cdr h)))
106 ;; Call a hook
107 (run-hooks 'semanticdb-mode-hook))
108 ))
109 84
110(defun semanticdb-toggle-global-mode () 85(defun semanticdb-toggle-global-mode ()
111 "Toggle use of the Semantic Database feature. 86 "Toggle use of the Semantic Database feature.
diff --git a/lisp/cedet/semantic/ede-grammar.el b/lisp/cedet/semantic/ede-grammar.el
new file mode 100644
index 00000000000..c23b489c837
--- /dev/null
+++ b/lisp/cedet/semantic/ede-grammar.el
@@ -0,0 +1,202 @@
1;;; semantic/ede-grammar.el --- EDE support for Semantic Grammar Files
2
3;;; Copyright (C) 2003, 2004, 2007, 2008, 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <zappo@gnu.org>
6;; Keywords: project, make
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software: you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation, either version 3 of the License, or
13;; (at your option) any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
22
23;;; Commentary:
24;;
25;; Handle .by or .wy files.
26
27(require 'semantic)
28(require 'ede/proj)
29(require 'ede/pmake)
30(require 'ede/pconf)
31(require 'ede/proj-elisp)
32(require 'semantic/grammar)
33
34;;; Code:
35(defclass semantic-ede-proj-target-grammar (ede-proj-target-makefile)
36 ((menu :initform nil)
37 (keybindings :initform nil)
38 (phony :initform t)
39 (sourcetype :initform
40 (semantic-ede-source-grammar-wisent
41 semantic-ede-source-grammar-bovine
42 ))
43 (availablecompilers :initform
44 (semantic-ede-grammar-compiler-wisent
45 semantic-ede-grammar-compiler-bovine
46 ))
47 )
48 "This target consists of a group of grammar files.
49A grammar target consists of grammar files that build Emacs Lisp programs for
50parsing different languages.")
51
52(defvar semantic-ede-source-grammar-wisent
53 (ede-sourcecode "semantic-ede-grammar-source-wisent"
54 :name "Wisent Grammar"
55 :sourcepattern "\\.wy$"
56 )
57 "Semantic Grammar source code definition for wisent.")
58
59(defclass semantic-ede-grammar-compiler-class (ede-compiler)
60 nil
61 "Specialized compiler for semantic grammars.")
62
63(defvar semantic-ede-grammar-compiler-wisent
64 (semantic-ede-grammar-compiler-class
65 "ede-emacs-wisent-compiler"
66 :name "emacs"
67 :variables '(("EMACS" . "emacs"))
68 :commands
69 '(
70 "@echo \"(add-to-list 'load-path nil)\" > grammar-make-script"
71 "@for loadpath in . ${LOADPATH}; do \\"
72 " echo \"(add-to-list 'load-path \\\"$$loadpath\\\")\" >> grammar-make-script; \\"
73 "done;"
74 "@echo \"(require 'semantic-load)\" >> grammar-make-script"
75 "@echo \"(require 'semantic-grammar)\" >> grammar-make-script"
76 ;; "@echo \"(setq debug-on-error t)\" >> grammar-make-script"
77 "\"$(EMACS)\" -batch --no-site-file -l grammar-make-script -f semantic-grammar-batch-build-packages $^"
78 )
79 ;; :autoconf '("AM_PATH_LISPDIR")
80 :sourcetype '(semantic-ede-source-grammar-wisent)
81 :objectextention "-wy.elc"
82 )
83 "Compile Emacs Lisp programs.")
84
85
86(defvar semantic-ede-source-grammar-bovine
87 (ede-sourcecode "semantic-ede-grammar-source-bovine"
88 :name "Bovine Grammar"
89 :sourcepattern "\\.by$"
90 )
91 "Semantic Grammar source code definition for the bovinator.")
92
93(defvar semantic-ede-grammar-compiler-bovine
94 (semantic-ede-grammar-compiler-class
95 "ede-emacs-wisent-compiler"
96 :name "emacs"
97 :variables '(("EMACS" . "emacs"))
98 :commands
99 '(
100 "@echo \"(add-to-list 'load-path nil)\" > grammar-make-script"
101 "@for loadpath in . ${LOADPATH}; do \\"
102 " echo \"(add-to-list 'load-path \\\"$$loadpath\\\")\" >> grammar-make-script; \\"
103 "done;"
104 "@echo \"(require 'semantic-load)\" >> grammar-make-script"
105 "@echo \"(require 'semantic-grammar)\" >> grammar-make-script"
106 ;; "@echo \"(setq debug-on-error t)\" >> grammar-make-script"
107 "\"$(EMACS)\" -batch --no-site-file -l grammar-make-script -f semantic-grammar-batch-build-packages $^"
108 )
109 ;; :autoconf '("AM_PATH_LISPDIR")
110 :sourcetype '(semantic-ede-source-grammar-bovine)
111 :objectextention "-by.elc"
112 )
113 "Compile Emacs Lisp programs.")
114
115;;; Target options.
116(defmethod ede-buffer-mine ((this semantic-ede-proj-target-grammar) buffer)
117 "Return t if object THIS lays claim to the file in BUFFER.
118Lays claim to all -by.el, and -wy.el files."
119 ;; We need to be a little more careful than this, but at the moment it
120 ;; is common to have only one target of this class per directory.
121 (if (string-match "-[bw]y\\.elc?$" (buffer-file-name buffer))
122 t
123 (call-next-method) ; The usual thing.
124 ))
125
126(defmethod project-compile-target ((obj semantic-ede-proj-target-grammar))
127 "Compile all sources in a Lisp target OBJ."
128 (let* ((cb (current-buffer))
129 (proj (ede-target-parent obj))
130 (default-directory (oref proj directory)))
131 (mapc (lambda (src)
132 (save-excursion
133 (set-buffer (find-file-noselect src))
134 (save-excursion
135 (semantic-grammar-create-package))
136 (save-buffer)
137 (let ((cf (concat (semantic-grammar-package) ".el")))
138 (if (or (not (file-exists-p cf))
139 (file-newer-than-file-p src cf))
140 (byte-compile-file cf)))))
141 (oref obj source)))
142 (message "All Semantic Grammar sources are up to date in %s" (object-name obj)))
143
144;;; Makefile generation functions
145;;
146(defmethod ede-proj-makefile-sourcevar ((this semantic-ede-proj-target-grammar))
147 "Return the variable name for THIS's sources."
148 (cond ((ede-proj-automake-p)
149 (error "No Automake support for Semantic Grammars"))
150 (t (concat (ede-pmake-varname this) "_SEMANTIC_GRAMMAR"))))
151
152(defmethod ede-proj-makefile-insert-variables :AFTER ((this semantic-ede-proj-target-grammar))
153 "Insert variables needed by target THIS."
154 (ede-proj-makefile-insert-loadpath-items
155 (ede-proj-elisp-packages-to-loadpath
156 (list "eieio" "semantic" "inversion" "ede")))
157 ;; eieio for object system needed in ede
158 ;; semantic because it is
159 ;; Inversion for versioning system.
160 ;; ede for project regeneration
161 (ede-pmake-insert-variable-shared
162 (concat (ede-pmake-varname this) "_SEMANTIC_GRAMMAR_EL")
163 (insert
164 (mapconcat (lambda (src)
165 (save-excursion
166 (set-buffer (find-file-noselect src))
167 (concat (semantic-grammar-package) ".el")))
168 (oref this source)
169 " ")))
170 )
171
172(defmethod ede-proj-makefile-insert-rules ((this semantic-ede-proj-target-grammar))
173 "Insert rules needed by THIS target."
174 ;; Add in some dependencies.
175;; (mapc (lambda (src)
176;; (let ((nm (file-name-sans-extension src)))
177;; (insert nm "-wy.el: " src "\n"
178;; nm "-wy.elc: " nm "-wy.el\n\n")
179;; ))
180;; (oref this source))
181 ;; Call the normal insertion of rules.
182 (call-next-method)
183 )
184
185(defmethod ede-proj-makefile-insert-dist-dependencies ((this semantic-ede-proj-target-grammar))
186 "Insert dist dependencies, or intermediate targets.
187This makes sure that all grammar lisp files are created before the dist
188runs, so they are always up to date.
189Argument THIS is the target that should insert stuff."
190 (call-next-method)
191 (insert " $(" (ede-pmake-varname this) "_SEMANTIC_GRAMMAR_EL)")
192 )
193
194;; (autoload 'ede-proj-target-elisp "ede/proj-elisp"
195;; "Target class for Emacs/Semantic grammar files." nil nil)
196
197(ede-proj-register-target "semantic grammar"
198 semantic-ede-proj-target-grammar)
199
200(provide 'semantic/ede-grammar)
201
202;;; semantic/ede-grammar.el ends here
diff --git a/lisp/cedet/semantic/grammar-wy.el b/lisp/cedet/semantic/grammar-wy.el
new file mode 100644
index 00000000000..ae1aec7b466
--- /dev/null
+++ b/lisp/cedet/semantic/grammar-wy.el
@@ -0,0 +1,478 @@
1;;; semantic/grammar-wy.el --- Generated parser support file
2
3;; Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
4
5;; Author: David Ponce <david@dponce.com>
6;; Keywords: syntax
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software: you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation, either version 3 of the License, or
13;; (at your option) any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
22
23;;; Commentary:
24;;
25;; This file is generated from the grammar file semantic-grammar.wy in
26;; the upstream CEDET repository.
27
28;;; Code:
29
30(require 'semantic/lex)
31(defvar semantic-grammar-lex-c-char-re)
32
33;; Current parsed nonterminal name.
34(defvar semantic-grammar-wy--nterm nil)
35;; Index of rule in a nonterminal clause.
36(defvar semantic-grammar-wy--rindx nil)
37
38;;; Declarations
39;;
40(defconst semantic-grammar-wy--keyword-table
41 (semantic-lex-make-keyword-table
42 '(("%default-prec" . DEFAULT-PREC)
43 ("%no-default-prec" . NO-DEFAULT-PREC)
44 ("%keyword" . KEYWORD)
45 ("%languagemode" . LANGUAGEMODE)
46 ("%left" . LEFT)
47 ("%nonassoc" . NONASSOC)
48 ("%package" . PACKAGE)
49 ("%prec" . PREC)
50 ("%put" . PUT)
51 ("%quotemode" . QUOTEMODE)
52 ("%right" . RIGHT)
53 ("%scopestart" . SCOPESTART)
54 ("%start" . START)
55 ("%token" . TOKEN)
56 ("%type" . TYPE)
57 ("%use-macros" . USE-MACROS))
58 'nil)
59 "Table of language keywords.")
60
61(defconst semantic-grammar-wy--token-table
62 (semantic-lex-make-type-table
63 '(("punctuation"
64 (GT . ">")
65 (LT . "<")
66 (OR . "|")
67 (SEMI . ";")
68 (COLON . ":"))
69 ("close-paren"
70 (RBRACE . "}")
71 (RPAREN . ")"))
72 ("open-paren"
73 (LBRACE . "{")
74 (LPAREN . "("))
75 ("block"
76 (BRACE_BLOCK . "(LBRACE RBRACE)")
77 (PAREN_BLOCK . "(LPAREN RPAREN)"))
78 ("code"
79 (EPILOGUE . "%%...EOF")
80 (PROLOGUE . "%{...%}"))
81 ("sexp"
82 (SEXP))
83 ("qlist"
84 (PREFIXED_LIST))
85 ("char"
86 (CHARACTER))
87 ("symbol"
88 (PERCENT_PERCENT . "\\`%%\\'")
89 (SYMBOL))
90 ("string"
91 (STRING)))
92 '(("punctuation" :declared t)
93 ("block" :declared t)
94 ("sexp" matchdatatype sexp)
95 ("sexp" syntax "\\=")
96 ("sexp" :declared t)
97 ("qlist" matchdatatype sexp)
98 ("qlist" syntax "\\s'\\s-*(")
99 ("qlist" :declared t)
100 ("char" syntax semantic-grammar-lex-c-char-re)
101 ("char" :declared t)
102 ("symbol" syntax ":?\\(\\sw\\|\\s_\\)+")
103 ("symbol" :declared t)
104 ("string" :declared t)
105 ("keyword" :declared t)))
106 "Table of lexical tokens.")
107
108(defconst semantic-grammar-wy--parse-table
109 (progn
110 (eval-when-compile
111 (require 'semantic/wisent/comp))
112 (wisent-compile-grammar
113 '((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)
114 nil
115 (grammar
116 ((prologue))
117 ((epilogue))
118 ((declaration))
119 ((nonterminal))
120 ((PERCENT_PERCENT)))
121 (prologue
122 ((PROLOGUE)
123 (wisent-raw-tag
124 (semantic-tag-new-code "prologue" nil))))
125 (epilogue
126 ((EPILOGUE)
127 (wisent-raw-tag
128 (semantic-tag-new-code "epilogue" nil))))
129 (declaration
130 ((decl)
131 (eval $1)))
132 (decl
133 ((default_prec_decl))
134 ((no_default_prec_decl))
135 ((languagemode_decl))
136 ((package_decl))
137 ((precedence_decl))
138 ((put_decl))
139 ((quotemode_decl))
140 ((scopestart_decl))
141 ((start_decl))
142 ((keyword_decl))
143 ((token_decl))
144 ((type_decl))
145 ((use_macros_decl)))
146 (default_prec_decl
147 ((DEFAULT-PREC)
148 `(wisent-raw-tag
149 (semantic-tag "default-prec" 'assoc :value
150 '("t")))))
151 (no_default_prec_decl
152 ((NO-DEFAULT-PREC)
153 `(wisent-raw-tag
154 (semantic-tag "default-prec" 'assoc :value
155 '("nil")))))
156 (languagemode_decl
157 ((LANGUAGEMODE symbols)
158 `(wisent-raw-tag
159 (semantic-tag ',(car $2)
160 'languagemode :rest ',(cdr $2)))))
161 (package_decl
162 ((PACKAGE SYMBOL)
163 `(wisent-raw-tag
164 (semantic-tag-new-package ',$2 nil))))
165 (precedence_decl
166 ((associativity token_type_opt items)
167 `(wisent-raw-tag
168 (semantic-tag ',$1 'assoc :type ',$2 :value ',$3))))
169 (associativity
170 ((LEFT)
171 (progn "left"))
172 ((RIGHT)
173 (progn "right"))
174 ((NONASSOC)
175 (progn "nonassoc")))
176 (put_decl
177 ((PUT put_name put_value)
178 `(wisent-raw-tag
179 (semantic-tag ',$2 'put :value ',(list $3))))
180 ((PUT put_name put_value_list)
181 `(wisent-raw-tag
182 (semantic-tag ',$2 'put :value ',$3)))
183 ((PUT put_name_list put_value)
184 `(wisent-raw-tag
185 (semantic-tag ',(car $2)
186 'put :rest ',(cdr $2)
187 :value ',(list $3))))
188 ((PUT put_name_list put_value_list)
189 `(wisent-raw-tag
190 (semantic-tag ',(car $2)
191 'put :rest ',(cdr $2)
192 :value ',$3))))
193 (put_name_list
194 ((BRACE_BLOCK)
195 (mapcar 'semantic-tag-name
196 (semantic-parse-region
197 (car $region1)
198 (cdr $region1)
199 'put_names 1))))
200 (put_names
201 ((LBRACE)
202 nil)
203 ((RBRACE)
204 nil)
205 ((put_name)
206 (wisent-raw-tag
207 (semantic-tag $1 'put-name))))
208 (put_name
209 ((SYMBOL))
210 ((token_type)))
211 (put_value_list
212 ((BRACE_BLOCK)
213 (mapcar 'semantic-tag-code-detail
214 (semantic-parse-region
215 (car $region1)
216 (cdr $region1)
217 'put_values 1))))
218 (put_values
219 ((LBRACE)
220 nil)
221 ((RBRACE)
222 nil)
223 ((put_value)
224 (wisent-raw-tag
225 (semantic-tag-new-code "put-value" $1))))
226 (put_value
227 ((SYMBOL any_value)
228 (cons $1 $2)))
229 (scopestart_decl
230 ((SCOPESTART SYMBOL)
231 `(wisent-raw-tag
232 (semantic-tag ',$2 'scopestart))))
233 (quotemode_decl
234 ((QUOTEMODE SYMBOL)
235 `(wisent-raw-tag
236 (semantic-tag ',$2 'quotemode))))
237 (start_decl
238 ((START symbols)
239 `(wisent-raw-tag
240 (semantic-tag ',(car $2)
241 'start :rest ',(cdr $2)))))
242 (keyword_decl
243 ((KEYWORD SYMBOL string_value)
244 `(wisent-raw-tag
245 (semantic-tag ',$2 'keyword :value ',$3))))
246 (token_decl
247 ((TOKEN token_type_opt SYMBOL string_value)
248 `(wisent-raw-tag
249 (semantic-tag ',$3 ',(if $2 'token 'keyword)
250 :type ',$2 :value ',$4)))
251 ((TOKEN token_type_opt symbols)
252 `(wisent-raw-tag
253 (semantic-tag ',(car $3)
254 'token :type ',$2 :rest ',(cdr $3)))))
255 (token_type_opt
256 (nil)
257 ((token_type)))
258 (token_type
259 ((LT SYMBOL GT)
260 (progn $2)))
261 (type_decl
262 ((TYPE token_type plist_opt)
263 `(wisent-raw-tag
264 (semantic-tag ',$2 'type :value ',$3))))
265 (plist_opt
266 (nil)
267 ((plist)))
268 (plist
269 ((plist put_value)
270 (append
271 (list $2)
272 $1))
273 ((put_value)
274 (list $1)))
275 (use_name_list
276 ((BRACE_BLOCK)
277 (mapcar 'semantic-tag-name
278 (semantic-parse-region
279 (car $region1)
280 (cdr $region1)
281 'use_names 1))))
282 (use_names
283 ((LBRACE)
284 nil)
285 ((RBRACE)
286 nil)
287 ((SYMBOL)
288 (wisent-raw-tag
289 (semantic-tag $1 'use-name))))
290 (use_macros_decl
291 ((USE-MACROS SYMBOL use_name_list)
292 `(wisent-raw-tag
293 (semantic-tag "macro" 'macro :type ',$2 :value ',$3))))
294 (string_value
295 ((STRING)
296 (read $1)))
297 (any_value
298 ((SYMBOL))
299 ((STRING))
300 ((PAREN_BLOCK))
301 ((PREFIXED_LIST))
302 ((SEXP)))
303 (symbols
304 ((lifo_symbols)
305 (nreverse $1)))
306 (lifo_symbols
307 ((lifo_symbols SYMBOL)
308 (cons $2 $1))
309 ((SYMBOL)
310 (list $1)))
311 (nonterminal
312 ((SYMBOL
313 (setq semantic-grammar-wy--nterm $1 semantic-grammar-wy--rindx 0)
314 COLON rules SEMI)
315 (wisent-raw-tag
316 (semantic-tag $1 'nonterminal :children $4))))
317 (rules
318 ((lifo_rules)
319 (apply 'nconc
320 (nreverse $1))))
321 (lifo_rules
322 ((lifo_rules OR rule)
323 (cons $3 $1))
324 ((rule)
325 (list $1)))
326 (rule
327 ((rhs)
328 (let*
329 ((nterm semantic-grammar-wy--nterm)
330 (rindx semantic-grammar-wy--rindx)
331 (rhs $1)
332 comps prec action elt)
333 (setq semantic-grammar-wy--rindx
334 (1+ semantic-grammar-wy--rindx))
335 (while rhs
336 (setq elt
337 (car rhs)
338 rhs
339 (cdr rhs))
340 (cond
341 ((vectorp elt)
342 (if prec
343 (error "duplicate %%prec in `%s:%d' rule" nterm rindx))
344 (setq prec
345 (aref elt 0)))
346 ((consp elt)
347 (if
348 (or action comps)
349 (setq comps
350 (cons elt comps)
351 semantic-grammar-wy--rindx
352 (1+ semantic-grammar-wy--rindx))
353 (setq action
354 (car elt))))
355 (t
356 (setq comps
357 (cons elt comps)))))
358 (wisent-cook-tag
359 (wisent-raw-tag
360 (semantic-tag
361 (format "%s:%d" nterm rindx)
362 'rule :type
363 (if comps "group" "empty")
364 :value comps :prec prec :expr action))))))
365 (rhs
366 (nil)
367 ((rhs item)
368 (cons $2 $1))
369 ((rhs action)
370 (cons
371 (list $2)
372 $1))
373 ((rhs PREC item)
374 (cons
375 (vector $3)
376 $1)))
377 (action
378 ((PAREN_BLOCK))
379 ((PREFIXED_LIST))
380 ((BRACE_BLOCK)
381 (format "(progn\n%s)"
382 (let
383 ((s $1))
384 (if
385 (string-match "^{[ \n ]*" s)
386 (setq s
387 (substring s
388 (match-end 0))))
389 (if
390 (string-match "[ \n ]*}$" s)
391 (setq s
392 (substring s 0
393 (match-beginning 0))))
394 s))))
395 (items
396 ((lifo_items)
397 (nreverse $1)))
398 (lifo_items
399 ((lifo_items item)
400 (cons $2 $1))
401 ((item)
402 (list $1)))
403 (item
404 ((SYMBOL))
405 ((CHARACTER))))
406 '(grammar prologue epilogue declaration nonterminal rule put_names put_values use_names)))
407 "Parser table.")
408
409(defun semantic-grammar-wy--install-parser ()
410 "Setup the Semantic Parser."
411 (semantic-install-function-overrides
412 '((parse-stream . wisent-parse-stream)))
413 (setq semantic-parser-name "LALR"
414 semantic--parse-table semantic-grammar-wy--parse-table
415 semantic-debug-parser-source "semantic-grammar.wy"
416 semantic-flex-keywords-obarray semantic-grammar-wy--keyword-table
417 semantic-lex-types-obarray semantic-grammar-wy--token-table)
418 ;; Collect unmatched syntax lexical tokens
419 (semantic-make-local-hook 'wisent-discarding-token-functions)
420 (add-hook 'wisent-discarding-token-functions
421 'wisent-collect-unmatched-syntax nil t))
422
423
424;;; Analyzers
425
426(define-lex-sexp-type-analyzer semantic-grammar-wy--<sexp>-sexp-analyzer
427 "sexp analyzer for <sexp> tokens."
428 "\\="
429 'SEXP)
430
431(define-lex-sexp-type-analyzer semantic-grammar-wy--<qlist>-sexp-analyzer
432 "sexp analyzer for <qlist> tokens."
433 "\\s'\\s-*("
434 'PREFIXED_LIST)
435
436(define-lex-keyword-type-analyzer semantic-grammar-wy--<keyword>-keyword-analyzer
437 "keyword analyzer for <keyword> tokens."
438 "\\(\\sw\\|\\s_\\)+")
439
440(define-lex-block-type-analyzer semantic-grammar-wy--<block>-block-analyzer
441 "block analyzer for <block> tokens."
442 "\\s(\\|\\s)"
443 '((("(" LPAREN PAREN_BLOCK)
444 ("{" LBRACE BRACE_BLOCK))
445 (")" RPAREN)
446 ("}" RBRACE))
447 )
448
449(define-lex-regex-type-analyzer semantic-grammar-wy--<char>-regexp-analyzer
450 "regexp analyzer for <char> tokens."
451 semantic-grammar-lex-c-char-re
452 nil
453 'CHARACTER)
454
455(define-lex-sexp-type-analyzer semantic-grammar-wy--<string>-sexp-analyzer
456 "sexp analyzer for <string> tokens."
457 "\\s\""
458 'STRING)
459
460(define-lex-regex-type-analyzer semantic-grammar-wy--<symbol>-regexp-analyzer
461 "regexp analyzer for <symbol> tokens."
462 ":?\\(\\sw\\|\\s_\\)+"
463 '((PERCENT_PERCENT . "\\`%%\\'"))
464 'SYMBOL)
465
466(define-lex-string-type-analyzer semantic-grammar-wy--<punctuation>-string-analyzer
467 "string analyzer for <punctuation> tokens."
468 "\\(\\s.\\|\\s$\\|\\s'\\)+"
469 '((GT . ">")
470 (LT . "<")
471 (OR . "|")
472 (SEMI . ";")
473 (COLON . ":"))
474 'punctuation)
475
476(provide 'semantic/grammar-wy)
477
478;;; semantic/grammar-wy.el ends here
diff --git a/lisp/cedet/semantic/grammar.el b/lisp/cedet/semantic/grammar.el
new file mode 100644
index 00000000000..5d947551d48
--- /dev/null
+++ b/lisp/cedet/semantic/grammar.el
@@ -0,0 +1,1912 @@
1;;; semantic/grammar.el --- Major mode framework for Semantic grammars
2
3;;; Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008, 2009
4;;; Free Software Foundation, Inc.
5
6;; Author: David Ponce <david@dponce.com>
7;; Maintainer: David Ponce <david@dponce.com>
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software: you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation, either version 3 of the License, or
14;; (at your option) any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23
24;;; Commentary:
25;;
26;; Major mode framework for editing Semantic's input grammar files.
27
28;;; History:
29;;
30
31;;; Code:
32
33(require 'semantic)
34(require 'semantic/ctxt)
35(require 'semantic/format)
36(require 'semantic/grammar-wy)
37(require 'semantic/idle)
38(declare-function semantic-momentary-highlight-tag "semantic/decorate")
39(declare-function semantic-analyze-context "semantic/analyze")
40(declare-function semantic-analyze-tags-of-class-list
41 "semantic/analyze/complete")
42
43
44;; (eval-when-compile
45;; (require 'semantic/analyze))
46
47(eval-when-compile
48 (require 'eldoc)
49 (require 'semantic/edit)
50 (require 'semantic/find))
51
52;;(require 'semantic/wisent)
53;; (require 'font-lock)
54;; (require 'pp)
55
56;; (eval-when-compile
57;; ;; (require 'senator)
58;; (require 'semantic/edit)
59;; (require 'semantic/find)
60;; (require 'semantic/format)
61;; (require 'semantic/idle))
62
63
64;;;;
65;;;; Set up lexer
66;;;;
67
68(defconst semantic-grammar-lex-c-char-re "'\\s\\?.'"
69 "Regexp matching C-like character literals.")
70
71;; Most of the analyzers are auto-generated from the grammar, but the
72;; following which need special handling code.
73;;
74(define-lex-regex-analyzer semantic-grammar-lex-prologue
75 "Detect and create a prologue token."
76 "\\<%{"
77 ;; Zing to the end of this brace block.
78 (semantic-lex-push-token
79 (semantic-lex-token
80 'PROLOGUE (point)
81 (save-excursion
82 (semantic-lex-unterminated-syntax-protection 'PROLOGUE
83 (forward-char)
84 (forward-sexp 1)
85 (point))))))
86
87(defsubst semantic-grammar-epilogue-start ()
88 "Return the start position of the grammar epilogue."
89 (save-excursion
90 (goto-char (point-min))
91 (if (re-search-forward "^\\s-*\\<%%\\>\\s-*$" nil t 2)
92 (match-beginning 0)
93 (1+ (point-max)))))
94
95(define-lex-regex-analyzer semantic-grammar-lex-epilogue
96 "Detect and create an epilogue or percent-percent token."
97 "\\<%%\\>"
98 (let ((start (match-beginning 0))
99 (end (match-end 0))
100 (class 'PERCENT_PERCENT))
101 (when (>= start (semantic-grammar-epilogue-start))
102 (setq class 'EPILOGUE
103 end (point-max)))
104 (semantic-lex-push-token
105 (semantic-lex-token class start end))))
106
107(define-lex semantic-grammar-lexer
108 "Lexical analyzer that handles Semantic grammar buffers.
109It ignores whitespaces, newlines and comments."
110 semantic-lex-ignore-newline
111 semantic-lex-ignore-whitespace
112 ;; Must detect prologue/epilogue before other symbols/keywords!
113 semantic-grammar-lex-prologue
114 semantic-grammar-lex-epilogue
115 semantic-grammar-wy--<keyword>-keyword-analyzer
116 semantic-grammar-wy--<symbol>-regexp-analyzer
117 semantic-grammar-wy--<char>-regexp-analyzer
118 semantic-grammar-wy--<string>-sexp-analyzer
119 ;; Must detect comments after strings because `comment-start-skip'
120 ;; regexp match semicolons inside strings!
121 semantic-lex-ignore-comments
122 ;; Must detect prefixed list before punctuation because prefix chars
123 ;; are also punctuations!
124 semantic-grammar-wy--<qlist>-sexp-analyzer
125 ;; Must detect punctuations after comments because the semicolon can
126 ;; be a punctuation or a comment start!
127 semantic-grammar-wy--<punctuation>-string-analyzer
128 semantic-grammar-wy--<block>-block-analyzer
129 semantic-grammar-wy--<sexp>-sexp-analyzer)
130
131;;; Test the lexer
132;;
133(defun semantic-grammar-lex-buffer ()
134 "Run `semantic-grammar-lex' on current buffer."
135 (interactive)
136 (semantic-lex-init)
137 (setq semantic-lex-analyzer 'semantic-grammar-lexer)
138 (let ((token-stream
139 (semantic-lex (point-min) (point-max))))
140 (with-current-buffer (get-buffer-create "*semantic-grammar-lex*")
141 (erase-buffer)
142 (pp token-stream (current-buffer))
143 (goto-char (point-min))
144 (pop-to-buffer (current-buffer)))))
145
146;;;;
147;;;; Semantic action expansion
148;;;;
149
150(defun semantic-grammar-ASSOC (&rest args)
151 "Return expansion of built-in ASSOC expression.
152ARGS are ASSOC's key value list."
153 (let ((key t))
154 `(semantic-tag-make-assoc-list
155 ,@(mapcar #'(lambda (i)
156 (prog1
157 (if key
158 (list 'quote i)
159 i)
160 (setq key (not key))))
161 args))))
162
163(defsubst semantic-grammar-quote-p (sym)
164 "Return non-nil if SYM is bound to the `quote' function."
165 (condition-case nil
166 (eq (indirect-function sym)
167 (indirect-function 'quote))
168 (error nil)))
169
170(defsubst semantic-grammar-backquote-p (sym)
171 "Return non-nil if SYM is bound to the `backquote' function."
172 (condition-case nil
173 (eq (indirect-function sym)
174 (indirect-function 'backquote))
175 (error nil)))
176
177;;;;
178;;;; API to access grammar tags
179;;;;
180
181(define-mode-local-override semantic-tag-components
182 semantic-grammar-mode (tag)
183 "Return the children of tag TAG."
184 (semantic-tag-get-attribute tag :children))
185
186(defun semantic-grammar-first-tag-name (class)
187 "Return the name of the first tag of class CLASS found.
188Warn if other tags of class CLASS exist."
189 (let* ((tags (semantic-find-tags-by-class
190 class (current-buffer))))
191 (if tags
192 (prog1
193 (semantic-tag-name (car tags))
194 (if (cdr tags)
195 (message "*** Ignore all but first declared %s"
196 class))))))
197
198(defun semantic-grammar-tag-symbols (class)
199 "Return the list of symbols defined in tags of class CLASS.
200That is tag names plus names defined in tag attribute `:rest'."
201 (let* ((tags (semantic-find-tags-by-class
202 class (current-buffer))))
203 (apply 'append
204 (mapcar
205 #'(lambda (tag)
206 (mapcar
207 'intern
208 (cons (semantic-tag-name tag)
209 (semantic-tag-get-attribute tag :rest))))
210 tags))))
211
212(defsubst semantic-grammar-item-text (item)
213 "Return the readable string form of ITEM."
214 (if (string-match semantic-grammar-lex-c-char-re item)
215 (concat "?" (substring item 1 -1))
216 item))
217
218(defsubst semantic-grammar-item-value (item)
219 "Return symbol or character value of ITEM string."
220 (if (string-match semantic-grammar-lex-c-char-re item)
221 (let ((c (read (concat "?" (substring item 1 -1)))))
222 (if (featurep 'xemacs)
223 ;; Handle characters as integers in XEmacs like in GNU Emacs.
224 (char-int c)
225 c))
226 (intern item)))
227
228(defun semantic-grammar-prologue ()
229 "Return grammar prologue code as a string value."
230 (let ((tag (semantic-find-first-tag-by-name
231 "prologue"
232 (semantic-find-tags-by-class 'code (current-buffer)))))
233 (if tag
234 (save-excursion
235 (concat
236 (buffer-substring
237 (progn
238 (goto-char (semantic-tag-start tag))
239 (skip-chars-forward "%{\r\n\t ")
240 (point))
241 (progn
242 (goto-char (semantic-tag-end tag))
243 (skip-chars-backward "\r\n\t %}")
244 (point)))
245 "\n"))
246 "")))
247
248(defun semantic-grammar-epilogue ()
249 "Return grammar epilogue code as a string value."
250 (let ((tag (semantic-find-first-tag-by-name
251 "epilogue"
252 (semantic-find-tags-by-class 'code (current-buffer)))))
253 (if tag
254 (save-excursion
255 (concat
256 (buffer-substring
257 (progn
258 (goto-char (semantic-tag-start tag))
259 (skip-chars-forward "%\r\n\t ")
260 (point))
261 (progn
262 (goto-char (semantic-tag-end tag))
263 (skip-chars-backward "\r\n\t")
264 ;; If a grammar footer is found, skip it.
265 (re-search-backward "^;;;\\s-+\\S-+\\s-+ends here"
266 (save-excursion
267 (beginning-of-line)
268 (point))
269 t)
270 (skip-chars-backward "\r\n\t")
271 (point)))
272 "\n"))
273 "")))
274
275(defsubst semantic-grammar-buffer-file (&optional buffer)
276 "Return name of file sans directory BUFFER is visiting.
277No argument or nil as argument means use the current buffer."
278 (file-name-nondirectory (buffer-file-name buffer)))
279
280(defun semantic-grammar-package ()
281 "Return the %package value as a string.
282If there is no %package statement in the grammar, return a default
283package name derived from the grammar file name. For example, the
284default package name for the grammar file foo.wy is foo-wy, and for
285foo.by it is foo-by."
286 (or (semantic-grammar-first-tag-name 'package)
287 (let* ((file (semantic-grammar-buffer-file))
288 (ext (file-name-extension file))
289 (i (string-match (format "\\([.]\\)%s\\'" ext) file)))
290 (concat (substring file 0 i) "-" ext))))
291
292(defsubst semantic-grammar-languagemode ()
293 "Return the %languagemode value as a list of symbols or nil."
294 (semantic-grammar-tag-symbols 'languagemode))
295
296(defsubst semantic-grammar-start ()
297 "Return the %start value as a list of symbols or nil."
298 (semantic-grammar-tag-symbols 'start))
299
300(defsubst semantic-grammar-scopestart ()
301 "Return the %scopestart value as a symbol or nil."
302 (intern (or (semantic-grammar-first-tag-name 'scopestart) "nil")))
303
304(defsubst semantic-grammar-quotemode ()
305 "Return the %quotemode value as a symbol or nil."
306 (intern (or (semantic-grammar-first-tag-name 'quotemode) "nil")))
307
308(defsubst semantic-grammar-keywords ()
309 "Return the language keywords.
310That is an alist of (VALUE . TOKEN) where VALUE is the string value of
311the keyword and TOKEN is the terminal symbol identifying the keyword."
312 (mapcar
313 #'(lambda (key)
314 (cons (semantic-tag-get-attribute key :value)
315 (intern (semantic-tag-name key))))
316 (semantic-find-tags-by-class 'keyword (current-buffer))))
317
318(defun semantic-grammar-keyword-properties (keywords)
319 "Return the list of KEYWORDS properties."
320 (let ((puts (semantic-find-tags-by-class
321 'put (current-buffer)))
322 put keys key plist assoc pkey pval props)
323 (while puts
324 (setq put (car puts)
325 puts (cdr puts)
326 keys (mapcar
327 'intern
328 (cons (semantic-tag-name put)
329 (semantic-tag-get-attribute put :rest))))
330 (while keys
331 (setq key (car keys)
332 keys (cdr keys)
333 assoc (rassq key keywords))
334 (if (null assoc)
335 nil ;;(message "*** %%put to undefined keyword %s ignored" key)
336 (setq key (car assoc)
337 plist (semantic-tag-get-attribute put :value))
338 (while plist
339 (setq pkey (intern (caar plist))
340 pval (read (cdar plist))
341 props (cons (list key pkey pval) props)
342 plist (cdr plist))))))
343 props))
344
345(defun semantic-grammar-tokens ()
346 "Return defined lexical tokens.
347That is an alist (TYPE . DEFS) where type is a %token <type> symbol
348and DEFS is an alist of (TOKEN . VALUE). TOKEN is the terminal symbol
349identifying the token and VALUE is the string value of the token or
350nil."
351 (let (tags alist assoc tag type term names value)
352
353 ;; Check for <type> in %left, %right & %nonassoc declarations
354 (setq tags (semantic-find-tags-by-class
355 'assoc (current-buffer)))
356 (while tags
357 (setq tag (car tags)
358 tags (cdr tags))
359 (when (setq type (semantic-tag-type tag))
360 (setq names (semantic-tag-get-attribute tag :value)
361 assoc (assoc type alist))
362 (or assoc (setq assoc (list type)
363 alist (cons assoc alist)))
364 (while names
365 (setq term (car names)
366 names (cdr names))
367 (or (string-match semantic-grammar-lex-c-char-re term)
368 (setcdr assoc (cons (list (intern term))
369 (cdr assoc)))))))
370
371 ;; Then process %token declarations so they can override any
372 ;; previous specifications
373 (setq tags (semantic-find-tags-by-class
374 'token (current-buffer)))
375 (while tags
376 (setq tag (car tags)
377 tags (cdr tags))
378 (setq names (cons (semantic-tag-name tag)
379 (semantic-tag-get-attribute tag :rest))
380 type (or (semantic-tag-type tag) "<no-type>")
381 value (semantic-tag-get-attribute tag :value)
382 assoc (assoc type alist))
383 (or assoc (setq assoc (list type)
384 alist (cons assoc alist)))
385 (while names
386 (setq term (intern (car names))
387 names (cdr names))
388 (setcdr assoc (cons (cons term value) (cdr assoc)))))
389 alist))
390
391(defun semantic-grammar-token-%type-properties (&optional props)
392 "Return properties set by %type statements.
393This declare a new type if necessary.
394If optional argument PROPS is non-nil, it is an existing list of
395properties where to add new properties."
396 (let (type)
397 (dolist (tag (semantic-find-tags-by-class 'type (current-buffer)))
398 (setq type (semantic-tag-name tag))
399 ;; Indicate to auto-generate the analyzer for this type
400 (push (list type :declared t) props)
401 (dolist (e (semantic-tag-get-attribute tag :value))
402 (push (list type (intern (car e)) (read (or (cdr e) "nil")))
403 props)))
404 props))
405
406(defun semantic-grammar-token-%put-properties (tokens)
407 "For types found in TOKENS, return properties set by %put statements."
408 (let (found props)
409 (dolist (put (semantic-find-tags-by-class 'put (current-buffer)))
410 (dolist (type (cons (semantic-tag-name put)
411 (semantic-tag-get-attribute put :rest)))
412 (setq found (assoc type tokens))
413 (if (null found)
414 nil ;; %put <type> ignored, no token defined
415 (setq type (car found))
416 (dolist (e (semantic-tag-get-attribute put :value))
417 (push (list type (intern (car e)) (read (or (cdr e) "nil")))
418 props)))))
419 props))
420
421(defsubst semantic-grammar-token-properties (tokens)
422 "Return properties of declared types.
423Types are explicitly declared by %type statements. Types found in
424TOKENS are those declared implicitly by %token statements.
425Properties can be set by %put and %type statements.
426Properties set by %type statements take precedence over those set by
427%put statements."
428 (let ((props (semantic-grammar-token-%put-properties tokens)))
429 (semantic-grammar-token-%type-properties props)))
430
431(defun semantic-grammar-use-macros ()
432 "Return macro definitions from %use-macros statements.
433Also load the specified macro libraries."
434 (let (lib defs)
435 (dolist (tag (semantic-find-tags-by-class 'macro (current-buffer)))
436 (setq lib (intern (semantic-tag-type tag)))
437 (condition-case nil
438 ;;(load lib) ;; Be sure to use the latest macro library.
439 (require lib)
440 (error nil))
441 (dolist (mac (semantic-tag-get-attribute tag :value))
442 (push (cons (intern mac)
443 (intern (format "%s-%s" lib mac)))
444 defs)))
445 (nreverse defs)))
446
447(defvar semantic-grammar-macros nil
448 "List of associations (MACRO-NAME . EXPANDER).")
449(make-variable-buffer-local 'semantic-grammar-macros)
450
451(defun semantic-grammar-macros ()
452 "Build and return the alist of defined macros."
453 (append
454 ;; Definitions found in tags.
455 (semantic-grammar-use-macros)
456 ;; Other pre-installed definitions.
457 semantic-grammar-macros))
458
459;;;;
460;;;; Overloaded functions that build parser data.
461;;;;
462
463;;; Keyword table builder
464;;
465(defun semantic-grammar-keywordtable-builder-default ()
466 "Return the default value of the keyword table."
467 (let ((keywords (semantic-grammar-keywords)))
468 `(semantic-lex-make-keyword-table
469 ',keywords
470 ',(semantic-grammar-keyword-properties keywords))))
471
472(define-overloadable-function semantic-grammar-keywordtable-builder ()
473 "Return the keyword table table value.")
474
475;;; Token table builder
476;;
477(defun semantic-grammar-tokentable-builder-default ()
478 "Return the default value of the table of lexical tokens."
479 (let ((tokens (semantic-grammar-tokens)))
480 `(semantic-lex-make-type-table
481 ',tokens
482 ',(semantic-grammar-token-properties tokens))))
483
484(define-overloadable-function semantic-grammar-tokentable-builder ()
485 "Return the value of the table of lexical tokens.")
486
487;;; Parser table builder
488;;
489(defun semantic-grammar-parsetable-builder-default ()
490 "Return the default value of the parse table."
491 (error "`semantic-grammar-parsetable-builder' not defined"))
492
493(define-overloadable-function semantic-grammar-parsetable-builder ()
494 "Return the parser table value.")
495
496;;; Parser setup code builder
497;;
498(defun semantic-grammar-setupcode-builder-default ()
499 "Return the default value of the setup code form."
500 (error "`semantic-grammar-setupcode-builder' not defined"))
501
502(define-overloadable-function semantic-grammar-setupcode-builder ()
503 "Return the parser setup code form.")
504
505;;;;
506;;;; Lisp code generation
507;;;;
508(defvar semantic--grammar-input-buffer nil)
509(defvar semantic--grammar-output-buffer nil)
510
511(defsubst semantic-grammar-keywordtable ()
512 "Return the variable name of the keyword table."
513 (concat (file-name-sans-extension
514 (semantic-grammar-buffer-file
515 semantic--grammar-output-buffer))
516 "--keyword-table"))
517
518(defsubst semantic-grammar-tokentable ()
519 "Return the variable name of the token table."
520 (concat (file-name-sans-extension
521 (semantic-grammar-buffer-file
522 semantic--grammar-output-buffer))
523 "--token-table"))
524
525(defsubst semantic-grammar-parsetable ()
526 "Return the variable name of the parse table."
527 (concat (file-name-sans-extension
528 (semantic-grammar-buffer-file
529 semantic--grammar-output-buffer))
530 "--parse-table"))
531
532(defsubst semantic-grammar-setupfunction ()
533 "Return the name of the parser setup function."
534 (concat (file-name-sans-extension
535 (semantic-grammar-buffer-file
536 semantic--grammar-output-buffer))
537 "--install-parser"))
538
539(defmacro semantic-grammar-as-string (object)
540 "Return OBJECT as a string value."
541 `(if (stringp ,object)
542 ,object
543 ;;(require 'pp)
544 (pp-to-string ,object)))
545
546(defun semantic-grammar-insert-defconst (name value docstring)
547 "Insert declaration of constant NAME with VALUE and DOCSTRING."
548 (let ((start (point)))
549 (insert (format "(defconst %s\n%s%S)\n\n" name value docstring))
550 (save-excursion
551 (goto-char start)
552 (indent-sexp))))
553
554(defun semantic-grammar-insert-defun (name body docstring)
555 "Insert declaration of function NAME with BODY and DOCSTRING."
556 (let ((start (point)))
557 (insert (format "(defun %s ()\n%S\n%s)\n\n" name docstring body))
558 (save-excursion
559 (goto-char start)
560 (indent-sexp))))
561
562(defun semantic-grammar-insert-define (define)
563 "Insert the declaration specified by DEFINE expression.
564Typically a DEFINE expression should look like this:
565
566\(define-thing name docstring expression1 ...)"
567 ;;(require 'pp)
568 (let ((start (point)))
569 (insert (format "(%S %S" (car define) (nth 1 define)))
570 (dolist (item (nthcdr 2 define))
571 (insert "\n")
572 (delete-blank-lines)
573 (pp item (current-buffer)))
574 (insert ")\n\n")
575 (save-excursion
576 (goto-char start)
577 (indent-sexp))))
578
579(defconst semantic-grammar-header-template
580 '("\
581;;; " file " --- Generated parser support file
582
583" copy "
584
585;; Author: " user-full-name " <" user-mail-address ">
586;; Created: " date "
587;; Keywords: syntax
588;; X-RCS: " vcid "
589
590;; This file is not part of GNU Emacs.
591;;
592;; This program is free software; you can redistribute it and/or
593;; modify it under the terms of the GNU General Public License as
594;; published by the Free Software Foundation; either version 2, or (at
595;; your option) any later version.
596;;
597;; This software is distributed in the hope that it will be useful,
598;; but WITHOUT ANY WARRANTY; without even the implied warranty of
599;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
600;; General Public License for more details.
601;;
602;; You should have received a copy of the GNU General Public License
603;; along with GNU Emacs; see the file COPYING. If not, write to the
604;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
605;; Boston, MA 02110-1301, USA.
606
607;;; Commentary:
608;;
609;; PLEASE DO NOT MANUALLY EDIT THIS FILE! It is automatically
610;; generated from the grammar file " gram ".
611
612;;; History:
613;;
614
615;;; Code:
616")
617 "Generated header template.
618The symbols in the template are local variables in
619`semantic-grammar-header'")
620
621(defconst semantic-grammar-footer-template
622 '("\
623
624\(provide '" libr ")
625
626;;; " file " ends here
627")
628 "Generated footer template.
629The symbols in the list are local variables in
630`semantic-grammar-footer'.")
631
632(defun semantic-grammar-copyright-line ()
633 "Return the grammar copyright line, or nil if not found."
634 (save-excursion
635 (goto-char (point-min))
636 (when (re-search-forward "^;;+[ \t]+Copyright (C) .*$"
637 ;; Search only in the four top lines
638 (save-excursion (forward-line 4) (point))
639 t)
640 (match-string 0))))
641
642(defun semantic-grammar-header ()
643 "Return text of a generated standard header."
644 (let ((file (semantic-grammar-buffer-file
645 semantic--grammar-output-buffer))
646 (gram (semantic-grammar-buffer-file))
647 (date (format-time-string "%Y-%m-%d %T%z"))
648 (vcid (concat "$" "Id" "$")) ;; Avoid expansion
649 ;; Try to get the copyright from the input grammar, or
650 ;; generate a new one if not found.
651 (copy (or (semantic-grammar-copyright-line)
652 (concat (format-time-string ";; Copyright (C) %Y ")
653 user-full-name)))
654 (out ""))
655 (dolist (S semantic-grammar-header-template)
656 (cond ((stringp S)
657 (setq out (concat out S)))
658 ((symbolp S)
659 (setq out (concat out (symbol-value S))))))
660 out))
661
662(defun semantic-grammar-footer ()
663 "Return text of a generated standard footer."
664 (let* ((file (semantic-grammar-buffer-file
665 semantic--grammar-output-buffer))
666 (libr (file-name-sans-extension file))
667 (out ""))
668 (dolist (S semantic-grammar-footer-template)
669 (cond ((stringp S)
670 (setq out (concat out S)))
671 ((symbolp S)
672 (setq out (concat out (symbol-value S))))))
673 out))
674
675(defun semantic-grammar-token-data ()
676 "Return the string value of the table of lexical tokens."
677 (semantic-grammar-as-string
678 (semantic-grammar-tokentable-builder)))
679
680(defun semantic-grammar-keyword-data ()
681 "Return the string value of the table of keywords."
682 (semantic-grammar-as-string
683 (semantic-grammar-keywordtable-builder)))
684
685(defun semantic-grammar-parser-data ()
686 "Return the parser table as a string value."
687 (semantic-grammar-as-string
688 (semantic-grammar-parsetable-builder)))
689
690(defun semantic-grammar-setup-data ()
691 "Return the parser setup code form as a string value."
692 (semantic-grammar-as-string
693 (semantic-grammar-setupcode-builder)))
694
695;;; Generation of lexical analyzers.
696;;
697(defvar semantic-grammar--lex-block-specs)
698
699(defsubst semantic-grammar--lex-delim-spec (block-spec)
700 "Return delimiters specification from BLOCK-SPEC."
701 (condition-case nil
702 (let* ((standard-input (cdr block-spec))
703 (delim-spec (read)))
704 (if (and (consp delim-spec)
705 (car delim-spec) (symbolp (car delim-spec))
706 (cadr delim-spec) (symbolp (cadr delim-spec)))
707 delim-spec
708 (error)))
709 (error
710 (error "Invalid delimiters specification %s in block token %s"
711 (cdr block-spec) (car block-spec)))))
712
713(defun semantic-grammar--lex-block-specs ()
714 "Compute lexical block specifications for the current buffer.
715Block definitions are read from the current table of lexical types."
716 (cond
717 ;; Block specifications have been parsed and are invalid.
718 ((eq semantic-grammar--lex-block-specs 'error)
719 nil
720 )
721 ;; Parse block specifications.
722 ((null semantic-grammar--lex-block-specs)
723 (condition-case err
724 (let* ((blocks (cdr (semantic-lex-type-value "block" t)))
725 (open-delims (cdr (semantic-lex-type-value "open-paren" t)))
726 (close-delims (cdr (semantic-lex-type-value "close-paren" t)))
727 olist clist block-spec delim-spec open-spec close-spec)
728 (dolist (block-spec blocks)
729 (setq delim-spec (semantic-grammar--lex-delim-spec block-spec)
730 open-spec (assq (car delim-spec) open-delims)
731 close-spec (assq (cadr delim-spec) close-delims))
732 (or open-spec
733 (error "Missing open-paren token %s required by block %s"
734 (car delim-spec) (car block-spec)))
735 (or close-spec
736 (error "Missing close-paren token %s required by block %s"
737 (cdr delim-spec) (car block-spec)))
738 ;; build alist ((OPEN-DELIM OPEN-SYM BLOCK-SYM) ...)
739 (push (list (cdr open-spec) (car open-spec) (car block-spec))
740 olist)
741 ;; build alist ((CLOSE-DELIM CLOSE-SYM) ...)
742 (push (list (cdr close-spec) (car close-spec))
743 clist))
744 (setq semantic-grammar--lex-block-specs (cons olist clist)))
745 (error
746 (setq semantic-grammar--lex-block-specs 'error)
747 (message "%s" (error-message-string err))
748 nil))
749 )
750 ;; Block specifications already parsed.
751 (t
752 semantic-grammar--lex-block-specs)))
753
754(defsubst semantic-grammar-quoted-form (exp)
755 "Return a quoted form of EXP if it isn't a self evaluating form."
756 (if (and (not (null exp))
757 (or (listp exp) (symbolp exp)))
758 (list 'quote exp)
759 exp))
760
761(defun semantic-grammar-insert-defanalyzer (type)
762 "Insert declaration of the lexical analyzer defined with TYPE."
763 (let* ((type-name (symbol-name type))
764 (type-value (symbol-value type))
765 (syntax (get type 'syntax))
766 (declared (get type :declared))
767 spec mtype prefix name doc)
768 ;; Generate an analyzer if the corresponding type has been
769 ;; explicitly declared in a %type statement, and if at least the
770 ;; syntax property has been provided.
771 (when (and declared syntax)
772 (setq prefix (file-name-sans-extension
773 (semantic-grammar-buffer-file
774 semantic--grammar-output-buffer))
775 mtype (or (get type 'matchdatatype) 'regexp)
776 name (intern (format "%s--<%s>-%s-analyzer" prefix type mtype))
777 doc (format "%s analyzer for <%s> tokens." mtype type))
778 (cond
779 ;; Regexp match analyzer
780 ((eq mtype 'regexp)
781 (semantic-grammar-insert-define
782 `(define-lex-regex-type-analyzer ,name
783 ,doc ,syntax
784 ,(semantic-grammar-quoted-form (cdr type-value))
785 ',(or (car type-value) (intern type-name))))
786 )
787 ;; String compare analyzer
788 ((eq mtype 'string)
789 (semantic-grammar-insert-define
790 `(define-lex-string-type-analyzer ,name
791 ,doc ,syntax
792 ,(semantic-grammar-quoted-form (cdr type-value))
793 ',(or (car type-value) (intern type-name))))
794 )
795 ;; Block analyzer
796 ((and (eq mtype 'block)
797 (setq spec (semantic-grammar--lex-block-specs)))
798 (semantic-grammar-insert-define
799 `(define-lex-block-type-analyzer ,name
800 ,doc ,syntax
801 ,(semantic-grammar-quoted-form spec)))
802 )
803 ;; Sexp analyzer
804 ((eq mtype 'sexp)
805 (semantic-grammar-insert-define
806 `(define-lex-sexp-type-analyzer ,name
807 ,doc ,syntax
808 ',(or (car type-value) (intern type-name))))
809 )
810 ;; keyword analyzer
811 ((eq mtype 'keyword)
812 (semantic-grammar-insert-define
813 `(define-lex-keyword-type-analyzer ,name
814 ,doc ,syntax))
815 )
816 ))
817 ))
818
819(defun semantic-grammar-insert-defanalyzers ()
820 "Insert declarations of lexical analyzers."
821 (let (tokens props)
822 (with-current-buffer semantic--grammar-input-buffer
823 (setq tokens (semantic-grammar-tokens)
824 props (semantic-grammar-token-properties tokens)))
825 (insert "(require 'semantic-lex)\n\n")
826 (let ((semantic-lex-types-obarray
827 (semantic-lex-make-type-table tokens props))
828 semantic-grammar--lex-block-specs)
829 (mapatoms 'semantic-grammar-insert-defanalyzer
830 semantic-lex-types-obarray))))
831
832;;; Generation of the grammar support file.
833;;
834(defcustom semantic-grammar-file-regexp "\\.[wb]y$"
835 "Regexp which matches grammar source files."
836 :group 'semantic
837 :type 'regexp)
838
839(defsubst semantic-grammar-noninteractive ()
840 "Return non-nil if running without interactive terminal."
841 (if (featurep 'xemacs)
842 (noninteractive)
843 noninteractive))
844
845(defun semantic-grammar-create-package (&optional force)
846 "Create package Lisp code from grammar in current buffer.
847Does nothing if the Lisp code seems up to date.
848If optional argument FORCE is non-nil, unconditionally re-generate the
849Lisp code."
850 (interactive "P")
851 (setq force (or force current-prefix-arg))
852 (semantic-fetch-tags)
853 (let* (
854 ;; Values of the following local variables are obtained from
855 ;; the grammar parsed tree in current buffer, that is before
856 ;; switching to the output file.
857 (package (semantic-grammar-package))
858 (output (concat package ".el"))
859 (semantic--grammar-input-buffer (current-buffer))
860 (semantic--grammar-output-buffer (find-file-noselect output))
861 (header (semantic-grammar-header))
862 (prologue (semantic-grammar-prologue))
863 (epilogue (semantic-grammar-epilogue))
864 (footer (semantic-grammar-footer))
865 )
866 (if (and (not force)
867 (not (buffer-modified-p))
868 (file-newer-than-file-p
869 (buffer-file-name semantic--grammar-output-buffer)
870 (buffer-file-name semantic--grammar-input-buffer)))
871 (message "Package `%s' is up to date." package)
872 ;; Create the package
873 (set-buffer semantic--grammar-output-buffer)
874 ;; Use Unix EOLs, so that the file is portable to all platforms.
875 (setq buffer-file-coding-system 'raw-text-unix)
876 (erase-buffer)
877 (unless (eq major-mode 'emacs-lisp-mode)
878 (emacs-lisp-mode))
879
880;;;; Header + Prologue
881
882 (insert header
883 " \n;;; Prologue\n;;\n"
884 prologue
885 )
886 ;; Evaluate the prologue now, because it might provide definition
887 ;; of grammar macro expanders.
888 (eval-region (point-min) (point))
889
890 (save-excursion
891
892;;;; Declarations
893
894 (insert " \n;;; Declarations\n;;\n")
895
896 ;; `eval-defun' is not necessary to reset `defconst' values.
897 (semantic-grammar-insert-defconst
898 (semantic-grammar-keywordtable)
899 (with-current-buffer semantic--grammar-input-buffer
900 (semantic-grammar-keyword-data))
901 "Table of language keywords.")
902
903 (semantic-grammar-insert-defconst
904 (semantic-grammar-tokentable)
905 (with-current-buffer semantic--grammar-input-buffer
906 (semantic-grammar-token-data))
907 "Table of lexical tokens.")
908
909 (semantic-grammar-insert-defconst
910 (semantic-grammar-parsetable)
911 (with-current-buffer semantic--grammar-input-buffer
912 (semantic-grammar-parser-data))
913 "Parser table.")
914
915 (semantic-grammar-insert-defun
916 (semantic-grammar-setupfunction)
917 (with-current-buffer semantic--grammar-input-buffer
918 (semantic-grammar-setup-data))
919 "Setup the Semantic Parser.")
920
921;;;; Analyzers
922 (insert " \n;;; Analyzers\n;;\n")
923
924 (semantic-grammar-insert-defanalyzers)
925
926;;;; Epilogue & Footer
927
928 (insert " \n;;; Epilogue\n;;\n"
929 epilogue
930 footer
931 )
932
933 )
934
935 (save-buffer 16)
936
937 ;; If running in batch mode, there is nothing more to do.
938 ;; Save the generated file and quit.
939 (if (semantic-grammar-noninteractive)
940 (let ((version-control t)
941 (delete-old-versions t)
942 (make-backup-files t)
943 (vc-make-backup-files t))
944 (kill-buffer (current-buffer)))
945 ;; If running interactively, eval declarations and epilogue
946 ;; code, then pop to the buffer visiting the generated file.
947 (eval-region (point) (point-max))
948 (goto-char (point-min))
949 (pop-to-buffer (current-buffer))
950 ;; The generated code has been evaluated and updated into
951 ;; memory. Now find all buffers that match the major modes we
952 ;; have created this language for, and force them to call our
953 ;; setup function again, refreshing all semantic data, and
954 ;; enabling them to work with the new code just created.
955;;;; FIXME?
956 ;; At this point, I don't know any user's defined setup code :-(
957 ;; At least, what I can do for now, is to run the generated
958 ;; parser-install function.
959 (semantic-map-mode-buffers
960 (semantic-grammar-setupfunction)
961 (semantic-grammar-languagemode)))
962 )
963 ;; Return the name of the generated package file.
964 output))
965
966(defun semantic-grammar-recreate-package ()
967 "Unconditionnaly create Lisp code from grammar in current buffer.
968Like \\[universal-argument] \\[semantic-grammar-create-package]."
969 (interactive)
970 (semantic-grammar-create-package t))
971
972(defun semantic-grammar-batch-build-one-package (file)
973 "Build a Lisp package from the grammar in FILE.
974That is, generate Lisp code from FILE, and `byte-compile' it.
975Return non-nil if there were no errors, nil if errors."
976 ;; We need this require so that we can find `byte-compile-dest-file'.
977 (require 'bytecomp)
978 (unless (auto-save-file-name-p file)
979 ;; Create the package
980 (let ((packagename
981 (condition-case err
982 (with-current-buffer (find-file-noselect file)
983 (semantic-grammar-create-package))
984 (error
985 (message "%s" (error-message-string err))
986 nil))))
987 (when packagename
988 ;; Only byte compile if out of date
989 (if (file-newer-than-file-p
990 packagename (byte-compile-dest-file packagename))
991 (let (;; Some complex grammar table expressions need a few
992 ;; more resources than the default.
993 (max-specpdl-size (max 3000 max-specpdl-size))
994 (max-lisp-eval-depth (max 1000 max-lisp-eval-depth))
995 )
996 ;; byte compile the resultant file
997 (byte-compile-file packagename))
998 t)))))
999
1000(defun semantic-grammar-batch-build-packages ()
1001 "Build Lisp packages from grammar files on the command line.
1002That is, run `semantic-grammar-batch-build-one-package' for each file.
1003Each file is processed even if an error occurred previously.
1004Must be used from the command line, with `-batch'.
1005For example, to process grammar files in current directory, invoke:
1006
1007 \"emacs -batch -f semantic-grammar-batch-build-packages .\".
1008
1009See also the variable `semantic-grammar-file-regexp'."
1010 (or (semantic-grammar-noninteractive)
1011 (error "\
1012`semantic-grammar-batch-build-packages' must be used with -batch"
1013 ))
1014 (let ((status 0)
1015 ;; Remove vc from find-file-hook. It causes bad stuff to
1016 ;; happen in Emacs 20.
1017 (find-file-hook (delete 'vc-find-file-hook find-file-hook)))
1018 (message "Compiling Grammars from: %s" (locate-library "semantic-grammar"))
1019 (dolist (arg command-line-args-left)
1020 (unless (and arg (file-exists-p arg))
1021 (error "Argument %s is not a valid file name" arg))
1022 (setq arg (expand-file-name arg))
1023 (if (file-directory-p arg)
1024 ;; Directory as argument
1025 (dolist (src (condition-case nil
1026 (directory-files
1027 arg nil semantic-grammar-file-regexp)
1028 (error
1029 (error "Unable to read directory files"))))
1030 (or (semantic-grammar-batch-build-one-package
1031 (expand-file-name src arg))
1032 (setq status 1)))
1033 ;; Specific file argument
1034 (or (semantic-grammar-batch-build-one-package arg)
1035 (setq status 1))))
1036 (kill-emacs status)
1037 ))
1038
1039;;;;
1040;;;; Macros highlighting
1041;;;;
1042
1043(defvar semantic--grammar-macros-regexp-1 nil)
1044(make-variable-buffer-local 'semantic--grammar-macros-regexp-1)
1045
1046(defun semantic--grammar-macros-regexp-1 ()
1047 "Return font-lock keyword regexp for pre-installed macro names."
1048 (and semantic-grammar-macros
1049 (not semantic--grammar-macros-regexp-1)
1050 (condition-case nil
1051 (setq semantic--grammar-macros-regexp-1
1052 (concat "(\\s-*"
1053 (regexp-opt
1054 (mapcar #'(lambda (e) (symbol-name (car e)))
1055 semantic-grammar-macros)
1056 t)
1057 "\\>"))
1058 (error nil)))
1059 semantic--grammar-macros-regexp-1)
1060
1061(defconst semantic--grammar-macdecl-re
1062 "\\<%use-macros\\>[ \t\r\n]+\\(\\sw\\|\\s_\\)+[ \t\r\n]+{"
1063 "Regexp that matches a macro declaration statement.")
1064
1065(defvar semantic--grammar-macros-regexp-2 nil)
1066(make-variable-buffer-local 'semantic--grammar-macros-regexp-2)
1067
1068(defun semantic--grammar-clear-macros-regexp-2 (&rest ignore)
1069 "Clear the cached regexp that match macros local in this grammar.
1070IGNORE arguments.
1071Added to `before-change-functions' hooks to be run before each text
1072change."
1073 (setq semantic--grammar-macros-regexp-2 nil))
1074
1075(defun semantic--grammar-macros-regexp-2 ()
1076 "Return the regexp that match macros local in this grammar."
1077 (unless semantic--grammar-macros-regexp-2
1078 (let (macs)
1079 (save-excursion
1080 (goto-char (point-min))
1081 (while (re-search-forward semantic--grammar-macdecl-re nil t)
1082 (condition-case nil
1083 (setq macs (nconc macs
1084 (split-string
1085 (buffer-substring-no-properties
1086 (point)
1087 (progn
1088 (backward-char)
1089 (forward-list 1)
1090 (down-list -1)
1091 (point))))))
1092 (error nil)))
1093 (when macs
1094 (setq semantic--grammar-macros-regexp-2
1095 (concat "(\\s-*" (regexp-opt macs t) "\\>"))))))
1096 semantic--grammar-macros-regexp-2)
1097
1098(defun semantic--grammar-macros-matcher (end)
1099 "Search for a grammar macro name to highlight.
1100END is the limit of the search."
1101 (let ((regexp (semantic--grammar-macros-regexp-1)))
1102 (or (and regexp (re-search-forward regexp end t))
1103 (and (setq regexp (semantic--grammar-macros-regexp-2))
1104 (re-search-forward regexp end t)))))
1105
1106;;;;
1107;;;; Define major mode
1108;;;;
1109
1110(defvar semantic-grammar-syntax-table
1111 (let ((table (make-syntax-table (standard-syntax-table))))
1112 (modify-syntax-entry ?\: "." table) ;; COLON
1113 (modify-syntax-entry ?\> "." table) ;; GT
1114 (modify-syntax-entry ?\< "." table) ;; LT
1115 (modify-syntax-entry ?\| "." table) ;; OR
1116 (modify-syntax-entry ?\; ". 12" table) ;; SEMI, Comment start ;;
1117 (modify-syntax-entry ?\n ">" table) ;; Comment end
1118 (modify-syntax-entry ?\" "\"" table) ;; String
1119 (modify-syntax-entry ?\% "w" table) ;; Word
1120 (modify-syntax-entry ?\- "_" table) ;; Symbol
1121 (modify-syntax-entry ?\. "_" table) ;; Symbol
1122 (modify-syntax-entry ?\\ "\\" table) ;; Quote
1123 (modify-syntax-entry ?\` "'" table) ;; Prefix ` (backquote)
1124 (modify-syntax-entry ?\' "'" table) ;; Prefix ' (quote)
1125 (modify-syntax-entry ?\, "'" table) ;; Prefix , (comma)
1126 (modify-syntax-entry ?\# "'" table) ;; Prefix # (sharp)
1127 table)
1128 "Syntax table used in a Semantic grammar buffers.")
1129
1130(defvar semantic-grammar-mode-hook nil
1131 "Hook run when starting Semantic grammar mode.")
1132
1133(defvar semantic-grammar-mode-keywords-1
1134 `(("\\(\\<%%\\>\\|\\<%[{}]\\)"
1135 0 font-lock-reference-face)
1136 ("\\(%\\)\\(\\(\\sw\\|\\s_\\)+\\)"
1137 (1 font-lock-reference-face)
1138 (2 font-lock-keyword-face))
1139 ("\\<error\\>"
1140 0 (unless (semantic-grammar-in-lisp-p) 'bold))
1141 ("^\\(\\(\\sw\\|\\s_\\)+\\)[ \n\r\t]*:"
1142 1 font-lock-function-name-face)
1143 (semantic--grammar-macros-matcher
1144 1 ,(if (boundp 'font-lock-builtin-face)
1145 'font-lock-builtin-face
1146 'font-lock-preprocessor-face))
1147 ("\\$\\(\\sw\\|\\s_\\)*"
1148 0 font-lock-variable-name-face)
1149 ("<\\(\\(\\sw\\|\\s_\\)+\\)>"
1150 1 font-lock-type-face)
1151 (,semantic-grammar-lex-c-char-re
1152 0 ,(if (boundp 'font-lock-constant-face)
1153 'font-lock-constant-face
1154 'font-lock-string-face) t)
1155 ;; Must highlight :keyword here, because ':' is a punctuation in
1156 ;; grammar mode!
1157 ("[\r\n\t ]+:\\sw+\\>"
1158 0 font-lock-builtin-face)
1159 ;; Append the Semantic keywords
1160 ,@semantic-fw-font-lock-keywords
1161 )
1162 "Font Lock keywords used to highlight Semantic grammar buffers.")
1163
1164(defvar semantic-grammar-mode-keywords-2
1165 (append semantic-grammar-mode-keywords-1
1166 lisp-font-lock-keywords-1)
1167 "Font Lock keywords used to highlight Semantic grammar buffers.")
1168
1169(defvar semantic-grammar-mode-keywords-3
1170 (append semantic-grammar-mode-keywords-1
1171 lisp-font-lock-keywords-2)
1172 "Font Lock keywords used to highlight Semantic grammar buffers.")
1173
1174(defvar semantic-grammar-mode-keywords
1175 semantic-grammar-mode-keywords-1
1176 "Font Lock keywords used to highlight Semantic grammar buffers.")
1177
1178(defvar semantic-grammar-map
1179 (let ((km (make-sparse-keymap)))
1180
1181 (define-key km "|" 'semantic-grammar-electric-punctuation)
1182 (define-key km ";" 'semantic-grammar-electric-punctuation)
1183 (define-key km "%" 'semantic-grammar-electric-punctuation)
1184 (define-key km "(" 'semantic-grammar-electric-punctuation)
1185 (define-key km ")" 'semantic-grammar-electric-punctuation)
1186 (define-key km ":" 'semantic-grammar-electric-punctuation)
1187
1188 (define-key km "\t" 'semantic-grammar-indent)
1189 (define-key km "\M-\t" 'semantic-grammar-complete)
1190 (define-key km "\C-c\C-c" 'semantic-grammar-create-package)
1191 (define-key km "\C-cm" 'semantic-grammar-find-macro-expander)
1192 (define-key km "\C-cik" 'semantic-grammar-insert-keyword)
1193;; (define-key km "\C-cc" 'semantic-grammar-generate-and-load)
1194;; (define-key km "\C-cr" 'semantic-grammar-generate-one-rule)
1195
1196 km)
1197 "Keymap used in `semantic-grammar-mode'.")
1198
1199(defvar semantic-grammar-menu
1200 '("Grammar"
1201 ["Indent Line" semantic-grammar-indent]
1202 ["Complete Symbol" semantic-grammar-complete]
1203 ["Find Macro" semantic-grammar-find-macro-expander]
1204 "--"
1205 ["Insert %keyword" semantic-grammar-insert-keyword]
1206 "--"
1207 ["Update Lisp Package" semantic-grammar-create-package]
1208 ["Recreate Lisp Package" semantic-grammar-recreate-package]
1209 )
1210 "Common semantic grammar menu.")
1211
1212(defun semantic-grammar-setup-menu-emacs (symbol mode-menu)
1213 "Setup a GNU Emacs grammar menu in variable SYMBOL.
1214MODE-MENU is an optional specific menu whose items are appended to the
1215common grammar menu."
1216 (let ((items (make-symbol "items")))
1217 `(unless (boundp ',symbol)
1218 (easy-menu-define ,symbol (current-local-map)
1219 "Grammar Menu" semantic-grammar-menu)
1220 (let ((,items (cdr ,mode-menu)))
1221 (when ,items
1222 (easy-menu-add-item ,symbol nil "--")
1223 (while ,items
1224 (easy-menu-add-item ,symbol nil (car ,items))
1225 (setq ,items (cdr ,items))))))
1226 ))
1227
1228(defun semantic-grammar-setup-menu-xemacs (symbol mode-menu)
1229 "Setup an XEmacs grammar menu in variable SYMBOL.
1230MODE-MENU is an optional specific menu whose items are appended to the
1231common grammar menu."
1232 (let ((items (make-symbol "items"))
1233 (path (make-symbol "path")))
1234 `(progn
1235 (unless (boundp ',symbol)
1236 (easy-menu-define ,symbol nil
1237 "Grammar Menu" (copy-sequence semantic-grammar-menu)))
1238 (easy-menu-add ,symbol)
1239 (let ((,items (cdr ,mode-menu))
1240 (,path (list (car ,symbol))))
1241 (when ,items
1242 (easy-menu-add-item nil ,path "--")
1243 (while ,items
1244 (easy-menu-add-item nil ,path (car ,items))
1245 (setq ,items (cdr ,items))))))
1246 ))
1247
1248(defmacro semantic-grammar-setup-menu (&optional mode-menu)
1249 "Setup a mode local grammar menu.
1250MODE-MENU is an optional specific menu whose items are appended to the
1251common grammar menu."
1252 (let ((menu (intern (format "%s-menu" major-mode))))
1253 (if (featurep 'xemacs)
1254 (semantic-grammar-setup-menu-xemacs menu mode-menu)
1255 (semantic-grammar-setup-menu-emacs menu mode-menu))))
1256
1257(defsubst semantic-grammar-in-lisp-p ()
1258 "Return non-nil if point is in Lisp code."
1259 (or (>= (point) (semantic-grammar-epilogue-start))
1260 (condition-case nil
1261 (save-excursion
1262 (up-list -1)
1263 t)
1264 (error nil))))
1265
1266(defun semantic-grammar-edits-new-change-hook-fcn (overlay)
1267 "Function set into `semantic-edits-new-change-hook'.
1268Argument OVERLAY is the overlay created to mark the change.
1269When OVERLAY marks a change in the scope of a nonterminal tag extend
1270the change bounds to encompass the whole nonterminal tag."
1271 (let ((outer (car (semantic-find-tag-by-overlay-in-region
1272 (semantic-edits-os overlay)
1273 (semantic-edits-oe overlay)))))
1274 (if (semantic-tag-of-class-p outer 'nonterminal)
1275 (semantic-overlay-move overlay
1276 (semantic-tag-start outer)
1277 (semantic-tag-end outer)))))
1278
1279(defun semantic-grammar-mode ()
1280 "Initialize a buffer for editing Semantic grammars.
1281
1282\\{semantic-grammar-map}"
1283 (interactive)
1284 (kill-all-local-variables)
1285 (setq major-mode 'semantic-grammar-mode
1286 mode-name "Semantic Grammar Framework")
1287 (set (make-local-variable 'parse-sexp-ignore-comments) t)
1288 (set (make-local-variable 'comment-start) ";;")
1289 ;; Look within the line for a ; following an even number of backslashes
1290 ;; after either a non-backslash or the line beginning.
1291 (set (make-local-variable 'comment-start-skip)
1292 "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *")
1293 (set-syntax-table semantic-grammar-syntax-table)
1294 (use-local-map semantic-grammar-map)
1295 (set (make-local-variable 'indent-line-function)
1296 'semantic-grammar-indent)
1297 (set (make-local-variable 'fill-paragraph-function)
1298 'lisp-fill-paragraph)
1299 (set (make-local-variable 'font-lock-multiline)
1300 'undecided)
1301 (set (make-local-variable 'font-lock-defaults)
1302 '((semantic-grammar-mode-keywords
1303 semantic-grammar-mode-keywords-1
1304 semantic-grammar-mode-keywords-2
1305 semantic-grammar-mode-keywords-3)
1306 nil ;; perform string/comment fontification
1307 nil ;; keywords are case sensitive.
1308 ;; This puts _ & - as a word constituant,
1309 ;; simplifying our keywords significantly
1310 ((?_ . "w") (?- . "w"))))
1311 ;; Setup Semantic to parse grammar
1312 (semantic-grammar-wy--install-parser)
1313 (setq semantic-lex-comment-regex ";;"
1314 semantic-lex-analyzer 'semantic-grammar-lexer
1315 semantic-type-relation-separator-character '(":")
1316 semantic-symbol->name-assoc-list
1317 '(
1318 (code . "Setup Code")
1319 (keyword . "Keyword")
1320 (token . "Token")
1321 (nonterminal . "Nonterminal")
1322 (rule . "Rule")
1323 ))
1324 (set (make-local-variable 'semantic-format-face-alist)
1325 '(
1326 (code . default)
1327 (keyword . font-lock-keyword-face)
1328 (token . font-lock-type-face)
1329 (nonterminal . font-lock-function-name-face)
1330 (rule . default)
1331 ))
1332 (set (make-local-variable 'semantic-stickyfunc-sticky-classes)
1333 '(nonterminal))
1334 ;; Before each change, clear the cached regexp used to highlight
1335 ;; macros local in this grammar.
1336 (semantic-make-local-hook 'before-change-functions)
1337 (add-hook 'before-change-functions
1338 'semantic--grammar-clear-macros-regexp-2 nil t)
1339 ;; Handle safe re-parse of grammar rules.
1340 (semantic-make-local-hook 'semantic-edits-new-change-hooks)
1341 (add-hook 'semantic-edits-new-change-hooks
1342 'semantic-grammar-edits-new-change-hook-fcn
1343 nil t)
1344 (semantic-run-mode-hooks 'semantic-grammar-mode-hook))
1345
1346;;;;
1347;;;; Useful commands
1348;;;;
1349
1350(defvar semantic-grammar-skip-quoted-syntax-table
1351 (let ((st (copy-syntax-table semantic-grammar-syntax-table)))
1352 (modify-syntax-entry ?\' "$" st)
1353 st)
1354 "Syntax table to skip a whole quoted expression in grammar code.
1355Consider quote as a \"paired delimiter\", so `forward-sexp' will skip
1356whole quoted expression.")
1357
1358(defsubst semantic-grammar-backward-item ()
1359 "Move point to beginning of the previous grammar item."
1360 (forward-comment (- (point-max)))
1361 (if (zerop (skip-syntax-backward "."))
1362 (if (eq (char-before) ?\')
1363 (with-syntax-table
1364 ;; Can't be Lisp code here! Temporarily consider quote
1365 ;; as a "paired delimiter", so `forward-sexp' can skip
1366 ;; the whole quoted expression.
1367 semantic-grammar-skip-quoted-syntax-table
1368 (forward-sexp -1))
1369 (forward-sexp -1))))
1370
1371(defun semantic-grammar-anchored-indentation ()
1372 "Return indentation based on previous anchor character found."
1373 (let (indent)
1374 (save-excursion
1375 (while (not indent)
1376 (semantic-grammar-backward-item)
1377 (cond
1378 ((bobp)
1379 (setq indent 0))
1380 ((looking-at ":\\(\\s-\\|$\\)")
1381 (setq indent (current-column))
1382 (forward-char)
1383 (skip-syntax-forward "-")
1384 (if (eolp) (setq indent 2))
1385 )
1386 ((and (looking-at "[;%]")
1387 (not (looking-at "\\<%prec\\>")))
1388 (setq indent 0)
1389 ))))
1390 indent))
1391
1392(defun semantic-grammar-do-grammar-indent ()
1393 "Indent a line of grammar.
1394When called the point is not in Lisp code."
1395 (let (indent n)
1396 (save-excursion
1397 (beginning-of-line)
1398 (skip-syntax-forward "-")
1399 (setq indent (current-column))
1400 (cond
1401 ((or (bobp)
1402 (looking-at "\\(\\w\\|\\s_\\)+\\s-*:")
1403 (and (looking-at "%")
1404 (not (looking-at "%prec\\>"))))
1405 (setq n 0))
1406 ((looking-at ":")
1407 (setq n 2))
1408 ((and (looking-at ";;")
1409 (save-excursion (forward-comment (point-max))
1410 (looking-at ":")))
1411 (setq n 1))
1412 (t
1413 (setq n (semantic-grammar-anchored-indentation))
1414 (unless (zerop n)
1415 (cond
1416 ((looking-at ";;")
1417 (setq n (1- n)))
1418 ((looking-at "[|;]")
1419 )
1420 (t
1421 (setq n (+ n 2)))))))
1422 (when (/= n indent)
1423 (beginning-of-line)
1424 (delete-horizontal-space)
1425 (indent-to n)))))
1426
1427(defvar semantic-grammar-brackets-as-parens-syntax-table
1428 (let ((st (copy-syntax-table emacs-lisp-mode-syntax-table)))
1429 (modify-syntax-entry ?\{ "(} " st)
1430 (modify-syntax-entry ?\} "){ " st)
1431 st)
1432 "Syntax table that consider brackets as parenthesis.
1433So `lisp-indent-line' will work inside bracket blocks.")
1434
1435(defun semantic-grammar-do-lisp-indent ()
1436 "Maybe run the Emacs Lisp indenter on a line of code.
1437Return nil if not in a Lisp expression."
1438 (condition-case nil
1439 (save-excursion
1440 (beginning-of-line)
1441 (skip-chars-forward "\t ")
1442 (let ((first (point)))
1443 (or (>= first (semantic-grammar-epilogue-start))
1444 (up-list -1))
1445 (condition-case nil
1446 (while t
1447 (up-list -1))
1448 (error nil))
1449 (beginning-of-line)
1450 (save-restriction
1451 (narrow-to-region (point) first)
1452 (goto-char (point-max))
1453 (with-syntax-table
1454 ;; Temporarily consider brackets as parenthesis so
1455 ;; `lisp-indent-line' can indent Lisp code inside
1456 ;; brackets.
1457 semantic-grammar-brackets-as-parens-syntax-table
1458 (lisp-indent-line))))
1459 t)
1460 (error nil)))
1461
1462(defun semantic-grammar-indent ()
1463 "Indent the current line.
1464Use the Lisp or grammar indenter depending on point location."
1465 (interactive)
1466 (let ((orig (point))
1467 first)
1468 (or (semantic-grammar-do-lisp-indent)
1469 (semantic-grammar-do-grammar-indent))
1470 (setq first (save-excursion
1471 (beginning-of-line)
1472 (skip-chars-forward "\t ")
1473 (point)))
1474 (if (or (< orig first) (/= orig (point)))
1475 (goto-char first))))
1476
1477(defun semantic-grammar-electric-punctuation ()
1478 "Insert and reindent for the symbol just typed in."
1479 (interactive)
1480 (self-insert-command 1)
1481 (save-excursion
1482 (semantic-grammar-indent)))
1483
1484(defun semantic-grammar-complete ()
1485 "Attempt to complete the symbol under point.
1486Completion is position sensitive. If the cursor is in a match section of
1487a rule, then nonterminals symbols are scanned. If the cursor is in a Lisp
1488expression then Lisp symbols are completed."
1489 (interactive)
1490 (if (semantic-grammar-in-lisp-p)
1491 ;; We are in lisp code. Do lisp completion.
1492 (lisp-complete-symbol)
1493 ;; We are not in lisp code. Do rule completion.
1494 (let* ((nonterms (semantic-find-tags-by-class 'nonterminal (current-buffer)))
1495 (sym (car (semantic-ctxt-current-symbol)))
1496 (ans (try-completion sym nonterms)))
1497 (cond ((eq ans t)
1498 ;; All done
1499 (message "Symbols is already complete"))
1500 ((and (stringp ans) (string= ans sym))
1501 ;; Max matchable. Show completions.
1502 (with-output-to-temp-buffer "*Completions*"
1503 (display-completion-list (all-completions sym nonterms)))
1504 )
1505 ((stringp ans)
1506 ;; Expand the completions
1507 (forward-sexp -1)
1508 (delete-region (point) (progn (forward-sexp 1) (point)))
1509 (insert ans))
1510 (t (message "No Completions."))
1511 ))
1512 ))
1513
1514(defun semantic-grammar-insert-keyword (name)
1515 "Insert a new %keyword declaration with NAME.
1516Assumes it is typed in with the correct casing."
1517 (interactive "sKeyword: ")
1518 (if (not (bolp)) (insert "\n"))
1519 (insert "%keyword " (upcase name) " \"" name "\"
1520%put " (upcase name) " summary
1521\"\"\n")
1522 (forward-char -2))
1523
1524;;; Macro facilities
1525;;
1526
1527(defsubst semantic--grammar-macro-function-tag (name)
1528 "Search for a function tag for the grammar macro with name NAME.
1529Return the tag found or nil if not found."
1530 (car (semantic-find-tags-by-class
1531 'function
1532 (or (semantic-find-tags-by-name name (current-buffer))
1533 (and (featurep 'semanticdb)
1534 semanticdb-current-database
1535 (cdar (semanticdb-find-tags-by-name name nil t)))))))
1536
1537(defsubst semantic--grammar-macro-lib-part (def)
1538 "Return the library part of the grammar macro defined by DEF."
1539 (let ((suf (format "-%s\\'" (regexp-quote (symbol-name (car def)))))
1540 (fun (symbol-name (cdr def))))
1541 (substring fun 0 (string-match suf fun))))
1542
1543(defun semantic--grammar-macro-compl-elt (def &optional full)
1544 "Return a completion entry for the grammar macro defined by DEF.
1545If optional argument FULL is non-nil qualify the macro name with the
1546library found in DEF."
1547 (let ((mac (car def))
1548 (lib (semantic--grammar-macro-lib-part def)))
1549 (cons (if full
1550 (format "%s/%s" mac lib)
1551 (symbol-name mac))
1552 (list mac lib))))
1553
1554(defun semantic--grammar-macro-compl-dict ()
1555 "Return a completion dictionnary of macro definitions."
1556 (let ((defs (semantic-grammar-macros))
1557 def dups dict)
1558 (while defs
1559 (setq def (car defs)
1560 defs (cdr defs))
1561 (if (or (assoc (car def) defs) (assoc (car def) dups))
1562 (push def dups)
1563 (push (semantic--grammar-macro-compl-elt def) dict)))
1564 (while dups
1565 (setq def (car dups)
1566 dups (cdr dups))
1567 (push (semantic--grammar-macro-compl-elt def t) dict))
1568 dict))
1569
1570(defun semantic-grammar-find-macro-expander (macro-name library)
1571 "Visit the Emacs Lisp library where a grammar macro is implemented.
1572MACRO-NAME is a symbol that identifies a grammar macro.
1573LIBRARY is the name (sans extension) of the Emacs Lisp library where
1574to start searching the macro implementation. Lookup in included
1575libraries, if necessary.
1576Find a function tag (in current tags table) whose name contains MACRO-NAME.
1577Select the buffer containing the tag's definition, and move point there."
1578 (interactive
1579 (let* ((dic (semantic--grammar-macro-compl-dict))
1580 (def (assoc (completing-read "Macro: " dic nil 1) dic)))
1581 (or (cdr def) '(nil nil))))
1582 (when (and macro-name library)
1583 (let* ((lib (format "%s.el" library))
1584 (buf (find-file-noselect (or (locate-library lib t) lib)))
1585 (tag (with-current-buffer buf
1586 (semantic--grammar-macro-function-tag
1587 (format "%s-%s" library macro-name)))))
1588 (if tag
1589 (progn
1590 (require 'semantic/decorate)
1591 (pop-to-buffer (semantic-tag-buffer tag))
1592 (goto-char (semantic-tag-start tag))
1593 (semantic-momentary-highlight-tag tag))
1594 (pop-to-buffer buf)
1595 (message "No expander found in library %s for macro %s"
1596 library macro-name)))))
1597
1598;;; Additional help
1599;;
1600
1601(defvar semantic-grammar-syntax-help
1602 `(
1603 ;; Lexical Symbols
1604 ("symbol" . "Syntax: A symbol of alpha numeric and symbol characters")
1605 ("number" . "Syntax: Numeric characters.")
1606 ("punctuation" . "Syntax: Punctuation character.")
1607 ("semantic-list" . "Syntax: A list delimited by any valid list characters")
1608 ("open-paren" . "Syntax: Open Parenthesis character")
1609 ("close-paren" . "Syntax: Close Parenthesis character")
1610 ("string" . "Syntax: String character delimited text")
1611 ("comment" . "Syntax: Comment character delimited text")
1612 ;; Special Macros
1613 ("EMPTY" . "Syntax: Match empty text")
1614 ("ASSOC" . "Lambda Key: (ASSOC key1 value1 key2 value2 ...)")
1615 ("EXPAND" . "Lambda Key: (EXPAND <list id> <rule>)")
1616 ("EXPANDFULL" . "Lambda Key: (EXPANDFULL <list id> <rule>)")
1617 ;; Tag Generator Macros
1618 ("TAG" . "Generic Tag Generation: (TAG <name> <tag-class> [ :key value ]*)")
1619 ("VARIABLE-TAG" . "(VARIABLE-TAG <name> <lang-type> <default-value> [ :key value ]*)")
1620 ("FUNCTION-TAG" . "(FUNCTION-TAG <name> <lang-type> <arg-list> [ :key value ]*)")
1621 ("TYPE-TAG" . "(TYPE-TAG <name> <lang-type> <part-list> <parents> [ :key value ]*)")
1622 ("INCLUDE-TAG" . "(INCLUDE-TAG <name> <system-flag> [ :key value ]*)")
1623 ("PACKAGE-TAG" . "(PACKAGE-TAG <name> <detail> [ :key value ]*)")
1624 ("CODE-TAG" . "(CODE-TAG <name> <detail> [ :key value ]*)")
1625 ("ALIAS-TAG" . "(ALIAS-TAG <name> <aliasclass> <definition> [:key value]*)")
1626 ;; Special value macros
1627 ("$1" . "Match Value: Value from match list in slot 1")
1628 ("$2" . "Match Value: Value from match list in slot 2")
1629 ("$3" . "Match Value: Value from match list in slot 3")
1630 ("$4" . "Match Value: Value from match list in slot 4")
1631 ("$5" . "Match Value: Value from match list in slot 5")
1632 ("$6" . "Match Value: Value from match list in slot 6")
1633 ("$7" . "Match Value: Value from match list in slot 7")
1634 ("$8" . "Match Value: Value from match list in slot 8")
1635 ("$9" . "Match Value: Value from match list in slot 9")
1636 ;; Same, but with annoying , in front.
1637 (",$1" . "Match Value: Value from match list in slot 1")
1638 (",$2" . "Match Value: Value from match list in slot 2")
1639 (",$3" . "Match Value: Value from match list in slot 3")
1640 (",$4" . "Match Value: Value from match list in slot 4")
1641 (",$5" . "Match Value: Value from match list in slot 5")
1642 (",$6" . "Match Value: Value from match list in slot 6")
1643 (",$7" . "Match Value: Value from match list in slot 7")
1644 (",$8" . "Match Value: Value from match list in slot 8")
1645 (",$9" . "Match Value: Value from match list in slot 9")
1646 )
1647 "Association of syntax elements, and the corresponding help.")
1648
1649(defun semantic-grammar-eldoc-get-macro-docstring (macro expander)
1650 "Return a one-line docstring for the given grammar MACRO.
1651EXPANDER is the name of the function that expands MACRO."
1652 (require 'eldoc)
1653 (if (and (eq expander (aref eldoc-last-data 0))
1654 (eq 'function (aref eldoc-last-data 2)))
1655 (aref eldoc-last-data 1)
1656 (let ((doc (help-split-fundoc (documentation expander t) expander)))
1657 (cond
1658 (doc
1659 (setq doc (car doc))
1660 (string-match "\\`[^ )]* ?" doc)
1661 (setq doc (concat "(" (substring doc (match-end 0)))))
1662 (t
1663 (setq doc (eldoc-function-argstring expander))))
1664 (when doc
1665 (setq doc
1666 (eldoc-docstring-format-sym-doc
1667 macro (format "==> %s %s" expander doc) 'default))
1668 (eldoc-last-data-store expander doc 'function))
1669 doc)))
1670
1671(define-mode-local-override semantic-idle-summary-current-symbol-info
1672 semantic-grammar-mode ()
1673 "Display additional eldoc information about grammar syntax elements.
1674Syntax element is the current symbol at point.
1675If it is associated a help string in `semantic-grammar-syntax-help',
1676return that string.
1677If it is a macro name, return a description of the associated expander
1678function parameter list.
1679If it is a function name, return a description of this function
1680parameter list.
1681It it is a variable name, return a brief (one-line) documentation
1682string for the variable.
1683If a default description of the current context can be obtained,
1684return it.
1685Otherwise return nil."
1686 (require 'eldoc)
1687 (let* ((elt (car (semantic-ctxt-current-symbol)))
1688 (val (and elt (cdr (assoc elt semantic-grammar-syntax-help)))))
1689 (when (and (not val) elt (semantic-grammar-in-lisp-p))
1690 ;; Ensure to load macro definitions before doing `intern-soft'.
1691 (setq val (semantic-grammar-macros)
1692 elt (intern-soft elt)
1693 val (and elt (cdr (assq elt val))))
1694 (cond
1695 ;; Grammar macro
1696 ((and val (fboundp val))
1697 (setq val (semantic-grammar-eldoc-get-macro-docstring elt val)))
1698 ;; Function
1699 ((and elt (fboundp elt))
1700 (setq val (eldoc-get-fnsym-args-string elt)))
1701 ;; Variable
1702 ((and elt (boundp elt))
1703 (setq val (eldoc-get-var-docstring elt)))
1704 (t nil)))
1705 (or val (semantic-idle-summary-current-symbol-info-default))))
1706
1707(define-mode-local-override semantic-tag-boundary-p
1708 semantic-grammar-mode (tag)
1709 "Return non-nil for tags that should have a boundary drawn.
1710Only tags of type 'nonterminal will be so marked."
1711 (let ((c (semantic-tag-class tag)))
1712 (eq c 'nonterminal)))
1713
1714(define-mode-local-override semantic-ctxt-current-function
1715 semantic-grammar-mode (&optional point)
1716 "Determine the name of the current function at POINT."
1717 (save-excursion
1718 (and point (goto-char point))
1719 (when (semantic-grammar-in-lisp-p)
1720 (with-mode-local emacs-lisp-mode
1721 (semantic-ctxt-current-function)))))
1722
1723(define-mode-local-override semantic-ctxt-current-argument
1724 semantic-grammar-mode (&optional point)
1725 "Determine the argument index of the called function at POINT."
1726 (save-excursion
1727 (and point (goto-char point))
1728 (when (semantic-grammar-in-lisp-p)
1729 (with-mode-local emacs-lisp-mode
1730 (semantic-ctxt-current-argument)))))
1731
1732(define-mode-local-override semantic-ctxt-current-assignment
1733 semantic-grammar-mode (&optional point)
1734 "Determine the tag being assigned into at POINT."
1735 (save-excursion
1736 (and point (goto-char point))
1737 (when (semantic-grammar-in-lisp-p)
1738 (with-mode-local emacs-lisp-mode
1739 (semantic-ctxt-current-assignment)))))
1740
1741(define-mode-local-override semantic-ctxt-current-class-list
1742 semantic-grammar-mode (&optional point)
1743 "Determine the class of tags that can be used at POINT."
1744 (save-excursion
1745 (and point (goto-char point))
1746 (if (semantic-grammar-in-lisp-p)
1747 (with-mode-local emacs-lisp-mode
1748 (semantic-ctxt-current-class-list))
1749 '(nonterminal keyword))))
1750
1751(define-mode-local-override semantic-ctxt-current-mode
1752 semantic-grammar-mode (&optional point)
1753 "Return the major mode active at POINT.
1754POINT defaults to the value of point in current buffer.
1755Return `emacs-lisp-mode' is POINT is within Lisp code, otherwise
1756return the current major mode."
1757 (save-excursion
1758 (and point (goto-char point))
1759 (if (semantic-grammar-in-lisp-p)
1760 'emacs-lisp-mode
1761 (semantic-ctxt-current-mode-default))))
1762
1763(define-mode-local-override semantic-format-tag-abbreviate
1764 semantic-grammar-mode (tag &optional parent color)
1765 "Return a string abbreviation of TAG.
1766Optional PARENT is not used.
1767Optional COLOR is used to flag if color is added to the text."
1768 (let ((class (semantic-tag-class tag))
1769 (name (semantic-format-tag-name tag parent color)))
1770 (cond
1771 ((eq class 'nonterminal)
1772 (concat name ":"))
1773 ((eq class 'setting)
1774 "%settings%")
1775 ((memq class '(rule keyword))
1776 name)
1777 (t
1778 (concat "%" (symbol-name class) " " name)))))
1779
1780(define-mode-local-override semantic-format-tag-summarize
1781 semantic-grammar-mode (tag &optional parent color)
1782 "Return a string summarizing TAG.
1783Optional PARENT is not used.
1784Optional argument COLOR determines if color is added to the text."
1785 (let ((class (semantic-tag-class tag))
1786 (name (semantic-format-tag-name tag parent color))
1787 (label nil)
1788 (desc nil))
1789 (cond
1790 ((eq class 'nonterminal)
1791 (setq label "Nonterminal: "
1792 desc (format
1793 " with %d match lists."
1794 (length (semantic-tag-components tag)))))
1795 ((eq class 'keyword)
1796 (setq label "Keyword: ")
1797 (let (summary)
1798 (semantic--find-tags-by-function
1799 #'(lambda (put)
1800 (unless summary
1801 (setq summary (cdr (assoc "summary"
1802 (semantic-tag-get-attribute
1803 put :value))))))
1804 ;; Get `put' tag with TAG name.
1805 (semantic-find-tags-by-name-regexp
1806 (regexp-quote (semantic-tag-name tag))
1807 (semantic-find-tags-by-class 'put (current-buffer))))
1808 (setq desc (concat " = "
1809 (semantic-tag-get-attribute tag :value)
1810 (if summary
1811 (concat " - " (read summary))
1812 "")))))
1813 ((eq class 'token)
1814 (setq label "Token: ")
1815 (let ((val (semantic-tag-get-attribute tag :value))
1816 (names (semantic-tag-get-attribute tag :rest))
1817 (type (semantic-tag-type tag)))
1818 (if names
1819 (setq name (mapconcat 'identity (cons name names) " ")))
1820 (setq desc (concat
1821 (if type
1822 (format " <%s>" type)
1823 "")
1824 (if val
1825 (format "%s%S" val (if type " " ""))
1826 "")))))
1827 ((eq class 'assoc)
1828 (setq label "Assoc: ")
1829 (let ((val (semantic-tag-get-attribute tag :value))
1830 (type (semantic-tag-type tag)))
1831 (setq desc (concat
1832 (if type
1833 (format " <%s>" type)
1834 "")
1835 (if val
1836 (concat " " (mapconcat 'identity val " "))
1837 "")))))
1838 (t
1839 (setq desc (semantic-format-tag-abbreviate tag parent color))))
1840 (if (and color label)
1841 (setq label (semantic--format-colorize-text label 'label)))
1842 (if (and color label desc)
1843 (setq desc (semantic--format-colorize-text desc 'comment)))
1844 (if label
1845 (concat label name desc)
1846 ;; Just a description is the abbreviated version
1847 desc)))
1848
1849;;; Semantic Analysis
1850
1851(define-mode-local-override semantic-analyze-current-context
1852 semantic-grammar-mode (point)
1853 "Provide a semantic analysis object describing a context in a grammar."
1854 (require 'semantic/analyze)
1855 (if (semantic-grammar-in-lisp-p)
1856 (with-mode-local emacs-lisp-mode
1857 (semantic-analyze-current-context point))
1858
1859 (let* ((context-return nil)
1860 (prefixandbounds (semantic-ctxt-current-symbol-and-bounds))
1861 (prefix (car prefixandbounds))
1862 (bounds (nth 2 prefixandbounds))
1863 (prefixsym nil)
1864 (prefixclass (semantic-ctxt-current-class-list))
1865 )
1866
1867 ;; Do context for rules when in a match list.
1868 (setq prefixsym
1869 (semantic-find-first-tag-by-name
1870 (car prefix)
1871 (current-buffer)))
1872
1873 (setq context-return
1874 (semantic-analyze-context
1875 "context-for-semantic-grammar"
1876 :buffer (current-buffer)
1877 :scope nil
1878 :bounds bounds
1879 :prefix (if prefixsym
1880 (list prefixsym)
1881 prefix)
1882 :prefixtypes nil
1883 :prefixclass prefixclass
1884 ))
1885
1886 context-return)))
1887
1888(define-mode-local-override semantic-analyze-possible-completions
1889 semantic-grammar-mode (context)
1890 "Return a list of possible completions based on CONTEXT."
1891 (require 'semantic/analyze/complete)
1892 (if (semantic-grammar-in-lisp-p)
1893 (with-mode-local emacs-lisp-mode
1894 (semantic-analyze-possible-completions context))
1895 (save-excursion
1896 (set-buffer (oref context buffer))
1897 (let* ((prefix (car (oref context :prefix)))
1898 (completetext (cond ((semantic-tag-p prefix)
1899 (semantic-tag-name prefix))
1900 ((stringp prefix)
1901 prefix)
1902 ((stringp (car prefix))
1903 (car prefix))))
1904 (tags (semantic-find-tags-for-completion completetext
1905 (current-buffer))))
1906 (semantic-analyze-tags-of-class-list
1907 tags (oref context prefixclass)))
1908 )))
1909
1910(provide 'semantic/grammar)
1911
1912;;; semantic/grammar.el ends here
generated by cgit v1.2.1 (git 2.18.0) at 2026-01-12 15:35:20 +0000