aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorChong Yidong2009-09-20 21:06:41 +0000
committerChong Yidong2009-09-20 21:06:41 +0000
commit4d902e6f13f6bf5d304a0cbcff33e2780a825206 (patch)
tree20c5dbf4febbaff55e22b4fa0e950cf552e88e70
parent70702e9b0ea781fb955c66320c935bc0a8e1d0f1 (diff)
downloademacs-4d902e6f13f6bf5d304a0cbcff33e2780a825206.tar.gz
emacs-4d902e6f13f6bf5d304a0cbcff33e2780a825206.zip
lisp/cedet/srecode.el:
lisp/cedet/srecode/*.el: test/cedet/srecode-tests.el: New files lisp/files.el (auto-mode-alist): Use srecode-template-mode for .srt files. lisp/cedet/semantic/bovine/scm.el: Add local vars section for autoloading.
Diffstat
-rw-r--r--lisp/ChangeLog1
-rw-r--r--lisp/cedet/semantic/bovine/scm.el6
-rw-r--r--lisp/cedet/srecode.el53
-rw-r--r--lisp/cedet/srecode/args.el188
-rw-r--r--lisp/cedet/srecode/compile.el640
-rw-r--r--lisp/cedet/srecode/cpp.el149
-rw-r--r--lisp/cedet/srecode/ctxt.el247
-rw-r--r--lisp/cedet/srecode/dictionary.el565
-rw-r--r--lisp/cedet/srecode/document.el841
-rw-r--r--lisp/cedet/srecode/el.el113
-rw-r--r--lisp/cedet/srecode/expandproto.el132
-rw-r--r--lisp/cedet/srecode/extract.el242
-rw-r--r--lisp/cedet/srecode/fields.el438
-rw-r--r--lisp/cedet/srecode/filters.el56
-rw-r--r--lisp/cedet/srecode/find.el261
-rw-r--r--lisp/cedet/srecode/getset.el366
-rw-r--r--lisp/cedet/srecode/insert.el983
-rw-r--r--lisp/cedet/srecode/java.el62
-rw-r--r--lisp/cedet/srecode/map.el415
-rw-r--r--lisp/cedet/srecode/mode.el420
-rw-r--r--lisp/cedet/srecode/semantic.el431
-rw-r--r--lisp/cedet/srecode/srt-mode.el775
-rw-r--r--lisp/cedet/srecode/srt-wy.el277
-rw-r--r--lisp/cedet/srecode/srt.el106
-rw-r--r--lisp/cedet/srecode/table.el248
-rw-r--r--lisp/cedet/srecode/template.el69
-rw-r--r--lisp/cedet/srecode/texi.el282
-rw-r--r--lisp/files.el1
-rw-r--r--test/cedet/srecode-tests.el266
29 files changed, 8633 insertions, 0 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 77137241a48..eeb2e331bd6 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -9,6 +9,7 @@
9 * progmodes/autoconf.el: Provide autoconf as well. 9 * progmodes/autoconf.el: Provide autoconf as well.
10 10
11 * files.el (auto-mode-alist): Use emacs-lisp-mode for Project.ede. 11 * files.el (auto-mode-alist): Use emacs-lisp-mode for Project.ede.
12 (auto-mode-alist): Use srecode-template-mode for .srt files.
12 13
13 * cedet/semantic/bovine/gcc.el (semantic-gcc-test-output-parser) 14 * cedet/semantic/bovine/gcc.el (semantic-gcc-test-output-parser)
14 (semantic-gcc-test-output-parser-this-machine): 15 (semantic-gcc-test-output-parser-this-machine):
diff --git a/lisp/cedet/semantic/bovine/scm.el b/lisp/cedet/semantic/bovine/scm.el
index e57390157ce..3558062d61d 100644
--- a/lisp/cedet/semantic/bovine/scm.el
+++ b/lisp/cedet/semantic/bovine/scm.el
@@ -115,4 +115,10 @@ syntax as specified by the syntax table."
115 115
116(provide 'semantic/bovine/scm) 116(provide 'semantic/bovine/scm)
117 117
118;; Local variables:
119;; generated-autoload-file: "../loaddefs.el"
120;; generated-autoload-feature: semantic/loaddefs
121;; generated-autoload-load-name: "semantic/bovine/scm"
122;; End:
123
118;;; semantic/bovine/scm.el ends here 124;;; semantic/bovine/scm.el ends here
diff --git a/lisp/cedet/srecode.el b/lisp/cedet/srecode.el
new file mode 100644
index 00000000000..bb87865cc90
--- /dev/null
+++ b/lisp/cedet/srecode.el
@@ -0,0 +1,53 @@
1;;; srecode.el --- Semantic buffer evaluator.
2
3;;; Copyright (C) 2005, 2007, 2008, 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <zappo@gnu.org>
6;; Keywords: codegeneration
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;; Semantic does the job of converting source code into useful tag
26;; information. The set of `semantic-format-tag' functions has one
27;; function that will create a prototype of a tag, which has severe
28;; issues of complexity (in the format tag file itself) and inaccuracy
29;; (for the purpose of C++ code.)
30;;
31;; Contemplation of the simplistic problem within the scope of
32;; semantic showed that the solution was more complex than could
33;; possibly be handled in semantic-format.el. Semantic Recode, or
34;; srecode is a rich API for generating code out of semantic tags, or
35;; recoding the tags.
36;;
37;; See the srecode manual for specific details.
38
39(require 'eieio)
40(require 'mode-local)
41(require 'srecode/loaddefs)
42
43(defvar srecode-version "1.0pre7"
44 "Current version of the Semantic Recoder.")
45
46;;; Code:
47(defgroup srecode nil
48 "Semantic Recoder."
49 :group 'tools)
50
51(provide 'srecode)
52
53;;; srecode.el ends here
diff --git a/lisp/cedet/srecode/args.el b/lisp/cedet/srecode/args.el
new file mode 100644
index 00000000000..0d45831e9fc
--- /dev/null
+++ b/lisp/cedet/srecode/args.el
@@ -0,0 +1,188 @@
1;;; srecode/args.el --- Provide some simple template arguments
2
3;;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <eric@siege-engine.com>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;
24;; Srecode templates can accept arguments. These arguments represent
25;; sets of dictionary words that need to be derived. This file contains
26;; a set of simple arguments for srecode templates.
27
28(require 'srecode/insert)
29
30;;; Code:
31
32;;; :blank
33;;
34;; Using :blank means that the template should force blank lines
35;; before and after the template, reguardless of where the insertion
36;; is occuring.
37(defun srecode-semantic-handle-:blank (dict)
38 "Add macros into the dictionary DICT specifying blank line spacing.
39The wrapgap means make sure the first and last lines of the macro
40do not contain any text from preceeding or following text."
41 ;; This won't actually get used, but it might be nice
42 ;; to know about it.
43 (srecode-dictionary-set-value dict "BLANK" t)
44 )
45
46;;; :indent ARGUMENT HANDLING
47;;
48;; When a :indent argument is required, the default is to indent
49;; for the current major mode.
50(defun srecode-semantic-handle-:indent (dict)
51 "Add macros into the dictionary DICT for indentation."
52 (srecode-dictionary-set-value dict "INDENT" t)
53 )
54
55;;; :region ARGUMENT HANDLING
56;;
57;; When a :region argument is required, provide macros that
58;; deal with that active region.
59;;
60;; Regions allow a macro to wrap the region text within the
61;; template bounds.
62;;
63(defvar srecode-handle-region-when-non-active-flag nil
64 "Non-nil means do region handling w/out the region being active.")
65
66(defun srecode-semantic-handle-:region (dict)
67 "Add macros into the dictionary DICT based on the current :region."
68 ;; Only enable the region section if we can clearly show that
69 ;; the user is intending to do something with the region.
70 (when (or srecode-handle-region-when-non-active-flag
71 (eq last-command 'mouse-drag-region)
72 (and transient-mark-mode mark-active))
73 ;; Show the region section
74 (srecode-dictionary-show-section dict "REGION")
75 (srecode-dictionary-set-value
76 dict "REGIONTEXT" (buffer-substring-no-properties (point) (mark)))
77 ;; Only whack the region if our template output
78 ;; is also destined for the current buffer.
79 (when (eq standard-output (current-buffer))
80 (kill-region (point) (mark))))
81 )
82
83;;; :user ARGUMENT HANDLING
84;;
85;; When a :user argument is required, fill the dictionary with
86;; information about the current Emacs user.
87(defun srecode-semantic-handle-:user (dict)
88 "Add macros into the dictionary DICT based on the current :user."
89 (srecode-dictionary-set-value dict "AUTHOR" (user-full-name))
90 (srecode-dictionary-set-value dict "LOGIN" (user-login-name))
91 (srecode-dictionary-set-value dict "EMAIL" user-mail-address)
92 (srecode-dictionary-set-value dict "EMACSINITFILE" user-init-file)
93 (srecode-dictionary-set-value dict "UID" (user-uid))
94 )
95
96;;; :time ARGUMENT HANDLING
97;;
98;; When a :time argument is required, fill the dictionary with
99;; information about the current Emacs time.
100(defun srecode-semantic-handle-:time (dict)
101 "Add macros into the dictionary DICT based on the current :time."
102 ;; DATE Values
103 (srecode-dictionary-set-value
104 dict "YEAR" (format-time-string "%Y" (current-time)))
105 (srecode-dictionary-set-value
106 dict "MONTHNAME" (format-time-string "%B" (current-time)))
107 (srecode-dictionary-set-value
108 dict "MONTH" (format-time-string "%m" (current-time)))
109 (srecode-dictionary-set-value
110 dict "DAY" (format-time-string "%d" (current-time)))
111 (srecode-dictionary-set-value
112 dict "WEEKDAY" (format-time-string "%a" (current-time)))
113 ;; Time Values
114 (srecode-dictionary-set-value
115 dict "HOUR" (format-time-string "%H" (current-time)))
116 (srecode-dictionary-set-value
117 dict "HOUR12" (format-time-string "%l" (current-time)))
118 (srecode-dictionary-set-value
119 dict "AMPM" (format-time-string "%p" (current-time)))
120 (srecode-dictionary-set-value
121 dict "MINUTE" (format-time-string "%M" (current-time)))
122 (srecode-dictionary-set-value
123 dict "SECOND" (format-time-string "%S" (current-time)))
124 (srecode-dictionary-set-value
125 dict "TIMEZONE" (format-time-string "%Z" (current-time)))
126 ;; Convenience pre-packed date/time
127 (srecode-dictionary-set-value
128 dict "DATE" (format-time-string "%D" (current-time)))
129 (srecode-dictionary-set-value
130 dict "TIME" (format-time-string "%X" (current-time)))
131 )
132
133;;; :file ARGUMENT HANDLING
134;;
135;; When a :file argument is required, fill the dictionary with
136;; information about the file Emacs is editing at the time of
137;; insertion.
138(defun srecode-semantic-handle-:file (dict)
139 "Add macros into the dictionary DICT based on the current :file."
140 (let* ((bfn (buffer-file-name))
141 (file (file-name-nondirectory bfn))
142 (dir (file-name-directory bfn)))
143 (srecode-dictionary-set-value dict "FILENAME" file)
144 (srecode-dictionary-set-value dict "FILE" (file-name-sans-extension file))
145 (srecode-dictionary-set-value dict "EXTENSION" (file-name-extension file))
146 (srecode-dictionary-set-value dict "DIRECTORY" dir)
147 (srecode-dictionary-set-value dict "MODE" (symbol-name major-mode))
148 (srecode-dictionary-set-value
149 dict "SHORTMODE"
150 (let* ((mode-name (symbol-name major-mode))
151 (match (string-match "-mode" mode-name)))
152 (if match
153 (substring mode-name 0 match)
154 mode-name)))
155 (if (or (file-exists-p "CVS")
156 (file-exists-p "RCS"))
157 (srecode-dictionary-show-section dict "RCS")
158 )))
159
160;;; :system ARGUMENT HANDLING
161;;
162;; When a :system argument is required, fill the dictionary with
163;; information about the computer Emacs is running on.
164(defun srecode-semantic-handle-:system (dict)
165 "Add macros into the dictionary DICT based on the current :system."
166 (srecode-dictionary-set-value dict "SYSTEMCONF" system-configuration)
167 (srecode-dictionary-set-value dict "SYSTEMTYPE" system-type)
168 (srecode-dictionary-set-value dict "SYSTEMNAME" (system-name))
169 (srecode-dictionary-set-value dict "MAILHOST" (or mail-host-address
170 (system-name)))
171 )
172
173;;; :kill ARGUMENT HANDLING
174;;
175;; When a :kill argument is required, fill the dictionary with
176;; information about the current kill ring.
177(defun srecode-semantic-handle-:kill (dict)
178 "Add macros into the dictionary DICT based on the kill ring."
179 (srecode-dictionary-set-value dict "KILL" (car kill-ring))
180 (srecode-dictionary-set-value dict "KILL2" (nth 1 kill-ring))
181 (srecode-dictionary-set-value dict "KILL3" (nth 2 kill-ring))
182 (srecode-dictionary-set-value dict "KILL4" (nth 3 kill-ring))
183 )
184
185(provide 'srecode/args)
186
187;;; srecode/args.el ends here
188
diff --git a/lisp/cedet/srecode/compile.el b/lisp/cedet/srecode/compile.el
new file mode 100644
index 00000000000..f744b052162
--- /dev/null
+++ b/lisp/cedet/srecode/compile.el
@@ -0,0 +1,640 @@
1;;; srecode/compile --- Compilation of srecode template files.
2
3;;; Copyright (C) 2005, 2007, 2008, 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <zappo@gnu.org>
6;; Keywords: codegeneration
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;; Compile a Semantic Recoder template file.
26;;
27;; Template files are parsed using a Semantic/Wisent parser into
28;; a tag table. The code therin is then further parsed down using
29;; a regular expression parser.
30;;
31;; The output are a series of EIEIO objects which represent the
32;; templates in a way that could be inserted later.
33
34(require 'semantic)
35(require 'eieio)
36(require 'eieio-base)
37(require 'srecode)
38(require 'srecode/table)
39
40(declare-function srecode-template-inserter-newline-child-p "srecode/insert")
41(declare-function srecode-create-section-dictionary "srecode/dictionary")
42(declare-function srecode-dictionary-compound-variable "srecode/dictionary")
43
44;;; Code:
45
46;;; Template Class
47;;
48;; Templatets describe a patter of text that can be inserted into a
49;; buffer.
50;;
51(defclass srecode-template (eieio-named)
52 ((context :initarg :context
53 :initform nil
54 :documentation
55 "Context this template belongs to.")
56 (args :initarg :args
57 :documentation
58 "List of arguments that this template requires.")
59 (code :initarg :code
60 :documentation
61 "Compiled text from the template.")
62 (dictionary :initarg :dictionary
63 :type (or null srecode-dictionary)
64 :documentation
65 "List of section dictinaries.
66The compiled template can contain lists of section dictionaries,
67or values that are expected to be passed down into different
68section macros. The template section dictionaries are merged in with
69any incomming dictionaries values.")
70 (binding :initarg :binding
71 :documentation
72 "Preferred keybinding for this template in `srecode-minor-mode-map'.")
73 (active :allocation :class
74 :initform nil
75 :documentation
76 "During template insertion, this is the stack of active templates.
77The top-most template is the 'active' template. Use the accessor methods
78for push, pop, and peek for the active template.")
79 (table :initarg :table
80 :documentation
81 "The table this template lives in.")
82 )
83 "Class defines storage for semantic recoder templates.")
84
85(defun srecode-flush-active-templates ()
86 "Flush the active template storage.
87Useful if something goes wrong in SRecode, and the active tempalte
88stack is broken."
89 (interactive)
90 (if (oref srecode-template active)
91 (when (y-or-n-p (format "%d active templates. Flush? "
92 (length (oref srecode-template active))))
93 (oset-default srecode-template active nil))
94 (message "No active templates to flush."))
95 )
96
97;;; Inserters
98;;
99;; Each inserter object manages a different thing that
100;; might be inserted into a template output stream.
101;;
102;; The 'srecode-insert-method' on each inserter does the actual
103;; work, and the smaller, simple inserter object is saved in
104;; the compiled templates.
105;;
106;; See srecode-insert.el for the specialized classes.
107;;
108(defclass srecode-template-inserter (eieio-named)
109 ((secondname :initarg :secondname
110 :type (or null string)
111 :documentation
112 "If there is a colon in the inserter's name, it represents
113additional static argument data."))
114 "This represents an item to be inserted via a template macro.
115Plain text strings are not handled via this baseclass."
116 :abstract t)
117
118(defmethod srecode-parse-input ((ins srecode-template-inserter)
119 tag input STATE)
120 "For the template inserter INS, parse INPUT.
121Shorten input only by the amount needed.
122Return the remains of INPUT.
123STATE is the current compilation state."
124 input)
125
126(defmethod srecode-match-end ((ins srecode-template-inserter) name)
127 "For the template inserter INS, do I end a section called NAME?"
128 nil)
129
130(defmethod srecode-inserter-apply-state ((ins srecode-template-inserter) STATE)
131 "For the template inserter INS, apply information from STATE."
132 nil)
133
134(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter)
135 escape-start escape-end)
136 "Insert an example using inserter INS.
137Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
138 (princ " ")
139 (princ escape-start)
140 (when (and (slot-exists-p ins 'key) (oref ins key))
141 (princ (format "%c" (oref ins key))))
142 (princ "VARNAME")
143 (princ escape-end)
144 (terpri)
145 )
146
147
148;;; Compile State
149(defclass srecode-compile-state ()
150 ((context :initform "declaration"
151 :documentation "The active context.")
152 (prompts :initform nil
153 :documentation "The active prompts.")
154 (escape_start :initform "{{"
155 :documentation "The starting escape sequence.")
156 (escape_end :initform "}}"
157 :documentation "The ending escape sequence.")
158 )
159 "Current state of the compile.")
160
161(defmethod srecode-compile-add-prompt ((state srecode-compile-state)
162 prompttag)
163 "Add PROMPTTAG to the current list of prompts."
164 (with-slots (prompts) state
165 (let ((match (assoc (semantic-tag-name prompttag) prompts))
166 (newprompts prompts))
167 (when match
168 (let ((tmp prompts))
169 (setq newprompts nil)
170 (while tmp
171 (when (not (string= (car (car tmp))
172 (car prompttag)))
173 (setq newprompts (cons (car tmp)
174 newprompts)))
175 (setq tmp (cdr tmp)))))
176 (setq prompts (cons prompttag newprompts)))
177 ))
178
179;;; TEMPLATE COMPILER
180;;
181(defun srecode-compile-file (fname)
182 "Compile the templates from the file FNAME."
183 (let ((peb (get-file-buffer fname)))
184 (save-excursion
185 ;; Make whatever it is local.
186 (if (not peb)
187 (set-buffer (semantic-find-file-noselect fname))
188 (set-buffer peb))
189 ;; Do the compile.
190 (srecode-compile-templates)
191 ;; Trash the buffer if we had to read it in.
192 (if (not peb)
193 (kill-buffer (current-buffer)))
194 )))
195
196;;;###autoload
197(defun srecode-compile-templates ()
198 "Compile a semantic recode template file into a mode-local variable."
199 (interactive)
200 (require 'srecode-insert)
201 (message "Compiling template %s..."
202 (file-name-nondirectory (buffer-file-name)))
203 (let ((tags (semantic-fetch-tags))
204 (tag nil)
205 (class nil)
206 (table nil)
207 (STATE (srecode-compile-state (file-name-nondirectory
208 (buffer-file-name))))
209 (mode nil)
210 (application nil)
211 (priority nil)
212 (vars nil)
213 )
214
215 ;;
216 ;; COMPILE
217 ;;
218 (while tags
219 (setq tag (car tags)
220 class (semantic-tag-class tag))
221 ;; What type of item is it?
222 (cond
223 ;; CONTEXT tags specify the context all future tags
224 ;; belong to.
225 ((eq class 'context)
226 (oset STATE context (semantic-tag-name tag))
227 )
228
229 ;; PROMPT tags specify prompts for dictionary ? inserters
230 ;; which appear in the following templates
231 ((eq class 'prompt)
232 (srecode-compile-add-prompt STATE tag)
233 )
234
235 ;; VARIABLE tags can specify operational control
236 ((eq class 'variable)
237 (let* ((name (semantic-tag-name tag))
238 (value (semantic-tag-variable-default tag))
239 (firstvalue (car value)))
240 ;; If it is a single string, and one value, then
241 ;; look to see if it is one of our special variables.
242 (if (and (= (length value) 1) (stringp firstvalue))
243 (cond ((string= name "mode")
244 (setq mode (intern firstvalue)))
245 ((string= name "escape_start")
246 (oset STATE escape_start firstvalue)
247 )
248 ((string= name "escape_end")
249 (oset STATE escape_end firstvalue)
250 )
251 ((string= name "application")
252 (setq application (read firstvalue)))
253 ((string= name "priority")
254 (setq priority (read firstvalue)))
255 (t
256 ;; Assign this into some table of variables.
257 (setq vars (cons (cons name firstvalue) vars))
258 ))
259 ;; If it isn't a single string, then the value of the
260 ;; variable belongs to a compound dictionary value.
261 ;;
262 ;; Create a compound dictionary value from "value".
263 (require 'srecode/dictionary)
264 (let ((cv (srecode-dictionary-compound-variable
265 name :value value)))
266 (setq vars (cons (cons name cv) vars)))
267 ))
268 )
269
270 ;; FUNCTION tags are really templates.
271 ((eq class 'function)
272 (setq table (cons (srecode-compile-one-template-tag tag STATE)
273 table))
274 )
275
276 ;; Ooops
277 (t (error "Unknown TAG class %s" class))
278 )
279 ;; Continue
280 (setq tags (cdr tags)))
281
282 ;; MSG - Before install since nreverse whacks our list.
283 (message "%d templates compiled for %s"
284 (length table) mode)
285
286 ;;
287 ;; APPLY TO MODE
288 ;;
289 (if (not mode)
290 (error "You must specify a MODE for your templates"))
291
292 ;;
293 ;; Calculate priority
294 ;;
295 (if (not priority)
296 (let ((d (file-name-directory (buffer-file-name)))
297 (sd (file-name-directory (locate-library "srecode")))
298 (defaultdelta (if (eq mode 'default) 20 0)))
299 (if (string= d sd)
300 (setq priority (+ 80 defaultdelta))
301 (setq priority (+ 30 defaultdelta)))
302 (message "Templates %s has estimated priority of %d"
303 (file-name-nondirectory (buffer-file-name))
304 priority))
305 (message "Compiling templates %s priority %d... done!"
306 (file-name-nondirectory (buffer-file-name))
307 priority))
308
309 ;; Save it up!
310 (srecode-compile-template-table table mode priority application vars)
311 )
312)
313
314(defun srecode-compile-one-template-tag (tag STATE)
315 "Compile a template tag TAG into an srecode template class.
316STATE is the current compile state as an object `srecode-compile-state'."
317 (require 'srecode/dictionary)
318 (let* ((context (oref STATE context))
319 (codeout (srecode-compile-split-code
320 tag (semantic-tag-get-attribute tag :code)
321 STATE))
322 (code (cdr codeout))
323 (args (semantic-tag-function-arguments tag))
324 (binding (semantic-tag-get-attribute tag :binding))
325 (rawdicts (semantic-tag-get-attribute tag :dictionaries))
326 (sdicts (srecode-create-section-dictionary rawdicts STATE))
327 (addargs nil)
328 )
329; (message "Compiled %s to %d codes with %d args and %d prompts."
330; (semantic-tag-name tag)
331; (length code)
332; (length args)
333; (length prompts))
334 (while args
335 (setq addargs (cons (intern (car args)) addargs))
336 (when (eq (car addargs) :blank)
337 ;; If we have a wrap, then put wrap inserters on both
338 ;; ends of the code.
339 (setq code (append
340 (list (srecode-compile-inserter "BLANK"
341 "\r"
342 STATE
343 :secondname nil
344 :where 'begin))
345 code
346 (list (srecode-compile-inserter "BLANK"
347 "\r"
348 STATE
349 :secondname nil
350 :where 'end))
351 )))
352 (setq args (cdr args)))
353 (srecode-template (semantic-tag-name tag)
354 :context context
355 :args (nreverse addargs)
356 :dictionary sdicts
357 :binding binding
358 :code code)
359 ))
360
361(defun srecode-compile-do-hard-newline-p (comp)
362 "Examine COMP to decide if the upcoming newline should be hard.
363It is hard if the previous inserter is a newline object."
364 (while (and comp (stringp (car comp)))
365 (setq comp (cdr comp)))
366 (or (not comp)
367 (require 'srecode/insert)
368 (srecode-template-inserter-newline-child-p (car comp))))
369
370(defun srecode-compile-split-code (tag str STATE
371 &optional end-name)
372 "Split the code for TAG into something templatable.
373STR is the string of code from TAG to split.
374STATE is the current compile state.
375ESCAPE_START and ESCAPE_END are regexps that indicate the beginning
376escape character, and end escape character pattern for expandable
377macro names.
378Optional argument END-NAME specifies the name of a token upon which
379parsing should stop.
380If END-NAME is specified, and the input string"
381 (let* ((what str)
382 (end-token nil)
383 (comp nil)
384 (regex (concat "\n\\|" (regexp-quote (oref STATE escape_start))))
385 (regexend (regexp-quote (oref STATE escape_end)))
386 )
387 (while (and what (not end-token))
388 (cond
389 ((string-match regex what)
390 (let* ((prefix (substring what 0 (match-beginning 0)))
391 (match (substring what
392 (match-beginning 0)
393 (match-end 0)))
394 (namestart (match-end 0))
395 (junk (string-match regexend what namestart))
396 end tail name)
397 ;; Add string to compiled output
398 (when (> (length prefix) 0)
399 (setq comp (cons prefix comp)))
400 (if (string= match "\n")
401 ;; Do newline thingy.
402 (let ((new-inserter
403 (srecode-compile-inserter
404 "INDENT"
405 "\n"
406 STATE
407 :secondname nil
408 ;; This newline is "hard" meaning ALWAYS do it
409 ;; if the previous entry is also a newline.
410 ;; Without it, user entered blank lines will be
411 ;; ignored.
412 :hard (srecode-compile-do-hard-newline-p comp)
413 )))
414 ;; Trim WHAT back.
415 (setq what (substring what namestart))
416 (when (> (length what) 0)
417 ;; make the new inserter, but only if we aren't last.
418 (setq comp (cons new-inserter comp))
419 ))
420 ;; Regular inserter thingy.
421 (setq end (if junk
422 (match-beginning 0)
423 (error "Could not find end escape for %s"
424 (semantic-tag-name tag)))
425 tail (match-end 0))
426 (cond ((not end)
427 (error "No matching escape end for %s"
428 (semantic-tag-name tag)))
429 ((<= end namestart)
430 (error "Stray end escape for %s"
431 (semantic-tag-name tag)))
432 )
433 ;; Add string to compiled output
434 (setq name (substring what namestart end)
435 key nil)
436 ;; Trim WHAT back.
437 (setq what (substring what tail))
438 ;; Get the inserter
439 (let ((new-inserter
440 (srecode-compile-parse-inserter name STATE))
441 )
442 ;; If this is an end inserter, then assign into
443 ;; the end-token.
444 (if (srecode-match-end new-inserter end-name)
445 (setq end-token new-inserter))
446 ;; Add the inserter to our compilation stream.
447 (setq comp (cons new-inserter comp))
448 ;; Allow the inserter an opportunity to modify
449 ;; the input stream.
450 (setq what (srecode-parse-input new-inserter tag what
451 STATE))
452 )
453 )))
454 (t
455 (if end-name
456 (error "Unmatched section end %s" end-name))
457 (setq comp (cons what comp)
458 what nil))))
459 (cons what (nreverse comp))))
460
461(defun srecode-compile-parse-inserter (txt STATE)
462 "Parse the inserter TXT with the current STATE.
463Return an inserter object."
464 (let ((key (aref txt 0))
465 )
466 (if (and (or (< key ?A) (> key ?Z))
467 (or (< key ?a) (> key ?z)) )
468 (setq name (substring txt 1))
469 (setq name txt
470 key nil))
471 (let* ((junk (string-match ":" name))
472 (namepart (if junk
473 (substring name 0 (match-beginning 0))
474 name))
475 (secondname (if junk
476 (substring name (match-end 0))
477 nil))
478 (new-inserter (srecode-compile-inserter
479 namepart key STATE
480 :secondname secondname
481 )))
482 ;; Return the new inserter
483 new-inserter)))
484
485(defun srecode-compile-inserter (name key STATE &rest props)
486 "Create an srecode inserter object for some macro NAME.
487KEY indicates a single character key representing a type
488of inserter to create.
489STATE is the current compile state.
490PROPS are additional properties that might need to be passed
491to the inserter constructor."
492 ;;(message "Compile: %s %S" name props)
493 (if (not key)
494 (apply 'srecode-template-inserter-variable name props)
495 (let ((classes (class-children srecode-template-inserter))
496 (new nil))
497 ;; Loop over the various subclasses and
498 ;; create the correct inserter.
499 (while (and (not new) classes)
500 (setq classes (append classes (class-children (car classes))))
501 ;; Do we have a match?
502 (when (and (not (class-abstract-p (car classes)))
503 (equal (oref (car classes) key) key))
504 ;; Create the new class, and apply state.
505 (setq new (apply (car classes) name props))
506 (srecode-inserter-apply-state new STATE)
507 )
508 (setq classes (cdr classes)))
509 (if (not new) (error "SRECODE: Unknown macro code %S" key))
510 new)))
511
512(defun srecode-compile-template-table (templates mode priority application vars)
513 "Compile a list of TEMPLATES into an semantic recode table.
514The table being compiled is for MODE, or the string \"default\".
515PRIORITY is a numerical value that indicates this tables location
516in an ordered search.
517APPLICATION is the name of the application these templates belong to.
518A list of defined variables VARS provides a variable table."
519 (let ((namehash (make-hash-table :test 'equal
520 :size (length templates)))
521 (contexthash (make-hash-table :test 'equal :size 10))
522 (lp templates)
523 )
524
525 (while lp
526
527 (let* ((objname (oref (car lp) :object-name))
528 (context (oref (car lp) :context))
529 (globalname (concat context ":" objname))
530 )
531
532 ;; Place this template object into the global name hash.
533 (puthash globalname (car lp) namehash)
534
535 ;; Place this template into the specific context name hash.
536 (let ((hs (gethash context contexthash)))
537 ;; Make a new context if none was available.
538 (when (not hs)
539 (setq hs (make-hash-table :test 'equal :size 20))
540 (puthash context hs contexthash))
541 ;; Put into that contenxt's hash.
542 (puthash objname (car lp) hs)
543 )
544
545 (setq lp (cdr lp))))
546
547 (let* ((table (srecode-mode-table-new mode (buffer-file-name)
548 :templates (nreverse templates)
549 :namehash namehash
550 :contexthash contexthash
551 :variables vars
552 :major-mode mode
553 :priority priority
554 :application application))
555 (tmpl (oref table templates)))
556 ;; Loop over all the templates, and xref.
557 (while tmpl
558 (oset (car tmpl) :table table)
559 (setq tmpl (cdr tmpl))))
560 ))
561
562
563
564;;; DEBUG
565;;
566;; Dump out information about the current srecoder compiled templates.
567;;
568
569(defmethod srecode-dump ((tmp srecode-template))
570 "Dump the contents of the SRecode template tmp."
571 (princ "== Template \"")
572 (princ (object-name-string tmp))
573 (princ "\" in context ")
574 (princ (oref tmp context))
575 (princ "\n")
576 (when (oref tmp args)
577 (princ " Arguments: ")
578 (prin1 (oref tmp args))
579 (princ "\n"))
580 (when (oref tmp dictionary)
581 (princ " Section Dictionaries:\n")
582 (srecode-dump (oref tmp dictionary) 4)
583 ;(princ "\n")
584 )
585 (when (and (slot-boundp tmp 'binding) (oref tmp binding))
586 (princ " Binding: ")
587 (prin1 (oref tmp binding))
588 (princ "\n"))
589 (princ " Compiled Codes:\n")
590 (srecode-dump-code-list (oref tmp code) " ")
591 (princ "\n\n")
592 )
593
594(defun srecode-dump-code-list (code indent)
595 "Dump the CODE from a template code list to standard output.
596Argument INDENT specifies the indentation level for the list."
597 (let ((i 1))
598 (while code
599 (princ indent)
600 (prin1 i)
601 (princ ") ")
602 (cond ((stringp (car code))
603 (prin1 (car code)))
604 ((srecode-template-inserter-child-p (car code))
605 (srecode-dump (car code) indent))
606 (t
607 (princ "Unknown Code: ")
608 (prin1 (car code))))
609 (setq code (cdr code)
610 i (1+ i))
611 (when code
612 (princ "\n"))))
613 )
614
615(defmethod srecode-dump ((ins srecode-template-inserter) indent)
616 "Dump the state of the SRecode template inserter INS."
617 (princ "INS: \"")
618 (princ (object-name-string ins))
619 (when (oref ins :secondname)
620 (princ "\" : \"")
621 (princ (oref ins :secondname)))
622 (princ "\" type \"")
623 (let* ((oc (symbol-name (object-class ins)))
624 (junk (string-match "srecode-template-inserter-" oc))
625 (on (if junk
626 (substring oc (match-end 0))
627 oc)))
628 (princ on))
629 (princ "\"")
630 )
631
632(provide 'srecode/compile)
633
634;; Local variables:
635;; generated-autoload-file: "loaddefs.el"
636;; generated-autoload-feature: srecode/loaddefs
637;; generated-autoload-load-name: "srecode/compile"
638;; End:
639
640;;; srecode/compile.el ends here
diff --git a/lisp/cedet/srecode/cpp.el b/lisp/cedet/srecode/cpp.el
new file mode 100644
index 00000000000..28613a004ed
--- /dev/null
+++ b/lisp/cedet/srecode/cpp.el
@@ -0,0 +1,149 @@
1;;; srecode/cpp.el --- C++ specific handlers for Semantic Recoder
2
3;; Copyright (C) 2007, 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <eric@siege-engine.com>
6;; Jan Moringen <scymtym@users.sourceforge.net>
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;; Supply some C++ specific dictionary fillers and helpers
26
27;;; Code:
28
29;;; :cpp ARGUMENT HANDLING
30;;
31;; When a :cpp argument is required, fill the dictionary with
32;; information about the current C++ file.
33;;
34;; Error if not in a C++ mode.
35
36(require 'srecode)
37(require 'srecode/dictionary)
38(require 'srecode/semantic)
39
40;;;###autoload
41(defun srecode-semantic-handle-:cpp (dict)
42 "Add macros into the dictionary DICT based on the current c++ file.
43Adds the following:
44FILENAME_SYMBOL - filename converted into a C compat symbol.
45HEADER - Shown section if in a header file."
46 ;; A symbol representing
47 (let ((fsym (file-name-nondirectory (buffer-file-name)))
48 (case-fold-search t))
49
50 ;; Are we in a header file?
51 (if (string-match "\\.\\(h\\|hh\\|hpp\\|h\\+\\+\\)$" fsym)
52 (srecode-dictionary-show-section dict "HEADER")
53 (srecode-dictionary-show-section dict "NOTHEADER"))
54
55 ;; Strip out bad characters
56 (while (string-match "\\.\\| " fsym)
57 (setq fsym (replace-match "_" t t fsym)))
58 (srecode-dictionary-set-value dict "FILENAME_SYMBOL" fsym)
59 )
60 )
61
62(define-mode-local-override srecode-semantic-apply-tag-to-dict
63 c++-mode (tag-wrapper dict)
64 "Apply C++ specific features from TAG-WRAPPER into DICT.
65Calls `srecode-semantic-apply-tag-to-dict-default' first. Adds
66special behavior for tag of classes include, using and function."
67
68 ;; Use default implementation to fill in the basic properties.
69 (srecode-semantic-apply-tag-to-dict-default tag-wrapper dict)
70
71 ;; Pull out the tag for the individual pieces.
72 (let* ((tag (oref tag-wrapper :prime))
73 (class (semantic-tag-class tag)))
74
75 ;; Add additional information based on the class of the tag.
76 (cond
77 ;;
78 ;; INCLUDE
79 ;;
80 ((eq class 'include)
81 ;; For include tags, we have to discriminate between system-wide
82 ;; and local includes.
83 (if (semantic-tag-include-system-p tag)
84 (srecode-dictionary-show-section dict "SYSTEM")
85 (srecode-dictionary-show-section dict "LOCAL")))
86
87 ;;
88 ;; USING
89 ;;
90 ((eq class 'using)
91 ;; Insert the subject (a tag) of the include statement as VALUE
92 ;; entry into the dictionary.
93 (let ((value-tag (semantic-tag-get-attribute tag :value))
94 (value-dict (srecode-dictionary-add-section-dictionary
95 dict "VALUE")))
96 (srecode-semantic-apply-tag-to-dict
97 (srecode-semantic-tag (semantic-tag-name value-tag)
98 :prime value-tag)
99 value-dict))
100 ;; Discriminate using statements referring to namespaces and
101 ;; types.
102 (when (eq (semantic-tag-get-attribute tag :kind) 'namespace)
103 (srecode-dictionary-show-section dict "NAMESPACE")))
104
105 ;;
106 ;; FUNCTION
107 ;;
108 ((eq class 'function)
109 ;; @todo It would be nice to distinguish member functions from
110 ;; free functions and only apply the const and pure modifiers,
111 ;; when they make sense. My best bet would be
112 ;; (semantic-tag-function-parent tag), but it is not there, when
113 ;; the function is defined in the scope of a class.
114 (let ((member 't)
115 (modifiers (semantic-tag-modifiers tag)))
116
117 ;; Add modifiers into the dictionary
118 (dolist (modifier modifiers)
119 (let ((modifier-dict (srecode-dictionary-add-section-dictionary
120 dict "MODIFIERS")))
121 (srecode-dictionary-set-value modifier-dict "NAME" modifier)))
122
123 ;; When the function is a member function, it can have
124 ;; additional modifiers.
125 (when member
126
127 ;; For member functions, constness is called
128 ;; 'methodconst-flag'.
129 (when (semantic-tag-get-attribute tag :methodconst-flag)
130 (srecode-dictionary-show-section dict "CONST"))
131
132 ;; If the member function is pure virtual, add a dictionary
133 ;; entry.
134 (when (semantic-tag-get-attribute tag :pure-virtual-flag)
135 (srecode-dictionary-show-section dict "PURE"))
136 )
137 ))
138 ))
139 )
140
141(provide 'srecode/cpp)
142
143;; Local variables:
144;; generated-autoload-file: "loaddefs.el"
145;; generated-autoload-feature: srecode/loaddefs
146;; generated-autoload-load-name: "srecode/cpp"
147;; End:
148
149;;; srecode/cpp.el ends here
diff --git a/lisp/cedet/srecode/ctxt.el b/lisp/cedet/srecode/ctxt.el
new file mode 100644
index 00000000000..8dc302057ff
--- /dev/null
+++ b/lisp/cedet/srecode/ctxt.el
@@ -0,0 +1,247 @@
1;;; srecode/ctxt.el --- Derive a context from the source buffer.
2
3;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <eric@siege-engine.com>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;
24;; Manage context calculations for Semantic Recoder.
25;;
26;; SRecode templates are always bound to a context. By calculating
27;; the current context, we can narrow down the selection of possible
28;; templates to something reasonable.
29;;
30;; Alternately, code here will find a context for templates that
31;; require different pieces of code placed in multiple areas.
32
33(require 'semantic)
34(require 'semantic/tag-ls)
35
36(declare-function srecode-dictionary-show-section "srecode/dictionary")
37(declare-function srecode-dictionary-set-value "srecode/dictionary")
38
39;;; Code:
40
41(define-overload srecode-calculate-context ()
42 "Calculate the context at the current point.
43The returned context is a list, with the top-most context first.
44Each returned context is a string that that would show up in a `context'
45statement in an `.srt' file.
46
47Some useful context values used by the provided srecode templates are:
48 \"file\" - Templates that for a file (such as an empty file.)
49 \"empty\" - The file is empty
50 \"declaration\" - Top-level declarations in a file.
51 \"include\" - In or near include statements
52 \"package\" - In or near provide statements
53 \"function\" - In or near function statements
54 \"NAME\" - Near functions within NAME namespace or class
55 \"variable\" - In or near variable statements.
56 \"type\" - In or near type declarations.
57 \"comment\" - In a comment
58 \"classdecl\" - Declarations within a class/struct/etc.
59 \"variable\" - In or near class fields
60 \"function\" - In or near methods/functions
61 \"virtual\" - Nearby items are virtual
62 \"pure\" - and those virtual items are pure virtual
63 \"type\" - In or near type declarations.
64 \"comment\" - In a comment in a block of code
65 -- these items show up at the end of the context list. --
66 \"public\", \"protected\", \"private\" -
67 In or near a section of public/pritected/private entries.
68 \"code\" - In a block of code.
69 \"string\" - In a string in a block of code
70 \"comment\" - In a comment in a block of code
71
72 ... More later."
73 )
74
75(defun srecode-calculate-nearby-things ()
76 ;; NOTE: May need to add bounes to this FCN
77 "Calculate the CONTEXT type items nearby the current point.
78Assume that what we want to insert next is based on what is just
79before point. If there is nothing, then assume it is whatever is
80after point."
81 ;; @todo - ADD BOUNDS TO THE PREV/NEXT TAG SEARCH
82 ;; thus classdecl "near" stuff cannot be
83 ;; outside the bounds of the type in question.
84 (let ((near (semantic-find-tag-by-overlay-prev))
85 (prot nil)
86 (ans nil))
87 (if (not near)
88 (setq near (semantic-find-tag-by-overlay-next)))
89 (when near
90 ;; Calculate the type of thing we are near.
91 (if (not (semantic-tag-of-class-p near 'function))
92 (setq ans (cons (symbol-name (semantic-tag-class near)) ans))
93 ;; if the symbol NEAR has a parent,
94 (let ((p (semantic-tag-function-parent near)))
95 (setq ans (cons (symbol-name (semantic-tag-class near)) ans))
96 (cond ((semantic-tag-p p)
97 (setq ans (cons (semantic-tag-name p) ans)))
98 ((stringp p)
99 (setq ans (cons p ans)))
100 (t nil)))
101 ;; Was it virtual?
102 (when (semantic-tag-get-attribute near :virtual)
103 (setq ans (cons "virtual" ans)))
104 ;; Was it pure?
105 (when (semantic-tag-get-attribute near :pure-virtual-flag)
106 (setq ans (cons "pure" ans)))
107 )
108 ;; Calculate the protection
109 (setq prot (semantic-tag-protection near))
110 (when (and prot (not (eq prot 'unknown)))
111 (setq ans (cons (symbol-name prot) ans)))
112 )
113 (nreverse ans)))
114
115(defun srecode-calculate-context-font-lock ()
116 "Calculate an srecode context by using font-lock."
117 (let ((face (get-text-property (point) 'face))
118 )
119 (cond ((member face '(font-lock-string-face
120 font-lock-doc-face))
121 (list "string"))
122 ((member face '(font-lock-comment-face
123 font-lock-comment-delimiter-face))
124 (list "comment"))
125 )
126 ))
127
128(defun srecode-calculate-context-default ()
129 "Generic method for calculating a context for srecode."
130 (if (= (point-min) (point-max))
131 (list "file" "empty")
132
133 (semantic-fetch-tags)
134 (let ((ct (semantic-find-tag-by-overlay))
135 )
136 (cond ((or (not ct)
137 ;; Ok, below is a bit C specific.
138 (and (eq (semantic-tag-class (car ct)) 'type)
139 (string= (semantic-tag-type (car ct)) "namespace")))
140 (cons "declaration"
141 (or (srecode-calculate-context-font-lock)
142 (srecode-calculate-nearby-things)
143 ))
144 )
145 ((eq (semantic-tag-class (car ct)) 'function)
146 (cons "code" (srecode-calculate-context-font-lock))
147 )
148 ((eq (semantic-tag-class (car ct)) 'type) ; We know not namespace
149 (cons "classdecl"
150 (or (srecode-calculate-context-font-lock)
151 (srecode-calculate-nearby-things)))
152 )
153 ((and (car (cdr ct))
154 (eq (semantic-tag-class (car (cdr ct))) 'type))
155 (list "classdecl"
156 (symbol-name (semantic-tag-class (car ct))))
157 )
158 )
159 )))
160
161
162;;; HANDLERS
163;;
164;; The calculated context is one thing, but more info is often available.
165;; The context handlers can add info into the active dictionary that is
166;; based on the context, such as a method parent name, protection scheme,
167;; or other feature.
168
169(defun srecode-semantic-handle-:ctxt (dict &optional template)
170 "Add macros into the dictionary DICT based on the current Emacs Lisp file.
171Argument TEMPLATE is the template object adding context dictionary
172entries.
173This might add the following:
174 VIRTUAL - show a section if a function is virtual
175 PURE - show a section if a function is pure virtual.
176 PARENT - The name of a parent type for functions.
177 PROTECTION - Show a protection section, and what the protection is."
178 (require 'srecode/dictionary)
179 (when template
180
181 (let ((name (oref template object-name))
182 (cc (if (boundp 'srecode-insertion-start-context)
183 srecode-insertion-start-context))
184 ;(context (oref template context))
185 )
186
187; (when (and cc
188; (null (string= (car cc) context))
189; )
190; ;; No current context, or the base is different, then
191; ;; this is the section where we need to recalculate
192; ;; the context based on user choice, if possible.
193; ;;
194; ;; The recalculation is complex, as there are many possibilities
195; ;; that need to be divined. Set "cc" to the new context
196; ;; at the end.
197; ;;
198; ;; @todo -
199;
200; )
201
202 ;; The various context all have different features.
203 (let ((ct (nth 0 cc))
204 (it (nth 1 cc))
205 (last (last cc))
206 (parent nil)
207 )
208 (cond ((string= it "function")
209 (setq parent (nth 2 cc))
210 (when parent
211 (cond ((string= parent "virtual")
212 (srecode-dictionary-show-section dict "VIRTUAL")
213 (when (nth 3 cc)
214 (srecode-dictionary-show-section dict "PURE"))
215 )
216 (t
217 (srecode-dictionary-set-value dict "PARENT" parent))))
218 )
219 ((and (string= it "type")
220 (or (string= name "function") (string= name "method")))
221 ;; If we have a type, but we insert a fcn, then use that type
222 ;; as the function parent.
223 (let ((near (semantic-find-tag-by-overlay-prev)))
224 (when (and near (semantic-tag-of-class-p near 'type))
225 (srecode-dictionary-set-value
226 dict "PARENT" (semantic-tag-name near))))
227 )
228 ((string= ct "code")
229 ;;(let ((analyzer (semantic-analyze-current-context)))
230 ;; @todo - Use the analyze to setup things like local
231 ;; variables we might use or something.
232 nil
233 ;;)
234 )
235 (t
236 nil))
237 (when (member last '("public" "private" "protected"))
238 ;; Hey, fancy that, we can do both.
239 (srecode-dictionary-set-value dict "PROTECTION" parent)
240 (srecode-dictionary-show-section dict "PROTECTION"))
241 ))
242 ))
243
244
245(provide 'srecode/ctxt)
246
247;;; srecode/ctxt.el ends here
diff --git a/lisp/cedet/srecode/dictionary.el b/lisp/cedet/srecode/dictionary.el
new file mode 100644
index 00000000000..c637f1f2a5f
--- /dev/null
+++ b/lisp/cedet/srecode/dictionary.el
@@ -0,0 +1,565 @@
1;;; srecode-dictionary.el --- Dictionary code for the semantic recoder.
2
3;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <eric@siege-engine.com>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;
24;; Dictionaries contain lists of names and their assocaited values.
25;; These dictionaries are used to fill in macros from recoder templates.
26
27;;; Code:
28
29;;; CLASSES
30
31(require 'eieio)
32(require 'srecode)
33(require 'srecode/table)
34(eval-when-compile (require 'semantic))
35
36(declare-function srecode-compile-parse-inserter "srecode/compile")
37(declare-function srecode-dump-code-list "srecode/compile")
38(declare-function srecode-load-tables-for-mode "srecode/find")
39(declare-function srecode-insert-code-stream "srecode/insert")
40(declare-function data-debug-new-buffer "data-debug")
41(declare-function data-debug-insert-object-slots "eieio-datadebug")
42(declare-function srecode-field "srecode/fields")
43
44(defclass srecode-dictionary ()
45 ((namehash :initarg :namehash
46 :documentation
47 "Hash table containing the names of all the templates.")
48 (buffer :initarg :buffer
49 :documentation
50 "The buffer this dictionary was initialized with.")
51 (parent :initarg :parent
52 :type (or null srecode-dictionary)
53 :documentation
54 "The parent dictionary.
55Symbols not appearing in this dictionary will be checked against the
56parent dictionary.")
57 (origin :initarg :origin
58 :type string
59 :documentation
60 "A string representing the origin of this dictionary.
61Useful only while debugging.")
62 )
63 "Dictionary of symbols and what they mean.
64Dictionaries are used to look up named symbols from
65templates to decide what to do with those symbols.")
66
67(defclass srecode-dictionary-compound-value ()
68 ()
69 "A compound dictionary value.
70Values stored in a dictionary must be a STRING,
71a dictionary for showing sections, or an instance of a subclass
72of this class.
73
74Compound dictionary values derive from this class, and must
75provide a sequence of method implementations to convert into
76a string."
77 :abstract t)
78
79(defclass srecode-dictionary-compound-variable
80 (srecode-dictionary-compound-value)
81 ((value :initarg :value
82 :documentation
83 "The value of this template variable.
84Variables in template files are usually a single string
85which can be inserted into a dictionary directly.
86
87Some variables may be more complex and involve dictionary
88lookups, strings, concatenation, or the like.
89
90The format of VALUE is determined by current template
91formatting rules.")
92 (compiled :initarg :compiled
93 :type list
94 :documentation
95 "The compiled version of VALUE.")
96 )
97 "A compound dictionary value for template file variables.
98You can declare a variable in a template like this:
99
100set NAME \"str\" macro \"OTHERNAME\"
101
102with appending various parts together in a list.")
103
104(defmethod initialize-instance ((this srecode-dictionary-compound-variable)
105 &optional fields)
106 "Initialize the compound variable THIS.
107Makes sure that :value is compiled."
108 (let ((newfields nil)
109 (state nil))
110 (while fields
111 ;; Strip out :state
112 (if (eq (car fields) :state)
113 (setq state (car (cdr fields)))
114 (setq newfields (cons (car (cdr fields))
115 (cons (car fields) newfields))))
116 (setq fields (cdr (cdr fields))))
117
118 (when (not state)
119 (error "Cannot create compound variable without :state"))
120
121 (call-next-method this (nreverse newfields))
122 (when (not (slot-boundp this 'compiled))
123 (let ((val (oref this :value))
124 (comp nil))
125 (while val
126 (let ((nval (car val))
127 )
128 (cond ((stringp nval)
129 (setq comp (cons nval comp)))
130 ((and (listp nval)
131 (equal (car nval) 'macro))
132 (require 'srecode/compile)
133 (setq comp (cons
134 (srecode-compile-parse-inserter
135 (cdr nval)
136 state)
137 comp)))
138 (t
139 (error "Don't know how to handle variable value %S" nval)))
140 )
141 (setq val (cdr val)))
142 (oset this :compiled (nreverse comp))))))
143
144;;; DICTIONARY METHODS
145;;
146
147(defun srecode-create-dictionary (&optional buffer-or-parent)
148 "Create a dictionary for BUFFER.
149If BUFFER-OR-PARENT is not specified, assume a buffer, and
150use the current buffer.
151If BUFFER-OR-PARENT is another dictionary, then remember the
152parent within the new dictionary, and assume that BUFFER
153is the same as belongs to the parent dictionary.
154The dictionary is initialized with variables setup for that
155buffer's table.
156If BUFFER-OR-PARENT is t, then this dictionary should not be
157assocated with a buffer or parent."
158 (save-excursion
159 (let ((parent nil)
160 (buffer nil)
161 (origin nil)
162 (initfrombuff nil))
163 (cond ((bufferp buffer-or-parent)
164 (set-buffer buffer-or-parent)
165 (setq buffer buffer-or-parent
166 origin (buffer-name buffer-or-parent)
167 initfrombuff t))
168 ((srecode-dictionary-child-p buffer-or-parent)
169 (setq parent buffer-or-parent
170 buffer (oref buffer-or-parent buffer)
171 origin (concat (object-name buffer-or-parent) " in "
172 (if buffer (buffer-name buffer)
173 "no buffer")))
174 (when buffer
175 (set-buffer buffer)))
176 ((eq buffer-or-parent t)
177 (setq buffer nil
178 origin "Unspecified Origin"))
179 (t
180 (setq buffer (current-buffer)
181 origin (concat "Unspecified. Assume "
182 (buffer-name buffer))
183 initfrombuff t)
184 )
185 )
186 (let ((dict (srecode-dictionary
187 major-mode
188 :buffer buffer
189 :parent parent
190 :namehash (make-hash-table :test 'equal
191 :size 20)
192 :origin origin)))
193 ;; Only set up the default variables if we are being built
194 ;; directroy for a particular buffer.
195 (when initfrombuff
196 ;; Variables from the table we are inserting from.
197 ;; @todo - get a better tree of tables.
198 (let ((mt (srecode-get-mode-table major-mode))
199 (def (srecode-get-mode-table 'default)))
200 ;; Each table has multiple template tables.
201 ;; Do DEF first so that MT can override any values.
202 (srecode-dictionary-add-template-table dict def)
203 (srecode-dictionary-add-template-table dict mt)
204 ))
205 dict))))
206
207(defmethod srecode-dictionary-add-template-table ((dict srecode-dictionary)
208 tpl)
209 "Insert into DICT the variables found in table TPL.
210TPL is an object representing a compiled template file."
211 (when tpl
212 (let ((tabs (oref tpl :tables)))
213 (while tabs
214 (let ((vars (oref (car tabs) variables)))
215 (while vars
216 (srecode-dictionary-set-value
217 dict (car (car vars)) (cdr (car vars)))
218 (setq vars (cdr vars))))
219 (setq tabs (cdr tabs))))))
220
221
222(defmethod srecode-dictionary-set-value ((dict srecode-dictionary)
223 name value)
224 "In dictionary DICT, set NAME to have VALUE."
225 ;; Validate inputs
226 (if (not (stringp name))
227 (signal 'wrong-type-argument (list name 'stringp)))
228 ;; Add the value.
229 (with-slots (namehash) dict
230 (puthash name value namehash))
231 )
232
233(defmethod srecode-dictionary-add-section-dictionary ((dict srecode-dictionary)
234 name &optional show-only)
235 "In dictionary DICT, add a section dictionary for section macro NAME.
236Return the new dictionary.
237
238You can add several dictionaries to the same section macro.
239For each dictionary added to a macro, the block of codes in the
240template will be repeated.
241
242If optional argument SHOW-ONLY is non-nil, then don't add a new dictionarly
243if there is already one in place. Also, don't add FIRST/LAST entries.
244These entries are not needed when we are just showing a section.
245
246Each dictionary added will automatically get values for positional macros
247which will enable SECTIONS to be enabled.
248
249 * FIRST - The first entry in the table.
250 * NOTFIRST - Not the first entry in the table.
251 * LAST - The last entry in the table
252 * NOTLAST - Not the last entry in the table.
253
254Adding a new dictionary will alter these values in previously
255inserted dictionaries."
256 ;; Validate inputs
257 (if (not (stringp name))
258 (signal 'wrong-type-argument (list name 'stringp)))
259 (let ((new (srecode-create-dictionary dict))
260 (ov (srecode-dictionary-lookup-name dict name)))
261
262 (when (not show-only)
263 ;; Setup the FIRST/NOTFIRST and LAST/NOTLAST entries.
264 (if (null ov)
265 (progn
266 (srecode-dictionary-show-section new "FIRST")
267 (srecode-dictionary-show-section new "LAST"))
268 ;; Not the very first one. Lets clean up CAR.
269 (let ((tail (car (last ov))))
270 (srecode-dictionary-hide-section tail "LAST")
271 (srecode-dictionary-show-section tail "NOTLAST")
272 )
273 (srecode-dictionary-show-section new "NOTFIRST")
274 (srecode-dictionary-show-section new "LAST"))
275 )
276
277 (when (or (not show-only) (null ov))
278 (srecode-dictionary-set-value dict name (append ov (list new))))
279 ;; Return the new sub-dictionary.
280 new))
281
282(defmethod srecode-dictionary-show-section ((dict srecode-dictionary) name)
283 "In dictionary DICT, indicate that the section NAME should be exposed."
284 ;; Validate inputs
285 (if (not (stringp name))
286 (signal 'wrong-type-argument (list name 'stringp)))
287 ;; Showing a section is just like making a section dictionary, but
288 ;; with no dictionary values to add.
289 (srecode-dictionary-add-section-dictionary dict name t)
290 nil)
291
292(defmethod srecode-dictionary-hide-section ((dict srecode-dictionary) name)
293 "In dictionary DICT, indicate that the section NAME should be hidden."
294 ;; We need to find the has value, and then delete it.
295 ;; Validate inputs
296 (if (not (stringp name))
297 (signal 'wrong-type-argument (list name 'stringp)))
298 ;; Add the value.
299 (with-slots (namehash) dict
300 (remhash name namehash))
301 nil)
302
303(defmethod srecode-dictionary-merge ((dict srecode-dictionary) otherdict)
304 "Merge into DICT the dictionary entries from OTHERDICT."
305 (when otherdict
306 (maphash
307 (lambda (key entry)
308 ;; Only merge in the new values if there was no old value.
309 ;; This protects applications from being whacked, and basically
310 ;; makes these new section dictionary entries act like
311 ;; "defaults" instead of overrides.
312 (when (not (srecode-dictionary-lookup-name dict key))
313 (cond ((and (listp entry) (srecode-dictionary-p (car entry)))
314 ;; A list of section dictionaries.
315 ;; We need to merge them in.
316 (while entry
317 (let ((new-sub-dict
318 (srecode-dictionary-add-section-dictionary
319 dict key)))
320 (srecode-dictionary-merge new-sub-dict (car entry)))
321 (setq entry (cdr entry)))
322 )
323
324 (t
325 (srecode-dictionary-set-value dict key entry)))
326 ))
327 (oref otherdict namehash))))
328
329(defmethod srecode-dictionary-lookup-name ((dict srecode-dictionary)
330 name)
331 "Return information about the current DICT's value for NAME."
332 (if (not (slot-boundp dict 'namehash))
333 nil
334 ;; Get the value of this name from the dictionary
335 (or (with-slots (namehash) dict
336 (gethash name namehash))
337 (and (not (member name '("FIRST" "LAST" "NOTFIRST" "NOTLAST")))
338 (oref dict parent)
339 (srecode-dictionary-lookup-name (oref dict parent) name))
340 )))
341
342(defmethod srecode-root-dictionary ((dict srecode-dictionary))
343 "For dictionary DICT, return the root dictionary.
344The root dictionary is usually for a current or active insertion."
345 (let ((ans dict))
346 (while (oref ans parent)
347 (setq ans (oref ans parent)))
348 ans))
349
350;;; COMPOUND VALUE METHODS
351;;
352;; Compound values must provide at least the toStriong method
353;; for use in converting the compound value into sometehing insertable.
354
355(defmethod srecode-compound-toString ((cp srecode-dictionary-compound-value)
356 function
357 dictionary)
358 "Convert the compound dictionary value CP to a string.
359If FUNCTION is non-nil, then FUNCTION is somehow applied to an aspect
360of the compound value. The FUNCTION could be a fraction
361of some function symbol with a logical prefix excluded.
362
363If you subclass `srecode-dictionary-compound-value' then this
364method could return nil, but if it does that, it must insert
365the value itself using `princ', or by detecting if the current
366standard out is a buffer, and using `insert'."
367 (object-name cp))
368
369(defmethod srecode-dump ((cp srecode-dictionary-compound-value)
370 &optional indent)
371 "Display information about this compound value."
372 (princ (object-name cp))
373 )
374
375(defmethod srecode-compound-toString ((cp srecode-dictionary-compound-variable)
376 function
377 dictionary)
378 "Convert the compound dictionary variable value CP into a string.
379FUNCTION and DICTIONARY are as for the baseclass."
380 (require 'srecode/insert)
381 (srecode-insert-code-stream (oref cp compiled) dictionary))
382
383
384(defmethod srecode-dump ((cp srecode-dictionary-compound-variable)
385 &optional indent)
386 "Display information about this compound value."
387 (require 'srecode/compile)
388 (princ "# Compound Variable #\n")
389 (let ((indent (+ 4 (or indent 0)))
390 (cmp (oref cp compiled))
391 )
392 (srecode-dump-code-list cmp (make-string indent ? ))
393 ))
394
395;;; FIELD EDITING COMPOUND VALUE
396;;
397;; This is an interface to using field-editing objects
398;; instead of asking questions. This provides the basics
399;; behind this compound value.
400
401(defclass srecode-field-value (srecode-dictionary-compound-value)
402 ((firstinserter :initarg :firstinserter
403 :documentation
404 "The inserter object for the first occurance of this field.")
405 (defaultvalue :initarg :defaultvalue
406 :documentation
407 "The default value for this inserter.")
408 )
409 "When inserting values with editable field mode, a dictionary value.
410Compound values allow a field to be stored in the dictionary for when
411it is referenced a second time. This compound value can then be
412inserted with a new editable field.")
413
414(defmethod srecode-compound-toString((cp srecode-field-value)
415 function
416 dictionary)
417 "Convert this field into an insertable string."
418 (require 'srecode/fields)
419 ;; If we are not in a buffer, then this is not supported.
420 (when (not (bufferp standard-output))
421 (error "FIELDS invoked while inserting template to non-buffer."))
422
423 (if function
424 (error "@todo: Cannot mix field insertion with functions.")
425
426 ;; No function. Perform a plain field insertion.
427 ;; We know we are in a buffer, so we can perform the insertion.
428 (let* ((dv (oref cp defaultvalue))
429 (sti (oref cp firstinserter))
430 (start (point))
431 (name (oref sti :object-name)))
432
433 (if (or (not dv) (string= dv ""))
434 (insert name)
435 (insert dv))
436
437 (srecode-field name :name name
438 :start start
439 :end (point)
440 :prompt (oref sti prompt)
441 :read-fcn (oref sti read-fcn)
442 )
443 ))
444 ;; Returning nil is a signal that we have done the insertion ourselves.
445 nil)
446
447
448;;; Higher level dictionary functions
449;;
450(defun srecode-create-section-dictionary (sectiondicts STATE)
451 "Create a dictionary with section entries for a template.
452The format for SECTIONDICTS is what is emitted from the template parsers.
453STATE is the current compiler state."
454 (when sectiondicts
455 (let ((new (srecode-create-dictionary t)))
456 ;; Loop over each section. The section is a macro w/in the
457 ;; template.
458 (while sectiondicts
459 (let* ((sect (car (car sectiondicts)))
460 (entries (cdr (car sectiondicts)))
461 (subdict (srecode-dictionary-add-section-dictionary new sect))
462 )
463 ;; Loop over each entry. This is one variable in the
464 ;; section dictionary.
465 (while entries
466 (let ((tname (semantic-tag-name (car entries)))
467 (val (semantic-tag-variable-default (car entries))))
468 (if (eq val t)
469 (srecode-dictionary-show-section subdict tname)
470 (cond
471 ((and (stringp (car val))
472 (= (length val) 1))
473 (setq val (car val)))
474 (t
475 (setq val (srecode-dictionary-compound-variable
476 tname :value val :state STATE))))
477 (srecode-dictionary-set-value
478 subdict tname val))
479 (setq entries (cdr entries))))
480 )
481 (setq sectiondicts (cdr sectiondicts)))
482 new)))
483
484;;; DUMP DICTIONARY
485;;
486;; Make a dictionary, and dump it's contents.
487
488(defun srecode-adebug-dictionary ()
489 "Run data-debug on this mode's dictionary."
490 (interactive)
491 (require 'eieio-datadebug)
492 (require 'semantic)
493 (require 'srecode/find)
494 (let* ((modesym major-mode)
495 (start (current-time))
496 (junk (or (progn (srecode-load-tables-for-mode modesym)
497 (srecode-get-mode-table modesym))
498 (error "No table found for mode %S" modesym)))
499 (dict (srecode-create-dictionary (current-buffer)))
500 (end (current-time))
501 )
502 (message "Creating a dictionary took %.2f seconds."
503 (semantic-elapsed-time start end))
504 (data-debug-new-buffer "*SRECODE ADEBUG*")
505 (data-debug-insert-object-slots dict "*")))
506
507(defun srecode-dictionary-dump ()
508 "Dump a typical fabricated dictionary."
509 (interactive)
510 (require 'srecode/find)
511 (let ((modesym major-mode))
512 ;; This load allows the dictionary access to inherited
513 ;; and stacked dictionary entries.
514 (srecode-load-tables-for-mode modesym)
515 (let ((tmp (srecode-get-mode-table modesym))
516 )
517 (if (not tmp)
518 (error "No table found for mode %S" modesym))
519 ;; Now make the dictionary.
520 (let ((dict (srecode-create-dictionary (current-buffer))))
521 (with-output-to-temp-buffer "*SRECODE DUMP*"
522 (princ "DICTIONARY FOR ")
523 (princ major-mode)
524 (princ "\n--------------------------------------------\n")
525 (srecode-dump dict))
526 ))))
527
528(defmethod srecode-dump ((dict srecode-dictionary) &optional indent)
529 "Dump a dictionary."
530 (if (not indent) (setq indent 0))
531 (maphash (lambda (key entry)
532 (princ (make-string indent ? ))
533 (princ " ")
534 (princ key)
535 (princ " ")
536 (cond ((and (listp entry)
537 (srecode-dictionary-p (car entry)))
538 (let ((newindent (if indent
539 (+ indent 4)
540 4)))
541 (while entry
542 (princ " --> SUBDICTIONARY ")
543 (princ (object-name dict))
544 (princ "\n")
545 (srecode-dump (car entry) newindent)
546 (setq entry (cdr entry))
547 ))
548 (princ "\n")
549 )
550 ((srecode-dictionary-compound-value-child-p entry)
551 (srecode-dump entry indent)
552 (princ "\n")
553 )
554 (t
555 (prin1 entry)
556 ;(princ "\n")
557 ))
558 (terpri)
559 )
560 (oref dict namehash))
561 )
562
563(provide 'srecode/dictionary)
564
565;;; srecode/dictionary.el ends here
diff --git a/lisp/cedet/srecode/document.el b/lisp/cedet/srecode/document.el
new file mode 100644
index 00000000000..fd35a1828e3
--- /dev/null
+++ b/lisp/cedet/srecode/document.el
@@ -0,0 +1,841 @@
1;;; srecode/document.el --- Documentation (comment) generation
2
3;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <eric@siege-engine.com>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;
24;; Routines for fabricating human readable text from function and
25;; variable names as base-text for function comments. Document is not
26;; meant to generate end-text for any function. It is merely meant to
27;; provide some useful base words and text, and as a framework for
28;; managing comments.
29;;
30;;; Origins:
31;;
32;; Document was first written w/ cparse, a custom regexp based c parser.
33;;
34;; Document was then ported to cedet/semantic using sformat (super
35;; format) as the templating engine.
36;;
37;; Document has now been ported to srecode, using the semantic recoder
38;; as the templating engine.
39
40;; This file combines srecode-document.el and srecode-document-vars.el
41;; from the CEDET repository.
42
43(require 'srecode/args)
44(require 'srecode/dictionary)
45(require 'srecode/extract)
46(require 'srecode/insert)
47(require 'srecode/semantic)
48
49(require 'semantic)
50(require 'semantic/tag)
51(require 'semantic/doc)
52(require 'pulse)
53
54;;; Code:
55
56(defgroup document nil
57 "File and tag browser frame."
58 :group 'texinfo
59 :group 'srecode)
60
61(defcustom srecode-document-autocomment-common-nouns-abbrevs
62 '(
63 ("sock\\(et\\)?" . "socket")
64 ("addr\\(ess\\)?" . "address")
65 ("buf\\(f\\(er\\)?\\)?" . "buffer")
66 ("cur\\(r\\(ent\\)?\\)?" . "current")
67 ("dev\\(ice\\)?" . "device")
68 ("doc" . "document")
69 ("i18n" . "internationalization")
70 ("file" . "file")
71 ("line" . "line")
72 ("l10n" . "localization")
73 ("msg\\|message" . "message")
74 ("name" . "name")
75 ("next\\|nxt" . "next")
76 ("num\\(ber\\)?" . "number")
77 ("port" . "port")
78 ("host" . "host")
79 ("obj\\|object" . "object")
80 ("previous\\|prev" . "previous")
81 ("str\\(ing\\)?" . "string")
82 ("use?r" . "user")
83 ("\\(^\\|\\s-\\)id\\($\\|\\s-\\)" . "Identifier") ;complex cause ;common syllable
84 )
85 "List of common English abbreviations or full words.
86These are nouns (as opposed to verbs) for use in creating expanded
87versions of names.This is an alist with each element of the form:
88 (MATCH . RESULT)
89MATCH is a regexp to match in the type field.
90RESULT is a string."
91 :group 'document
92 :type '(repeat (cons (string :tag "Regexp")
93 (string :tag "Doc Text"))))
94
95(defcustom srecode-document-autocomment-function-alist
96 '(
97 ("abort" . "Aborts the")
98 ;; trick to get re-alloc and alloc to pair into one sentence.
99 ("realloc" . "moves or ")
100 ("alloc\\(ate\\)?" . "Allocates and initializes a new ")
101 ("clean" . "Cleans up the")
102 ("clobber" . "Removes")
103 ("close" . "Cleanly closes")
104 ("check" . "Checks the")
105 ("comp\\(are\\)?" . "Compares the")
106 ("create" . "Creates a new ")
107 ("find" . "Finds ")
108 ("free" . "Frees up space")
109 ("gen\\(erate\\)?" . "Generates a new ")
110 ("get\\|find" . "Looks for the given ")
111 ("gobble" . "Removes")
112 ("he?lp" . "Provides help for")
113 ("li?ste?n" . "Listens for ")
114 ("connect" . "Connects to ")
115 ("acc?e?pt" . "Accepts a ")
116 ("load" . "Loads in ")
117 ("match" . "Check that parameters match")
118 ("name" . "Provides a name which ")
119 ("new" . "Allocates a ")
120 ("parse" . "Parses the parameters and returns ")
121 ("print\\|display" . "Prints out")
122 ("read" . "Reads from")
123 ("reset" . "Resets the parameters and returns")
124 ("scan" . "Scans the ")
125 ("setup\\|init\\(iallize\\)?" . "Initializes the ")
126 ("select" . "Chooses the ")
127 ("send" . "Sends a")
128 ("re?c\\(v\\|ieves?\\)" . "Receives a ")
129 ("to" . "Converts ")
130 ("update" . "Updates the ")
131 ("wait" . "Waits for ")
132 ("write" . "Writes to")
133 )
134 "List of names to string match against the function name.
135This is an alist with each element of the form:
136 (MATCH . RESULT)
137MATCH is a regexp to match in the type field.
138RESULT is a string.
139
140Certain prefixes may always mean the same thing, and the same comment
141can be used as a beginning for the description. Regexp should be
142lower case since the string they are compared to is downcased.
143A string may end in a space, in which case, last-alist is searched to
144see how best to describe what can be returned.
145Doesn't always work correctly, but that is just because English
146doesn't always work correctly."
147 :group 'document
148 :type '(repeat (cons (string :tag "Regexp")
149 (string :tag "Doc Text"))))
150
151(defcustom srecode-document-autocomment-common-nouns-abbrevs
152 '(
153 ("sock\\(et\\)?" . "socket")
154 ("addr\\(ess\\)?" . "address")
155 ("buf\\(f\\(er\\)?\\)?" . "buffer")
156 ("cur\\(r\\(ent\\)?\\)?" . "current")
157 ("dev\\(ice\\)?" . "device")
158 ("file" . "file")
159 ("line" . "line")
160 ("msg\\|message" . "message")
161 ("name" . "name")
162 ("next\\|nxt" . "next")
163 ("port" . "port")
164 ("host" . "host")
165 ("obj\\|object" . "object")
166 ("previous\\|prev" . "previous")
167 ("str\\(ing\\)?" . "string")
168 ("use?r" . "user")
169 ("num\\(ber\\)?" . "number")
170 ("\\(^\\|\\s-\\)id\\($\\|\\s-\\)" . "Identifier") ;complex cause ;commen sylable
171 )
172 "List of common English abbreviations or full words.
173These are nouns (as opposed to verbs) for use in creating expanded
174versions of names.This is an alist with each element of the form:
175 (MATCH . RESULT)
176MATCH is a regexp to match in the type field.
177RESULT is a string."
178 :group 'document
179 :type '(repeat (cons (string :tag "Regexp")
180 (string :tag "Doc Text"))))
181
182(defcustom srecode-document-autocomment-return-first-alist
183 '(
184 ;; Static must be first in the list to provide the intro to the sentence
185 ("static" . "Locally defined function which ")
186 ("Bool\\|BOOL" . "Status of ")
187 )
188 "List of regexp matches for types.
189They provide a little bit of text when typing information is
190described.
191This is an alist with each element of the form:
192 (MATCH . RESULT)
193MATCH is a regexp to match in the type field.
194RESULT is a string."
195 :group 'document
196 :type '(repeat (cons (string :tag "Regexp")
197 (string :tag "Doc Text"))))
198
199(defcustom srecode-document-autocomment-return-last-alist
200 '(
201 ("static[ \t\n]+struct \\([a-zA-Z0-9_]+\\)" . "%s")
202 ("struct \\([a-zA-Z0-9_]+\\)" . "%s")
203 ("static[ \t\n]+union \\([a-zA-Z0-9_]+\\)" . "%s")
204 ("union \\([a-zA-Z0-9_]+\\)" . "%s")
205 ("static[ \t\n]+enum \\([a-zA-Z0-9_]+\\)" . "%s")
206 ("enum \\([a-zA-Z0-9_]+\\)" . "%s")
207 ("static[ \t\n]+\\([a-zA-Z0-9_]+\\)" . "%s")
208 ("\\([a-zA-Z0-9_]+\\)" . "of type %s")
209 )
210 "List of regexps which provide the type of the return value.
211This is an alist with each element of the form:
212 (MATCH . RESULT)
213MATCH is a regexp to match in the type field.
214RESULT is a string, which can contain %s, whih is replaced with
215`match-string' 1."
216 :group 'document
217 :type '(repeat (cons (string :tag "Regexp")
218 (string :tag "Doc Text"))))
219
220(defcustom srecode-document-autocomment-param-alist
221 '( ("[Cc]txt" . "Context")
222 ("[Ii]d" . "Identifier of")
223 ("[Tt]ype" . "Type of")
224 ("[Nn]ame" . "Name of")
225 ("argc" . "Number of arguments")
226 ("argv" . "Argument vector")
227 ("envp" . "Environment variable vector")
228 )
229 "Alist of common variable names appearing as function parameters.
230This is an alist with each element of the form:
231 (MATCH . RESULT)
232MATCH is a regexp to match in the type field.
233RESULT is a string of text to use to describe MATCH.
234When one is encountered, document-insert-parameters will automatically
235place this comment after the parameter name."
236 :group 'document
237 :type '(repeat (cons (string :tag "Regexp")
238 (string :tag "Doc Text"))))
239
240(defcustom srecode-document-autocomment-param-type-alist
241 '(("const" . "Constant")
242 ("void" . "Empty")
243 ("char[ ]*\\*" . "String ")
244 ("\\*\\*" . "Pointer to ")
245 ("\\*" . "Pointer ")
246 ("char[ ]*\\([^ \t*]\\|$\\)" . "Character")
247 ("int\\|long" . "Number of")
248 ("FILE" . "File of")
249 ("float\\|double" . "Value of")
250 ;; How about some X things?
251 ("Bool\\|BOOL" . "Flag")
252 ("Window" . "Window")
253 ("GC" . "Graphic Context")
254 ("Widget" . "Widget")
255 )
256 "Alist of input parameter types and strings desribing them.
257This is an alist with each element of the form:
258 (MATCH . RESULT)
259MATCH is a regexp to match in the type field.
260RESULT is a string."
261 :group 'document
262 :type '(repeat (cons (string :tag "Regexp")
263 (string :tag "Doc Text"))))
264
265;;;###autoload
266(defun srecode-document-insert-comment ()
267 "Insert some comments.
268Whack any comments that may be in the way and replace them.
269If the region is active, then insert group function comments.
270If the cursor is in a comment, figure out what kind of comment it is
271 and replace it.
272If the cursor is in a function, insert a function comment.
273If the cursor is on a one line prototype, then insert post-fcn comments."
274 (interactive)
275 (semantic-fetch-tags)
276 (let ((ctxt (srecode-calculate-context)))
277 (if ;; Active region stuff.
278 (or srecode-handle-region-when-non-active-flag
279 (eq last-command 'mouse-drag-region)
280 (and transient-mark-mode mark-active))
281 (if (> (point) (mark))
282 (srecode-document-insert-group-comments (mark) (point))
283 (srecode-document-insert-group-comments (point) (mark)))
284 ;; ELSE
285
286 ;; A declaration comment. Find what it documents.
287 (when (equal ctxt '("declaration" "comment"))
288
289 ;; If we are on a one line tag/comment, go to that fcn.
290 (if (save-excursion (back-to-indentation)
291 (semantic-current-tag))
292 (back-to-indentation)
293
294 ;; Else, do we have a fcn following us?
295 (let ((tag (semantic-find-tag-by-overlay-next)))
296 (when tag (semantic-go-to-tag tag))))
297 )
298
299 ;; Now analyze the tag we may be on.
300
301 (if (semantic-current-tag)
302 (cond
303 ;; A one-line variable
304 ((and (semantic-tag-of-class-p (semantic-current-tag) 'variable)
305 (srecode-document-one-line-tag-p (semantic-current-tag)))
306 (srecode-document-insert-variable-one-line-comment))
307 ;; A plain function
308 ((semantic-tag-of-class-p (semantic-current-tag) 'function)
309 (srecode-document-insert-function-comment))
310 ;; Don't know.
311 (t
312 (error "Not sure what to comment"))
313 )
314
315 ;; ELSE, no tag. Perhaps we should just insert a nice section
316 ;; header??
317
318 (let ((title (read-string "Section Title (RET to skip): ")))
319
320 (when (and (stringp title) (not (= (length title) 0)))
321 (srecode-document-insert-section-comment title)))
322
323 ))))
324
325(defun srecode-document-insert-section-comment (&optional title)
326 "Insert a section comment with TITLE."
327 (interactive "sSection Title: ")
328
329 (srecode-load-tables-for-mode major-mode)
330 (srecode-load-tables-for-mode major-mode 'document)
331
332 (if (not (srecode-table))
333 (error "No template table found for mode %s" major-mode))
334
335 (let* ((dict (srecode-create-dictionary))
336 (temp (srecode-template-get-table (srecode-table)
337 "section-comment"
338 "declaration"
339 'document)))
340 (if (not temp)
341 (error "No templates for inserting section comments"))
342
343 (when title
344 (srecode-dictionary-set-value
345 dict "TITLE" title))
346
347 (srecode-insert-fcn temp dict)
348 ))
349
350
351(defun srecode-document-trim-whitespace (str)
352 "Strip stray whitespace from around STR."
353 (when (string-match "^\\(\\s-\\|\n\\)+" str)
354 (setq str (replace-match "" t t str)))
355 (when (string-match "\\(\\s-\\|\n\\)+$" str)
356 (setq str (replace-match "" t t str)))
357 str)
358
359;;;###autoload
360(defun srecode-document-insert-function-comment (&optional fcn-in)
361 "Insert or replace a function comment.
362FCN-IN is the Semantic tag of the function to add a comment too.
363If FCN-IN is not provied, the current tag is used instead.
364It is assumed that the comment occurs just in front of FCN-IN."
365 (interactive)
366
367 (srecode-load-tables-for-mode major-mode)
368 (srecode-load-tables-for-mode major-mode 'document)
369
370 (if (not (srecode-table))
371 (error "No template table found for mode %s" major-mode))
372
373 (let* ((dict (srecode-create-dictionary))
374 (temp (srecode-template-get-table (srecode-table)
375 "function-comment"
376 "declaration"
377 'document)))
378 (if (not temp)
379 (error "No templates for inserting function comments"))
380
381 ;; Try to figure out the tag we want to use.
382 (when (not fcn-in)
383 (semantic-fetch-tags)
384 (setq fcn-in (semantic-current-tag)))
385
386 (when (or (not fcn-in)
387 (not (semantic-tag-of-class-p fcn-in 'function)))
388 (error "No tag of class 'function to insert comment for"))
389
390 (if (not (eq (current-buffer) (semantic-tag-buffer fcn-in)))
391 (error "Only insert comments for tags in the current buffer"))
392
393 ;; Find any existing doc strings.
394 (semantic-go-to-tag fcn-in)
395 (beginning-of-line)
396 (forward-char -1)
397
398 (let ((lextok (semantic-documentation-comment-preceeding-tag fcn-in 'lex))
399 (doctext
400 (srecode-document-function-name-comment fcn-in))
401 )
402
403 (when lextok
404 (let* ((s (semantic-lex-token-start lextok))
405 (e (semantic-lex-token-end lextok))
406 (plaintext
407 (srecode-document-trim-whitespace
408 (save-excursion
409 (goto-char s)
410 (semantic-doc-snarf-comment-for-tag nil))))
411 (extract (condition-case nil
412 (srecode-extract temp s e)
413 (error nil))
414 )
415 (distance (count-lines e (semantic-tag-start fcn-in)))
416 (belongelsewhere (save-excursion
417 (goto-char s)
418 (back-to-indentation)
419 (semantic-current-tag)))
420 )
421
422 (when (not belongelsewhere)
423
424 (pulse-momentary-highlight-region s e)
425
426 ;; There are many possible states that comment could be in.
427 ;; Take a guess about what the user would like to do, and ask
428 ;; the right kind of question.
429 (when (or (not (> distance 2))
430 (y-or-n-p "Replace this comment? "))
431
432 (when (> distance 2)
433 (goto-char e)
434 (delete-horizontal-space)
435 (delete-blank-lines))
436
437 (cond
438 ((and plaintext (not extract))
439 (if (y-or-n-p "Convert old-style comment to Template with old text? ")
440 (setq doctext plaintext))
441 (delete-region s e)
442 (goto-char s))
443 (extract
444 (when (y-or-n-p "Refresh pre-existing comment (recycle old doc)? ")
445 (delete-region s e)
446 (goto-char s)
447 (setq doctext
448 (srecode-document-trim-whitespace
449 (srecode-dictionary-lookup-name extract "DOC")))))
450 ))
451 )))
452
453 (beginning-of-line)
454
455 ;; Perform the insertion
456 (let ((srecode-semantic-selected-tag fcn-in)
457 (srecode-semantic-apply-tag-augment-hook
458 (lambda (tag dict)
459 (srecode-dictionary-set-value
460 dict "DOC"
461 (if (eq tag fcn-in)
462 doctext
463 (srecode-document-parameter-comment tag))
464 )))
465 )
466 (srecode-insert-fcn temp dict)
467 ))
468 ))
469
470;;;###autoload
471(defun srecode-document-insert-variable-one-line-comment (&optional var-in)
472 "Insert or replace a variable comment.
473VAR-IN is the Semantic tag of the function to add a comment too.
474If VAR-IN is not provied, the current tag is used instead.
475It is assumed that the comment occurs just after VAR-IN."
476 (interactive)
477
478 (srecode-load-tables-for-mode major-mode)
479 (srecode-load-tables-for-mode major-mode 'document)
480
481 (if (not (srecode-table))
482 (error "No template table found for mode %s" major-mode))
483
484 (let* ((dict (srecode-create-dictionary))
485 (temp (srecode-template-get-table (srecode-table)
486 "variable-same-line-comment"
487 "declaration"
488 'document)))
489 (if (not temp)
490 (error "No templates for inserting variable comments"))
491
492 ;; Try to figure out the tag we want to use.
493 (when (not var-in)
494 (semantic-fetch-tags)
495 (setq var-in (semantic-current-tag)))
496
497 (when (or (not var-in)
498 (not (semantic-tag-of-class-p var-in 'variable)))
499 (error "No tag of class 'variable to insert comment for"))
500
501 (if (not (eq (current-buffer) (semantic-tag-buffer var-in)))
502 (error "Only insert comments for tags in the current buffer"))
503
504 ;; Find any existing doc strings.
505 (goto-char (semantic-tag-end var-in))
506 (skip-syntax-forward "-" (point-at-eol))
507 (let ((lextok (semantic-doc-snarf-comment-for-tag 'lex))
508 )
509
510 (when lextok
511 (let ((s (semantic-lex-token-start lextok))
512 (e (semantic-lex-token-end lextok)))
513
514 (pulse-momentary-highlight-region s e)
515
516 (when (not (y-or-n-p "A comment already exists. Replace? "))
517 (error "Quit"))
518
519 ;; Extract text from the existing comment.
520 (srecode-extract temp s e)
521
522 (delete-region s e)
523 (goto-char s) ;; To avoid adding a CR.
524 ))
525 )
526
527 ;; Clean up the end of the line and use handy comment-column.
528 (end-of-line)
529 (delete-horizontal-space)
530 (move-to-column comment-column t)
531 (when (< (point) (point-at-eol)) (end-of-line))
532
533 ;; Perform the insertion
534 (let ((srecode-semantic-selected-tag var-in)
535 (srecode-semantic-apply-tag-augment-hook
536 (lambda (tag dict)
537 (srecode-dictionary-set-value
538 dict "DOC" (srecode-document-parameter-comment
539 tag))))
540 )
541 (srecode-insert-fcn temp dict)
542 ))
543 )
544
545;;;###autoload
546(defun srecode-document-insert-group-comments (beg end)
547 "Insert group comments around the active between BEG and END.
548If the region includes only parts of some tags, expand out
549to the beginning and end of the tags on the region.
550If there is only one tag in the region, complain."
551 (interactive "r")
552 (srecode-load-tables-for-mode major-mode)
553 (srecode-load-tables-for-mode major-mode 'document)
554
555 (if (not (srecode-table))
556 (error "No template table found for mode %s" major-mode))
557
558 (let* ((dict (srecode-create-dictionary))
559 (context "declaration")
560 (temp-start nil)
561 (temp-end nil)
562 (tag-start (save-excursion
563 (goto-char beg)
564 (or (semantic-current-tag)
565 (semantic-find-tag-by-overlay-next))))
566 (tag-end (save-excursion
567 (goto-char end)
568 (or (semantic-current-tag)
569 (semantic-find-tag-by-overlay-prev))))
570 (parent-tag nil)
571 (first-pos beg)
572 (second-pos end)
573 )
574
575 ;; If beg/end wrapped nothing, then tag-start,end would actually
576 ;; point at some odd stuff that is out of order.
577 (when (or (not tag-start) (not tag-end)
578 (> (semantic-tag-end tag-start)
579 (semantic-tag-start tag-end)))
580 (setq tag-start nil
581 tag-end nil))
582
583 (when tag-start
584 ;; If tag-start and -end are the same, and it is a class or
585 ;; struct, try to find child tags inside the classdecl.
586 (cond
587 ((and (eq tag-start tag-end)
588 tag-start
589 (semantic-tag-of-class-p tag-start 'type))
590 (setq parent-tag tag-start)
591 (setq tag-start (semantic-find-tag-by-overlay-next beg)
592 tag-end (semantic-find-tag-by-overlay-prev end))
593 )
594 ((eq (semantic-find-tag-parent-by-overlay tag-start) tag-end)
595 (setq parent-tag tag-end)
596 (setq tag-end (semantic-find-tag-by-overlay-prev end))
597 )
598 ((eq tag-start (semantic-find-tag-parent-by-overlay tag-end))
599 (setq parent-tag tag-start)
600 (setq tag-start (semantic-find-tag-by-overlay-next beg))
601 )
602 )
603
604 (when parent-tag
605 ;; We are probably in a classdecl
606 ;; @todo -could I really use (srecode-calculate-context) ?
607
608 (setq context "classdecl")
609 )
610
611 ;; Derive start and end locations based on the tags.
612 (setq first-pos (semantic-tag-start tag-start)
613 second-pos (semantic-tag-end tag-end))
614 )
615 ;; Now load the templates
616 (setq temp-start (srecode-template-get-table (srecode-table)
617 "group-comment-start"
618 context
619 'document)
620 temp-end (srecode-template-get-table (srecode-table)
621 "group-comment-end"
622 context
623 'document))
624
625 (when (or (not temp-start) (not temp-end))
626 (error "No templates for inserting group comments"))
627
628 ;; Setup the name of this group ahead of time.
629
630 ;; @todo - guess at a name based on common strings
631 ;; of the tags in the group.
632 (srecode-dictionary-set-value
633 dict "GROUPNAME"
634 (read-string "Name of group: "))
635
636 ;; Perform the insertion
637 ;; Do the end first so we don't need to recalculate anything.
638 ;;
639 (goto-char second-pos)
640 (end-of-line)
641 (srecode-insert-fcn temp-end dict)
642
643 (goto-char first-pos)
644 (beginning-of-line)
645 (srecode-insert-fcn temp-start dict)
646
647 ))
648
649
650;;; Document Generation Functions
651;;
652;; Routines for making up English style comments.
653
654(defun srecode-document-function-name-comment (tag)
655 "Create documentation for the function defined in TAG.
656If we can identify a verb in the list followed by some
657name part then check the return value to see if we can use that to
658finish off the sentence. ie. any function with 'alloc' in it will be
659allocating something based on its type."
660 (let ((al srecode-document-autocomment-return-first-alist)
661 (dropit nil)
662 (tailit nil)
663 (news "")
664 (fname (semantic-tag-name tag))
665 (retval (or (semantic-tag-type tag) "")))
666 (if (listp retval)
667 ;; convert a type list into a long string to analyze.
668 (setq retval (car retval)))
669 ;; check for modifiers like static
670 (while al
671 (if (string-match (car (car al)) (downcase retval))
672 (progn
673 (setq news (concat news (cdr (car al))))
674 (setq dropit t)
675 (setq al nil)))
676 (setq al (cdr al)))
677 ;; check for verb parts!
678 (setq al srecode-document-autocomment-function-alist)
679 (while al
680 (if (string-match (car (car al)) (downcase fname))
681 (progn
682 (setq news
683 (concat news (if dropit (downcase (cdr (car al)))
684 (cdr (car al)))))
685 ;; if we end in a space, then we are expecting a potential
686 ;; return value.
687 (if (= ? (aref news (1- (length news))))
688 (setq tailit t))
689 (setq al nil)))
690 (setq al (cdr al)))
691 ;; check for noun parts!
692 (setq al srecode-document-autocomment-common-nouns-abbrevs)
693 (while al
694 (if (string-match (car (car al)) (downcase fname))
695 (progn
696 (setq news
697 (concat news (if dropit (downcase (cdr (car al)))
698 (cdr (car al)))))
699 (setq al nil)))
700 (setq al (cdr al)))
701 ;; add tailers to names which are obviously returning something.
702 (if tailit
703 (progn
704 (setq al srecode-document-autocomment-return-last-alist)
705 (while al
706 (if (string-match (car (car al)) (downcase retval))
707 (progn
708 (setq news
709 (concat news " "
710 ;; this one may use parts of the return value.
711 (format (cdr (car al))
712 (srecode-document-programmer->english
713 (substring retval (match-beginning 1)
714 (match-end 1))))))
715 (setq al nil)))
716 (setq al (cdr al)))))
717 news))
718
719(defun srecode-document-parameter-comment (param &optional commentlist)
720 "Convert tag or string PARAM into a name,comment pair.
721Optional COMMENTLIST is list of previously existing comments to
722use instead in alist form. If the name doesn't appear in the list of
723standard names, then englishify it instead."
724 (let ((cmt "")
725 (aso srecode-document-autocomment-param-alist)
726 (fnd nil)
727 (name (if (stringp param) param (semantic-tag-name param)))
728 (tt (if (stringp param) nil (semantic-tag-type param))))
729 ;; Make sure the type is a string.
730 (if (listp tt)
731 (setq tt (semantic-tag-name tt)))
732 ;; Find name description parts.
733 (while aso
734 (if (string-match (car (car aso)) name)
735 (progn
736 (setq fnd t)
737 (setq cmt (concat cmt (cdr (car aso))))))
738 (setq aso (cdr aso)))
739 (if (/= (length cmt) 0)
740 nil
741 ;; finally check for array parts
742 (if (and (not (stringp param)) (semantic-tag-modifiers param))
743 (setq cmt (concat cmt "array of ")))
744 (setq aso srecode-document-autocomment-param-type-alist)
745 (while (and aso tt)
746 (if (string-match (car (car aso)) tt)
747 (setq cmt (concat cmt (cdr (car aso)))))
748 (setq aso (cdr aso))))
749 ;; Convert from programmer to english.
750 (if (not fnd)
751 (setq cmt (concat cmt " "
752 (srecode-document-programmer->english name))))
753 cmt))
754
755(defun srecode-document-programmer->english (programmer)
756 "Take PROGRAMMER and convert it into English.
757Works with the following rules:
758 1) convert all _ into spaces.
759 2) inserts spaces between CamelCasing word breaks.
760 3) expands noun names based on common programmer nouns.
761
762 This function is designed for variables, not functions. This does
763not account for verb parts."
764 (if (string= "" programmer)
765 ""
766 (let ((ind 0) ;index in string
767 (llow nil) ;lower/upper case flag
768 (newstr nil) ;new string being generated
769 (al nil)) ;autocomment list
770 ;;
771 ;; 1) Convert underscores
772 ;;
773 (while (< ind (length programmer))
774 (setq newstr (concat newstr
775 (if (= (aref programmer ind) ?_)
776 " " (char-to-string (aref programmer ind)))))
777 (setq ind (1+ ind)))
778 (setq programmer newstr
779 newstr nil
780 ind 0)
781 ;;
782 ;; 2) Find word breaks between case changes
783 ;;
784 (while (< ind (length programmer))
785 (setq newstr
786 (concat newstr
787 (let ((tc (aref programmer ind)))
788 (if (and (>= tc ?a) (<= tc ?z))
789 (progn
790 (setq llow t)
791 (char-to-string tc))
792 (if llow
793 (progn
794 (setq llow nil)
795 (concat " " (char-to-string tc)))
796 (char-to-string tc))))))
797 (setq ind (1+ ind)))
798 ;;
799 ;; 3) Expand the words if possible
800 ;;
801 (setq llow nil
802 ind 0
803 programmer newstr
804 newstr nil)
805 (while (string-match (concat "^\\s-*\\([^ \t\n]+\\)") programmer)
806 (let ((ts (substring programmer (match-beginning 1) (match-end 1)))
807 (end (match-end 1)))
808 (setq al srecode-document-autocomment-common-nouns-abbrevs)
809 (setq llow nil)
810 (while al
811 (if (string-match (car (car al)) (downcase ts))
812 (progn
813 (setq newstr (concat newstr (cdr (car al))))
814 ;; don't terminate because we may actuall have 2 words
815 ;; next to eachother we didn't identify before
816 (setq llow t)))
817 (setq al (cdr al)))
818 (if (not llow) (setq newstr (concat newstr ts)))
819 (setq newstr (concat newstr " "))
820 (setq programmer (substring programmer end))))
821 newstr)))
822
823;;; UTILS
824;;
825(defun srecode-document-one-line-tag-p (tag)
826 "Does TAG fit on one line with space on the end?"
827 (save-excursion
828 (semantic-go-to-tag tag)
829 (and (<= (semantic-tag-end tag) (point-at-eol))
830 (goto-char (semantic-tag-end tag))
831 (< (current-column) 70))))
832
833(provide 'srecode/document)
834
835;; Local variables:
836;; generated-autoload-file: "loaddefs.el"
837;; generated-autoload-feature: srecode/loaddefs
838;; generated-autoload-load-name: "srecode/document"
839;; End:
840
841;;; srecode/document.el ends here
diff --git a/lisp/cedet/srecode/el.el b/lisp/cedet/srecode/el.el
new file mode 100644
index 00000000000..3df606a59c5
--- /dev/null
+++ b/lisp/cedet/srecode/el.el
@@ -0,0 +1,113 @@
1;;; srecode/el.el --- Emacs Lisp specific arguments
2
3;; Copyright (C) 2008 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <eric@siege-engine.com>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;
24;; Emacs Lisp specific handlers. To use these handlers in your
25;; template, add the :name part to your template argument list.
26;;
27;; Error if not in a Emacs Lisp mode
28
29;;; Code:
30
31(require 'srecode)
32(require 'srecode/semantic)
33
34(declare-function semanticdb-brute-find-tags-by-class "semantic/db-find")
35
36;;;###autoload
37(defun srecode-semantic-handle-:el (dict)
38 "Add macros into the dictionary DICT based on the current Emacs Lisp file.
39Adds the following:
40 PRENAME - The common name prefix of this file."
41 (let* ((names (append (semantic-find-tags-by-class 'function (current-buffer))
42 (semantic-find-tags-by-class 'variable (current-buffer)))
43 )
44 (common (try-completion "" names)))
45
46 (srecode-dictionary-set-value dict "PRENAME" common)
47 ))
48
49;;;###autoload
50(defun srecode-semantic-handle-:el-custom (dict)
51 "Add macros into the dictionary DICT based on the current Emacs Lisp file.
52Adds the following:
53 GROUP - The 'defgroup' name we guess you want for variables.
54 FACEGROUP - The `defgroup' name you might want for faces."
55 (require 'semantic/db-find)
56 (let ((groups (semanticdb-strip-find-results
57 (semanticdb-brute-find-tags-by-class 'customgroup)))
58 (varg nil)
59 (faceg nil)
60 )
61
62 ;; Pick the best group
63 (while groups
64 (cond ((string-match "face" (semantic-tag-name (car groups)))
65 (setq faceg (car groups)))
66 ((not varg)
67 (setq varg (car groups)))
68 (t
69 ;; What about other groups?
70 ))
71 (setq groups (cdr groups)))
72
73 ;; Double check the facegroup.
74 (setq faceg (or faceg varg))
75
76 ;; Setup some variables
77 (srecode-dictionary-set-value dict "GROUP" (semantic-tag-name varg))
78 (srecode-dictionary-set-value dict "FACEGROUP" (semantic-tag-name faceg))
79
80 ))
81
82(define-mode-local-override srecode-semantic-apply-tag-to-dict
83 emacs-lisp-mode (tagobj dict)
84 "Apply Emacs Lisp specific features from TAGOBJ into DICT.
85Calls `srecode-semantic-apply-tag-to-dict-default' first."
86 (srecode-semantic-apply-tag-to-dict-default tagobj dict)
87
88 ;; Pull out the tag for the individual pieces.
89 (let* ((tag (oref tagobj :prime))
90 (doc (semantic-tag-docstring tag)))
91
92 ;; It is much more common to have doc on ELisp.
93 (srecode-dictionary-set-value dict "DOC" doc)
94
95 (cond
96 ;;
97 ;; FUNCTION
98 ;;
99 ((eq (semantic-tag-class tag) 'function)
100 (if (semantic-tag-get-attribute tag :user-visible-flag)
101 (srecode-dictionary-set-value dict "INTERACTIVE" " (interactive)\n ")
102 (srecode-dictionary-set-value dict "INTERACTIVE" ""))))))
103
104
105(provide 'srecode/el)
106
107;; Local variables:
108;; generated-autoload-file: "loaddefs.el"
109;; generated-autoload-feature: srecode/loaddefs
110;; generated-autoload-load-name: "srecode/el"
111;; End:
112
113;;; srecode/el.el ends here
diff --git a/lisp/cedet/srecode/expandproto.el b/lisp/cedet/srecode/expandproto.el
new file mode 100644
index 00000000000..eb09ed260bd
--- /dev/null
+++ b/lisp/cedet/srecode/expandproto.el
@@ -0,0 +1,132 @@
1;;; srecode/expandproto.el --- Expanding prototypes.
2
3;; Copyright (C) 2007 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <eric@siege-engine.com>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;
24;; Methods for expanding a prototype into an implementation.
25
26(require 'ring)
27(require 'semantic)
28(require 'semantic/analyze)
29(require 'srecode/insert)
30(require 'srecode/dictionary)
31
32(declare-function semantic-brute-find-tag-by-attribute-value "semantic/find")
33
34;;; Code:
35(defcustom srecode-expandproto-template-file-alist
36 '( ( c++-mode . "srecode-expandproto-cpp.srt" )
37 )
38 ;; @todo - Make this variable auto-generated from the Makefile.
39 "Associate template files for expanding prototypes to a major mode."
40 :group 'srecode
41 :type '(repeat (cons (sexp :tag "Mode")
42 (sexp :tag "Filename"))
43 ))
44
45;;;###autoload
46(defun srecode-insert-prototype-expansion ()
47 "Insert get/set methods for the current class."
48 (interactive)
49
50 (srecode-load-tables-for-mode major-mode)
51 (srecode-load-tables-for-mode major-mode
52 srecode-expandproto-template-file-alist)
53
54 (if (not (srecode-table))
55 (error "No template table found for mode %s" major-mode))
56
57 (let ((proto
58 ;; Step 1: Find the prototype, or prototype list to expand.
59 (srecode-find-prototype-for-expansion)))
60
61 (if (not proto)
62 (error "Could not find prototype to expand"))
63
64 ;; Step 2: Insert implementations of the prototypes.
65
66
67 ))
68
69(defun srecode-find-prototype-for-expansion ()
70 "Find a prototype to use for expanding into an implementation."
71 ;; We may find a prototype tag in one of several places.
72 ;; Search in order of logical priority.
73 (let ((proto nil)
74 )
75
76 ;; 1) A class full of prototypes under point.
77 (let ((tag (semantic-current-tag)))
78 (when tag
79 (when (not (semantic-tag-of-class-p tag 'type))
80 (setq tag (semantic-current-tag-parent))))
81 (when (and tag (semantic-tag-of-class-p tag 'type))
82 ;; If the current class has prototype members, then
83 ;; we will do the whole class!
84 (require 'semantic/find)
85 (if (semantic-brute-find-tag-by-attribute-value
86 :prototype t
87 (semantic-tag-type-members tag))
88 (setq proto tag)))
89 )
90
91 ;; 2) A prototype under point.
92 (when (not proto)
93 (let ((tag (semantic-current-tag)))
94 (when (and tag
95 (and
96 (semantic-tag-of-class-p tag 'function)
97 (semantic-tag-get-attribute tag :prototype)))
98 (setq proto tag))))
99
100 ;; 3) A tag in the kill ring that is a prototype
101 (when (not proto)
102 (if (ring-empty-p senator-tag-ring)
103 nil ;; Not for us.
104 (let ((tag (ring-ref senator-tag-ring 0))
105 )
106 (when
107 (and tag
108 (or
109 (and
110 (semantic-tag-of-class-p tag 'function)
111 (semantic-tag-get-attribute tag :prototype))
112 (and
113 (semantic-tag-of-class-p tag 'type)
114 (require 'semantic/find)
115 (semantic-brute-find-tag-by-attribute-value
116 :prototype t
117 (semantic-tag-type-members tag))))
118 )
119 (setq proto tag))
120 )))
121
122 proto))
123
124(provide 'srecode-expandproto)
125
126;; Local variables:
127;; generated-autoload-file: "loaddefs.el"
128;; generated-autoload-feature: srecode/loaddefs
129;; generated-autoload-load-name: "srecode/expandproto"
130;; End:
131
132;;; srecode/expandproto.el ends here
diff --git a/lisp/cedet/srecode/extract.el b/lisp/cedet/srecode/extract.el
new file mode 100644
index 00000000000..c6de1e1faaa
--- /dev/null
+++ b/lisp/cedet/srecode/extract.el
@@ -0,0 +1,242 @@
1;;; srecode/extract.el --- Extract content from previously inserted macro.
2
3;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <eric@siege-engine.com>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;
24;; Extract content from a previously inserted macro.
25;;
26;; The extraction routines can be handy if you want to extract users
27;; added text from the middle of a template inserted block of text.
28;; This code will not work for all templates. It will only work for
29;; templates with unique static text between all the different insert
30;; macros.
31;;
32;; That said, it will handle include and section templates, so complex
33;; or deep template calls can be extracted.
34;;
35;; This code was specifically written for srecode-document, which
36;; wants to extract user written text, and re-use it in a reformatted
37;; comment.
38
39(require 'srecode)
40(require 'srecode/compile)
41(require 'srecode/insert)
42
43;;; Code:
44
45(defclass srecode-extract-state ()
46 ((anchor :initform nil
47 :documentation
48 "The last known plain-text end location.")
49 (lastinserter :initform nil
50 :documentation
51 "The last inserter with 'later extraction type.")
52 (lastdict :initform nil
53 :documentation
54 "The dictionary associated with lastinserter.")
55 )
56 "The current extraction state.")
57
58(defmethod srecode-extract-state-set ((st srecode-extract-state) ins dict)
59 "Set onto the extract state ST a new inserter INS and dictinary DICT."
60 (oset st lastinserter ins)
61 (oset st lastdict dict))
62
63(defmethod srecode-extract-state-set-anchor ((st srecode-extract-state))
64 "Reset the achor point on extract state ST."
65 (oset st anchor (point)))
66
67(defmethod srecode-extract-state-extract ((st srecode-extract-state)
68 endpoint)
69 "Perform an extraction on the extract state ST with ENDPOITNT.
70If there was no waiting inserter, do nothing."
71 (when (oref st lastinserter)
72 (save-match-data
73 (srecode-inserter-extract (oref st lastinserter)
74 (oref st anchor)
75 endpoint
76 (oref st lastdict)
77 st))
78 ;; Clear state.
79 (srecode-extract-state-set st nil nil)))
80
81;;; Extraction
82;l
83(defun srecode-extract (template start end)
84 "Extract TEMPLATE from between START and END in the current buffer.
85Uses TEMPLATE's constant strings to break up the text and guess what
86the dictionary entries were for that block of text."
87 (save-excursion
88 (save-restriction
89 (narrow-to-region start end)
90 (let ((dict (srecode-create-dictionary t))
91 (state (srecode-extract-state "state"))
92 )
93 (goto-char start)
94 (srecode-extract-method template dict state)
95 dict))))
96
97(defmethod srecode-extract-method ((st srecode-template) dictionary
98 state)
99 "Extract template ST and store extracted text in DICTIONARY.
100Optional STARTRETURN is a symbol in which the start of the first
101plain-text match occured."
102 (srecode-extract-code-stream (oref st code) dictionary state))
103
104(defun srecode-extract-code-stream (code dictionary state)
105 "Extract CODE from buffer text into DICTIONARY.
106Uses string constants in CODE to split up the buffer.
107Uses STATE to maintain the current extraction state."
108 (while code
109 (cond
110
111 ;; constant strings need mark the end of old inserters that
112 ;; need to extract values, or are just there.
113 ((stringp (car code))
114 (srecode-extract-state-set-anchor state)
115 ;; When we have a string, find it in the collection, then extract
116 ;; that start point as the end point of the inserter
117 (unless (re-search-forward (regexp-quote (car code))
118 (point-max) t)
119 (error "Unable to extract all dictionary entries"))
120
121 (srecode-extract-state-extract state (match-beginning 0))
122 (goto-char (match-end 0))
123 )
124
125 ;; Some inserters are simple, and need to be extracted after
126 ;; we find our next block of static text.
127 ((eq (srecode-inserter-do-extract-p (car code)) 'later)
128 (srecode-extract-state-set state (car code) dictionary)
129 )
130
131 ;; Some inserter want to start extraction now, such as sections.
132 ;; We can't predict the end point till we parse out the middle.
133 ((eq (srecode-inserter-do-extract-p (car code)) 'now)
134 (srecode-extract-state-set-anchor state)
135 (srecode-inserter-extract (car code) (point) nil dictionary state))
136 )
137 (setq code (cdr code))
138 ))
139
140;;; Inserter Base Extractors
141;;
142(defmethod srecode-inserter-do-extract-p ((ins srecode-template-inserter))
143 "Return non-nil if this inserter can extract values."
144 nil)
145
146(defmethod srecode-inserter-extract ((ins srecode-template-inserter)
147 start end dict state)
148 "Extract text from START/END and store in DICT.
149Return nil as this inserter will extract nothing."
150 nil)
151
152;;; Variable extractor is simple and can extract later.
153;;
154(defmethod srecode-inserter-do-extract-p ((ins srecode-template-inserter-variable))
155 "Return non-nil if this inserter can extract values."
156 'later)
157
158(defmethod srecode-inserter-extract ((ins srecode-template-inserter-variable)
159 start end vdict state)
160 "Extract text from START/END and store in VDICT.
161Return t if something was extracted.
162Return nil if this inserter doesn't need to extract anything."
163 (srecode-dictionary-set-value vdict
164 (oref ins :object-name)
165 (buffer-substring-no-properties
166 start end)
167 )
168 t)
169
170;;; Section Inserter
171;;
172(defmethod srecode-inserter-do-extract-p ((ins srecode-template-inserter-section-start))
173 "Return non-nil if this inserter can extract values."
174 'now)
175
176(defmethod srecode-inserter-extract ((ins srecode-template-inserter-section-start)
177 start end indict state)
178 "Extract text from START/END and store in INDICT.
179Return the starting location of the first plain-text match.
180Return nil if nothing was extracted."
181 (let ((name (oref ins :object-name))
182 (subdict (srecode-create-dictionary indict))
183 (allsubdict nil)
184 )
185
186 ;; Keep extracting till we can extract no more.
187 (while (condition-case nil
188 (progn
189 (srecode-extract-method
190 (oref ins template) subdict state)
191 t)
192 (error nil))
193
194 ;; Success means keep this subdict, and also make a new one for
195 ;; the next iteration.
196 (setq allsubdict (cons subdict allsubdict))
197 (setq subdict (srecode-create-dictionary indict))
198 )
199
200 (srecode-dictionary-set-value indict name (nreverse allsubdict))
201
202 nil))
203
204;;; Include Extractor must extract now.
205;;
206(defmethod srecode-inserter-do-extract-p ((ins srecode-template-inserter-include))
207 "Return non-nil if this inserter can extract values."
208 'now)
209
210(defmethod srecode-inserter-extract ((ins srecode-template-inserter-include)
211 start end dict state)
212 "Extract text from START/END and store in DICT.
213Return the starting location of the first plain-text match.
214Return nil if nothing was extracted."
215 (goto-char start)
216 (srecode-insert-include-lookup ins dict)
217 ;; There are two modes for includes. One is with no dict,
218 ;; so it is inserted straight. If the dict has a name, then
219 ;; we need to run once per dictionary occurance.
220 (if (not (string= (oref ins :object-name) ""))
221 ;; With a name, do the insertion.
222 (let ((subdict (srecode-dictionary-add-section-dictionary
223 dict (oref ins :object-name))))
224 (error "Need to implement include w/ name extractor.")
225 ;; Recurse into the new template while no errors.
226 (while (condition-case nil
227 (progn
228 (srecode-extract-method
229 (oref ins includedtemplate) subdict
230 state)
231 t)
232 (error nil))))
233
234 ;; No stream, do the extraction into the current dictionary.
235 (srecode-extract-method (oref ins includedtemplate) dict
236 state))
237 )
238
239
240(provide 'srecode/extract)
241
242;;; srecode/extract.el ends here
diff --git a/lisp/cedet/srecode/fields.el b/lisp/cedet/srecode/fields.el
new file mode 100644
index 00000000000..f335b0fef79
--- /dev/null
+++ b/lisp/cedet/srecode/fields.el
@@ -0,0 +1,438 @@
1;;; srecode/fields.el --- Handling type-in fields in a buffer.
2;;
3;; Copyright (C) 2009 Free Software Foundation, Inc.
4;;
5;; Author: Eric M. Ludlam <eric@siege-engine.com>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;
24;; Idea courtesy of yasnippets.
25;;
26;; If someone prefers not to type unknown dictionary entries into
27;; mini-buffer prompts, it could instead use in-buffer fields.
28;;
29;; A template-region specifies an area in which the fields exist. If
30;; the cursor exits the region, all fields are cleared.
31;;
32;; Each field is independent, but some are linked together by name.
33;; Typing in one will cause the matching ones to change in step.
34;;
35;; Each field has 2 overlays. The second overlay allows control in
36;; the character just after the field, but does not highlight it.
37
38;; Keep this library independent of SRecode proper.
39(require 'eieio)
40
41;;; Code:
42(defvar srecode-field-archive nil
43 "While inserting a set of fields, collect in this variable.
44Once an insertion set is done, these fields will be activated.")
45
46(defface srecode-field-face
47 '((((class color) (background dark))
48 (:underline "green"))
49 (((class color) (background light))
50 (:underline "green4")))
51 "*Face used to specify editable fields from a template."
52 :group 'semantic-faces)
53
54;;; BASECLASS
55;;
56;; Fields and the template region share some basic overlay features.
57
58(defclass srecode-overlaid ()
59 ((overlay :documentation
60 "Overlay representing this field.
61The overlay will crossreference this object.")
62 )
63 "An object that gets automatically bound to an overlay.
64Has virtual :start and :end initializers.")
65
66(defmethod initialize-instance ((olaid srecode-overlaid) &optional args)
67 "Initialize OLAID, being sure it archived."
68 ;; Extract :start and :end from the olaid list.
69 (let ((newargs nil)
70 (olay nil)
71 start end
72 )
73
74 (while args
75 (cond ((eq (car args) :start)
76 (setq args (cdr args))
77 (setq start (car args))
78 (setq args (cdr args))
79 )
80 ((eq (car args) :end)
81 (setq args (cdr args))
82 (setq end (car args))
83 (setq args (cdr args))
84 )
85 (t
86 (push (car args) newargs)
87 (setq args (cdr args))
88 (push (car args) newargs)
89 (setq args (cdr args)))
90 ))
91
92 ;; Create a temporary overlay now. We have to use an overlay and
93 ;; not a marker becaues of the in-front insertion rules. The rules
94 ;; are backward from what is wanted while typing.
95 (setq olay (make-overlay start end (current-buffer) t nil))
96 (overlay-put olay 'srecode-init-only t)
97
98 (oset olaid overlay olay)
99 (call-next-method olaid (nreverse newargs))
100
101 ))
102
103(defmethod srecode-overlaid-activate ((olaid srecode-overlaid))
104 "Activate the overlaid area."
105 (let* ((ola (oref olaid overlay))
106 (start (overlay-start ola))
107 (end (overlay-end ola))
108 ;; Create a new overlay here.
109 (ol (make-overlay start end (current-buffer) nil t)))
110
111 ;; Remove the old one.
112 (delete-overlay ola)
113
114 (overlay-put ol 'srecode olaid)
115
116 (oset olaid overlay ol)
117
118 ))
119
120(defmethod srecode-delete ((olaid srecode-overlaid))
121 "Delete the overlay from OLAID."
122 (delete-overlay (oref olaid overlay))
123 (slot-makeunbound olaid 'overlay)
124 )
125
126(defmethod srecode-empty-region-p ((olaid srecode-overlaid))
127 "Return non-nil if the region covered by OLAID is of length 0."
128 (= 0 (srecode-region-size olaid)))
129
130(defmethod srecode-region-size ((olaid srecode-overlaid))
131 "Return the length of region covered by OLAID."
132 (let ((start (overlay-start (oref olaid overlay)))
133 (end (overlay-end (oref olaid overlay))))
134 (- end start)))
135
136(defmethod srecode-point-in-region-p ((olaid srecode-overlaid))
137 "Return non-nil if point is in the region of OLAID."
138 (let ((start (overlay-start (oref olaid overlay)))
139 (end (overlay-end (oref olaid overlay))))
140 (and (>= (point) start) (<= (point) end))))
141
142(defun srecode-overlaid-at-point (class)
143 "Return a list of overlaid fields of type CLASS at point."
144 (let ((ol (overlays-at (point)))
145 (ret nil))
146 (while ol
147 (let ((tmp (overlay-get (car ol) 'srecode)))
148 (when (and tmp (object-of-class-p tmp class))
149 (setq ret (cons tmp ret))))
150 (setq ol (cdr ol)))
151 (car (nreverse ret))))
152
153(defmethod srecode-overlaid-text ((olaid srecode-overlaid) &optional set-to)
154 "Return the text under OLAID.
155If SET-TO is a string, then replace the text of OLAID wit SET-TO."
156 (let* ((ol (oref olaid overlay))
157 (start (overlay-start ol)))
158 (if (not (stringp set-to))
159 ;; Just return it.
160 (buffer-substring-no-properties start (overlay-end ol))
161 ;; Replace it.
162 (save-excursion
163 (delete-region start (overlay-end ol))
164 (goto-char start)
165 (insert set-to)
166 (move-overlay ol start (+ start (length set-to))))
167 nil)))
168
169;;; INSERTED REGION
170;;
171;; Managing point-exit, and flushing fields.
172
173(defclass srecode-template-inserted-region (srecode-overlaid)
174 ((fields :documentation
175 "A list of field overlays in this region.")
176 (active-region :allocation :class
177 :initform nil
178 :documentation
179 "The template region currently being handled.")
180 )
181 "Manage a buffer region in which fields exist.")
182
183(defmethod initialize-instance ((ir srecode-template-inserted-region)
184 &rest args)
185 "Initialize IR, capturing the active fields, and creating the overlay."
186 ;; Fill in the fields
187 (oset ir fields srecode-field-archive)
188 (setq srecode-field-archive nil)
189
190 ;; Initailize myself first.
191 (call-next-method)
192 )
193
194(defmethod srecode-overlaid-activate ((ir srecode-template-inserted-region))
195 "Activate the template area for IR."
196 ;; Activate all our fields
197
198 (dolist (F (oref ir fields))
199 (srecode-overlaid-activate F))
200
201 ;; Activate our overlay.
202 (call-next-method)
203
204 ;; Position the cursor at the first field
205 (let ((first (car (oref ir fields))))
206 (goto-char (overlay-start (oref first overlay))))
207
208 ;; Set ourselves up as 'active'
209 (oset ir active-region ir)
210
211 ;; Setup the post command hook.
212 (add-hook 'post-command-hook 'srecode-field-post-command t t)
213 )
214
215(defmethod srecode-delete ((ir srecode-template-inserted-region))
216 "Call into our base, but also clear out the fields."
217 ;; Clear us out of the baseclass.
218 (oset ir active-region nil)
219 ;; Clear our fields.
220 (mapc 'srecode-delete (oref ir fields))
221 ;; Call to our base
222 (call-next-method)
223 ;; Clear our hook.
224 (remove-hook 'post-command-hook 'srecode-field-post-command t)
225 )
226
227(defsubst srecode-active-template-region ()
228 "Return the active region for template fields."
229 (oref srecode-template-inserted-region active-region))
230
231(defun srecode-field-post-command ()
232 "Srecode field handler in the post command hook."
233 (let ((ar (srecode-active-template-region))
234 )
235 (if (not ar)
236 ;; Find a bug and fix it.
237 (remove-hook 'post-command-hook 'srecode-field-post-command t)
238 (if (srecode-point-in-region-p ar)
239 nil ;; Keep going
240 ;; We moved out of the temlate. Cancel the edits.
241 (srecode-delete ar)))
242 ))
243
244;;; FIELDS
245
246(defclass srecode-field (srecode-overlaid)
247 ((tail :documentation
248 "Overlay used on character just after this field.
249Used to provide useful keybindings there.")
250 (name :initarg :name
251 :documentation
252 "The name of this field.
253Usually initialized from the dictionary entry name that
254the users needs to edit.")
255 (prompt :initarg :prompt
256 :documentation
257 "A prompt string to use if this were in the minibuffer.
258Display when the cursor enters this field.")
259 (read-fcn :initarg :read-fcn
260 :documentation
261 "A function that would be used to read a string.
262Try to use this to provide useful completion when available.")
263 )
264 "Representation of one field.")
265
266(defvar srecode-field-keymap
267 (let ((km (make-sparse-keymap)))
268 (define-key km "\C-i" 'srecode-field-next)
269 (define-key km "\M-\C-i" 'srecode-field-prev)
270 (define-key km "\C-e" 'srecode-field-end)
271 (define-key km "\C-a" 'srecode-field-start)
272 (define-key km "\M-m" 'srecode-field-start)
273 (define-key km "\C-c\C-c" 'srecode-field-exit-ask)
274 km)
275 "Keymap applied to field overlays.")
276
277(defmethod initialize-instance ((field srecode-field) &optional args)
278 "Initialize FIELD, being sure it archived."
279 (add-to-list 'srecode-field-archive field t)
280 (call-next-method)
281 )
282
283(defmethod srecode-overlaid-activate ((field srecode-field))
284 "Activate the FIELD area."
285 (call-next-method)
286
287 (let* ((ol (oref field overlay))
288 (end nil)
289 (tail nil))
290 (overlay-put ol 'face 'srecode-field-face)
291 (overlay-put ol 'keymap srecode-field-keymap)
292 (overlay-put ol 'modification-hooks '(srecode-field-mod-hook))
293 (overlay-put ol 'insert-behind-hooks '(srecode-field-behind-hook))
294 (overlay-put ol 'insert-in-front-hooks '(srecode-field-mod-hook))
295
296 (setq end (overlay-end ol))
297 (setq tail (make-overlay end (+ end 1) (current-buffer)))
298
299 (overlay-put tail 'srecode field)
300 (overlay-put tail 'keymap srecode-field-keymap)
301 (overlay-put tail 'face 'srecode-field-face)
302 (oset field tail tail)
303 )
304 )
305
306(defmethod srecode-delete ((olaid srecode-field))
307 "Delete our secondary overlay."
308 ;; Remove our spare overlay
309 (delete-overlay (oref olaid tail))
310 (slot-makeunbound olaid 'tail)
311 ;; Do our baseclass work.
312 (call-next-method)
313 )
314
315(defvar srecode-field-replication-max-size 100
316 "Maximum size of a field before cancelling replication.")
317
318(defun srecode-field-mod-hook (ol after start end &optional pre-len)
319 "Modification hook for the field overlay.
320OL is the overlay.
321AFTER is non-nil if it is called after the change.
322START and END are the bounds of the change.
323PRE-LEN is used in the after mode for the length of the changed text."
324 (when (and after (not undo-in-progress))
325 (let* ((field (overlay-get ol 'srecode))
326 (inhibit-point-motion-hooks t)
327 (inhibit-modification-hooks t)
328 )
329 ;; Sometimes a field is deleted, but we might still get a stray
330 ;; event. Lets just ignore those events.
331 (when (slot-boundp field 'overlay)
332 ;; First, fixup the two overlays, in case they got confused.
333 (let ((main (oref field overlay))
334 (tail (oref field tail)))
335 (move-overlay main
336 (overlay-start main)
337 (1- (overlay-end tail)))
338 (move-overlay tail
339 (1- (overlay-end tail))
340 (overlay-end tail)))
341 ;; Now capture text from the main overlay, and propagate it.
342 (let* ((new-text (srecode-overlaid-text field))
343 (region (srecode-active-template-region))
344 (allfields (when region (oref region fields)))
345 (name (oref field name)))
346 (dolist (F allfields)
347 (when (and (not (eq F field))
348 (string= name (oref F name)))
349 (if (> (length new-text) srecode-field-replication-max-size)
350 (message "Field size too large for replication.")
351 ;; If we find other fields with the same name, then keep
352 ;; then all together. Disable change hooks to make sure
353 ;; we don't get a recursive edit.
354 (srecode-overlaid-text F new-text)
355 ))))
356 ))))
357
358(defun srecode-field-behind-hook (ol after start end &optional pre-len)
359 "Modification hook for the field overlay.
360OL is the overlay.
361AFTER is non-nil if it is called after the change.
362START and END are the bounds of the change.
363PRE-LEN is used in the after mode for the length of the changed text."
364 (when after
365 (let* ((field (overlay-get ol 'srecode))
366 )
367 (move-overlay ol (overlay-start ol) end)
368 (srecode-field-mod-hook ol after start end pre-len))
369 ))
370
371(defmethod srecode-field-goto ((field srecode-field))
372 "Goto the FIELD."
373 (goto-char (overlay-start (oref field overlay))))
374
375(defun srecode-field-next ()
376 "Move to the next field."
377 (interactive)
378 (let* ((f (srecode-overlaid-at-point 'srecode-field))
379 (tr (srecode-overlaid-at-point 'srecode-template-inserted-region))
380 )
381 (when (not f) (error "Not in a field"))
382 (when (not tr) (error "Not in a template region"))
383
384 (let ((fields (oref tr fields)))
385 (while fields
386 ;; Loop over fields till we match. Then move to the next one.
387 (when (eq f (car fields))
388 (if (cdr fields)
389 (srecode-field-goto (car (cdr fields)))
390 (srecode-field-goto (car (oref tr fields))))
391 (setq fields nil)
392 )
393 (setq fields (cdr fields))))
394 ))
395
396(defun srecode-field-prev ()
397 "Move to the prev field."
398 (interactive)
399 (let* ((f (srecode-overlaid-at-point 'srecode-field))
400 (tr (srecode-overlaid-at-point 'srecode-template-inserted-region))
401 )
402 (when (not f) (error "Not in a field"))
403 (when (not tr) (error "Not in a template region"))
404
405 (let ((fields (reverse (oref tr fields))))
406 (while fields
407 ;; Loop over fields till we match. Then move to the next one.
408 (when (eq f (car fields))
409 (if (cdr fields)
410 (srecode-field-goto (car (cdr fields)))
411 (srecode-field-goto (car (oref tr fields))))
412 (setq fields nil)
413 )
414 (setq fields (cdr fields))))
415 ))
416
417(defun srecode-field-end ()
418 "Move to the end of this field."
419 (interactive)
420 (let* ((f (srecode-overlaid-at-point 'srecode-field)))
421 (goto-char (overlay-end (oref f overlay)))))
422
423(defun srecode-field-start ()
424 "Move to the end of this field."
425 (interactive)
426 (let* ((f (srecode-overlaid-at-point 'srecode-field)))
427 (goto-char (overlay-start (oref f overlay)))))
428
429(defun srecode-field-exit-ask ()
430 "Ask if the user wants to exit field-editing mini-mode."
431 (interactive)
432 (when (y-or-n-p "Exit field-editing mode? ")
433 (srecode-delete (srecode-active-template-region))))
434
435
436(provide 'srecode/fields)
437
438;;; srecode/fields.el ends here
diff --git a/lisp/cedet/srecode/filters.el b/lisp/cedet/srecode/filters.el
new file mode 100644
index 00000000000..1e3582f46fb
--- /dev/null
+++ b/lisp/cedet/srecode/filters.el
@@ -0,0 +1,56 @@
1;;; srecode/filters.el --- Filters for use in template variables.
2
3;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <eric@siege-engine.com>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;
24;; Various useful srecoder template functions.
25
26;;; Code:
27
28(require 'newcomment)
29(require 'srecode/table)
30(require 'srecode/insert)
31
32(defun srecode-comment-prefix (str)
33 "Prefix each line of STR with the comment prefix characters."
34 (let* ((dict srecode-inserter-variable-current-dictionary)
35 ;; Derive the comment characters to put in front of each line.
36 (cs (or (and dict
37 (srecode-dictionary-lookup-name dict "comment_prefix"))
38 (and comment-multi-line comment-continue)
39 (and (not comment-multi-line) comment-start)))
40 (strs (split-string str "\n"))
41 (newstr "")
42 )
43 (while strs
44 (cond ((and (not comment-multi-line) (string= (car strs) ""))
45 ; (setq newstr (concat newstr "\n")))
46 )
47 (t
48 (setq newstr (concat newstr cs " " (car strs)))))
49 (setq strs (cdr strs))
50 (when strs (setq newstr (concat newstr "\n"))))
51 newstr))
52
53(provide 'srecode/filters)
54
55;;; srecode/filters.el ends here
56
diff --git a/lisp/cedet/srecode/find.el b/lisp/cedet/srecode/find.el
new file mode 100644
index 00000000000..aecba0a2ec3
--- /dev/null
+++ b/lisp/cedet/srecode/find.el
@@ -0,0 +1,261 @@
1;;;; srecode/find.el --- Tools for finding templates in the database.
2
3;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <eric@siege-engine.com>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;
24;; Various routines that search through various template tables
25;; in search of the right template.
26
27(require 'srecode/ctxt)
28(require 'srecode/table)
29(require 'srecode/map)
30
31(declare-function srecode-compile-file "srecode/compile")
32
33;;; Code:
34
35(defun srecode-table (&optional mode)
36 "Return the currently active Semantic Recoder table for this buffer.
37Optional argument MODE specifies the mode table to use."
38 (let* ((modeq (or mode major-mode))
39 (table (srecode-get-mode-table modeq)))
40
41 ;; If there isn't one, keep searching backwards for a table.
42 (while (and (not table) (setq modeq (get-mode-local-parent modeq)))
43 (setq table (srecode-get-mode-table modeq)))
44
45 ;; Last ditch effort.
46 (when (not table)
47 (setq table (srecode-get-mode-table 'default)))
48
49 table))
50
51;;; TRACKER
52;;
53;; Template file tracker for between sessions.
54;;
55(defun srecode-load-tables-for-mode (mmode &optional appname)
56 "Load all the template files for MMODE.
57Templates are found in the SRecode Template Map.
58See `srecode-get-maps' for more.
59APPNAME is the name of an application. In this case,
60all template files for that application will be loaded."
61 (require 'srecode/compile)
62 (let ((files
63 (if appname
64 (apply 'append
65 (mapcar
66 (lambda (map)
67 (srecode-map-entries-for-app-and-mode map appname mmode))
68 (srecode-get-maps)))
69 (apply 'append
70 (mapcar
71 (lambda (map)
72 (srecode-map-entries-for-mode map mmode))
73 (srecode-get-maps)))))
74 )
75 ;; Don't recurse if we are already the 'default state.
76 (when (not (eq mmode 'default))
77 ;; Are we a derived mode? If so, get the parent mode's
78 ;; templates loaded too.
79 (if (get-mode-local-parent mmode)
80 (srecode-load-tables-for-mode (get-mode-local-parent mmode)
81 appname)
82 ;; No parent mode, all templates depend on the defaults being
83 ;; loaded in, so get that in instead.
84 (srecode-load-tables-for-mode 'default appname)))
85
86 ;; Load in templates for our major mode.
87 (dolist (f files)
88 (let ((mt (srecode-get-mode-table mmode))
89 )
90 (when (or (not mt) (not (srecode-mode-table-find mt (car f))))
91 (srecode-compile-file (car f)))
92 ))
93 ))
94
95;;; SEARCH
96;;
97;; Find a given template based on name, and features of the current
98;; buffer.
99(defmethod srecode-template-get-table ((tab srecode-template-table)
100 template-name &optional
101 context application)
102 "Find in the template in table TAB, the template with TEMPLATE-NAME.
103Optional argument CONTEXT specifies that the template should part
104of a particular context.
105The APPLICATION argument is unused."
106 (if context
107 ;; If a context is specified, then look it up there.
108 (let ((ctxth (gethash context (oref tab contexthash))))
109 (when ctxth
110 (gethash template-name ctxth)))
111 ;; No context, perhaps a merged name?
112 (gethash template-name (oref tab namehash))))
113
114(defmethod srecode-template-get-table ((tab srecode-mode-table)
115 template-name &optional
116 context application)
117 "Find in the template in mode table TAB, the template with TEMPLATE-NAME.
118Optional argument CONTEXT specifies a context a particular template
119would belong to.
120Optional argument APPLICATION restricts searches to only template tables
121belonging to a specific application. If APPLICATION is nil, then only
122tables that do not belong to an application will be searched."
123 (let* ((mt tab)
124 (tabs (oref mt :tables))
125 (ans nil))
126 (while (and (not ans) tabs)
127 (let ((app (oref (car tabs) :application)))
128 (when (or (and (not application) (null app))
129 (and application (eq app application)))
130 (setq ans (srecode-template-get-table (car tabs) template-name
131 context)))
132 (setq tabs (cdr tabs))))
133 (or ans
134 ;; Recurse to the default.
135 (when (not (equal (oref tab :major-mode) 'default))
136 (srecode-template-get-table (srecode-get-mode-table 'default)
137 template-name context application)))))
138
139;;
140;; Find a given template based on a key binding.
141;;
142(defmethod srecode-template-get-table-for-binding
143 ((tab srecode-template-table) binding &optional context)
144 "Find in the template name in table TAB, the template with BINDING.
145Optional argument CONTEXT specifies that the template should part
146of a particular context."
147 (let* ((keyout nil)
148 (hashfcn (lambda (key value)
149 (when (and (slot-boundp value 'binding)
150 (oref value binding)
151 (= (aref (oref value binding) 0) binding))
152 (setq keyout key))))
153 (contextstr (cond ((listp context)
154 (car-safe context))
155 ((stringp context)
156 context)
157 (t nil)))
158 )
159 (if context
160 (let ((ctxth (gethash contextstr (oref tab contexthash))))
161 (when ctxth
162 ;; If a context is specified, then look it up there.
163 (maphash hashfcn ctxth)
164 ;; Context hashes EXCLUDE the context prefix which
165 ;; we need to include, so concat it here
166 (when keyout
167 (setq keyout (concat contextstr ":" keyout)))
168 )))
169 (when (not keyout)
170 ;; No context, or binding in context. Try full hash.
171 (maphash hashfcn (oref tab namehash)))
172 keyout))
173
174(defmethod srecode-template-get-table-for-binding
175 ((tab srecode-mode-table) binding &optional context application)
176 "Find in the template name in mode table TAB, the template with BINDING.
177Optional argument CONTEXT specifies a context a particular template
178would belong to.
179Optional argument APPLICATION restricts searches to only template tables
180belonging to a specific application. If APPLICATION is nil, then only
181tables that do not belong to an application will be searched."
182 (let* ((mt tab)
183 (tabs (oref mt :tables))
184 (ans nil))
185 (while (and (not ans) tabs)
186 (let ((app (oref (car tabs) :application)))
187 (when (or (and (not application) (null app))
188 (and application (eq app application)))
189 (setq ans (srecode-template-get-table-for-binding
190 (car tabs) binding context)))
191 (setq tabs (cdr tabs))))
192 (or ans
193 ;; Recurse to the default.
194 (when (not (equal (oref tab :major-mode) 'default))
195 (srecode-template-get-table-for-binding
196 (srecode-get-mode-table 'default) binding context)))))
197;;; Interactive
198;;
199;; Interactive queries into the template data.
200;;
201(defvar srecode-read-template-name-history nil
202 "History for completing reads for template names.")
203
204(defun srecode-all-template-hash (&optional mode hash)
205 "Create a hash table of all the currently available templates.
206Optional argument MODE is the major mode to look for.
207Optional argument HASH is the hash table to fill in."
208 (let* ((mhash (or hash (make-hash-table :test 'equal)))
209 (mmode (or mode major-mode))
210 (mp (get-mode-local-parent mmode))
211 )
212 ;; Get the parent hash table filled into our current hash.
213 (when (not (eq mode 'default))
214 (if mp
215 (srecode-all-template-hash mp mhash)
216 (srecode-all-template-hash 'default mhash)))
217 ;; Load up the hash table for our current mode.
218 (let* ((mt (srecode-get-mode-table mmode))
219 (tabs (when mt (oref mt :tables)))
220 )
221 (while tabs
222 ;; Exclude templates for a perticular application.
223 (when (not (oref (car tabs) :application))
224 (maphash (lambda (key temp)
225 (puthash key temp mhash)
226 )
227 (oref (car tabs) namehash)))
228 (setq tabs (cdr tabs)))
229 mhash)))
230
231(defun srecode-calculate-default-template-string (hash)
232 "Calculate the name of the template to use as a DEFAULT.
233Templates are read from HASH.
234Context into which the template is inserted is calculated
235with `srecode-calculate-context'."
236 (let* ((ctxt (srecode-calculate-context))
237 (ans (concat (nth 0 ctxt) ":" (nth 1 ctxt))))
238 (if (gethash ans hash)
239 ans
240 ;; No hash at the specifics, at least offer
241 ;; the prefix for the completing read
242 (concat (nth 0 ctxt) ":"))))
243
244(defun srecode-read-template-name (prompt &optional initial hist default)
245 "Completing read for Semantic Recoder template names.
246PROMPT is used to query for the name of the template desired.
247INITIAL is the initial string to use.
248HIST is a history variable to use.
249DEFAULT is what to use if the user presses RET."
250 (srecode-load-tables-for-mode major-mode)
251 (let* ((hash (srecode-all-template-hash))
252 (def (or initial
253 (srecode-calculate-default-template-string hash))))
254 (completing-read prompt hash
255 nil t def
256 (or hist
257 'srecode-read-template-name-history))))
258
259(provide 'srecode/find)
260
261;;; srecode/find.el ends here
diff --git a/lisp/cedet/srecode/getset.el b/lisp/cedet/srecode/getset.el
new file mode 100644
index 00000000000..b9ff6af2003
--- /dev/null
+++ b/lisp/cedet/srecode/getset.el
@@ -0,0 +1,366 @@
1;;; srecode/getset.el --- Package for inserting new get/set methods.
2
3;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <eric@siege-engine.com>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;
24;; SRecoder application for inserting new get/set methods into a class.
25
26(require 'semantic)
27(require 'semantic/analyze)
28(require 'semantic/find)
29(require 'srecode/insert)
30(require 'srecode/dictionary)
31
32;;; Code:
33(defvar srecode-insert-getset-fully-automatic-flag nil
34 "Non-nil means accept choices srecode comes up with without asking.")
35
36;;;###autoload
37(defun srecode-insert-getset (&optional class-in field-in)
38 "Insert get/set methods for the current class.
39CLASS-IN is the semantic tag of the class to update.
40FIELD-IN is the semantic tag, or string name, of the field to add.
41If you do not specify CLASS-IN or FIELD-IN then a class and field
42will be derived."
43 (interactive)
44
45 (srecode-load-tables-for-mode major-mode)
46 (srecode-load-tables-for-mode major-mode 'getset)
47
48 (if (not (srecode-table))
49 (error "No template table found for mode %s" major-mode))
50
51 (if (not (srecode-template-get-table (srecode-table)
52 "getset-in-class"
53 "declaration"
54 'getset))
55 (error "No templates for inserting get/set"))
56
57 ;; Step 1: Try to derive the tag for the class we will use
58 (let* ((class (or class-in (srecode-auto-choose-class (point))))
59 (tagstart (semantic-tag-start class))
60 (inclass (eq (semantic-current-tag-of-class 'type) class))
61 (field nil)
62 )
63
64 (when (not class)
65 (error "Move point to a class and try again"))
66
67 ;; Step 2: Select a name for the field we will use.
68 (when field-in
69 (setq field field-in))
70
71 (when (and inclass (not field))
72 (setq field (srecode-auto-choose-field (point))))
73
74 (when (not field)
75 (setq field (srecode-query-for-field class)))
76
77 ;; Step 3: Insert a new field if needed
78 (when (stringp field)
79
80 (goto-char (point))
81 (srecode-position-new-field class inclass)
82
83 (let* ((dict (srecode-create-dictionary))
84 (temp (srecode-template-get-table (srecode-table)
85 "getset-field"
86 "declaration"
87 'getset))
88 )
89 (when (not temp)
90 (error "Getset templates for %s not loaded!" major-mode))
91 (srecode-resolve-arguments temp dict)
92 (srecode-dictionary-set-value dict "NAME" field)
93 (when srecode-insert-getset-fully-automatic-flag
94 (srecode-dictionary-set-value dict "TYPE" "int"))
95 (srecode-insert-fcn temp dict)
96
97 (semantic-fetch-tags)
98 (save-excursion
99 (goto-char tagstart)
100 ;; Refresh our class tag.
101 (setq class (srecode-auto-choose-class (point)))
102 )
103
104 (let ((tmptag (semantic-deep-find-tags-by-name-regexp
105 field (current-buffer))))
106 (setq tmptag (semantic-find-tags-by-class 'variable tmptag))
107
108 (if tmptag
109 (setq field (car tmptag))
110 (error "Could not find new field %s" field)))
111 )
112
113 ;; Step 3.5: Insert an initializer if needed.
114 ;; ...
115
116
117 ;; Set up for the rest.
118 )
119
120 (if (not (semantic-tag-p field))
121 (error "Must specify field for get/set. (parts may not be impl'd yet.)"))
122
123 ;; Set 4: Position for insertion of methods
124 (srecode-position-new-methods class field)
125
126 ;; Step 5: Insert the get/set methods
127 (if (not (eq (semantic-current-tag) class))
128 ;; We are positioned on top of something else.
129 ;; insert a /n
130 (insert "\n"))
131
132 (let* ((dict (srecode-create-dictionary))
133 (srecode-semantic-selected-tag field)
134 (temp (srecode-template-get-table (srecode-table)
135 "getset-in-class"
136 "declaration"
137 'getset))
138 )
139 (if (not temp)
140 (error "Getset templates for %s not loaded!" major-mode))
141 (srecode-resolve-arguments temp dict)
142 (srecode-dictionary-set-value dict "GROUPNAME"
143 (concat (semantic-tag-name field)
144 " Accessors"))
145 (srecode-dictionary-set-value dict "NICENAME"
146 (srecode-strip-fieldname
147 (semantic-tag-name field)))
148 (srecode-insert-fcn temp dict)
149 )))
150
151(defun srecode-strip-fieldname (name)
152 "Strip the fieldname NAME of polish notation things."
153 (cond ((string-match "[a-z]\\([A-Z]\\w+\\)" name)
154 (substring name (match-beginning 1)))
155 ;; Add more rules here.
156 (t
157 name)))
158
159(defun srecode-position-new-methods (class field)
160 "Position the cursor in CLASS where new getset methods should go.
161FIELD is the field for the get sets.
162INCLASS specifies if the cursor is already in CLASS or not."
163 (semantic-go-to-tag field)
164
165 (let ((prev (semantic-find-tag-by-overlay-prev))
166 (next (semantic-find-tag-by-overlay-next))
167 (setname nil)
168 (aftertag nil)
169 )
170 (cond
171 ((and prev (semantic-tag-of-class-p prev 'variable))
172 (setq setname
173 (concat "set"
174 (srecode-strip-fieldname (semantic-tag-name prev))))
175 )
176 ((and next (semantic-tag-of-class-p next 'variable))
177 (setq setname
178 (concat "set"
179 (srecode-strip-fieldname (semantic-tag-name prev)))))
180 (t nil))
181
182 (setq aftertag (semantic-find-first-tag-by-name
183 setname (semantic-tag-type-members class)))
184
185 (when (not aftertag)
186 (setq aftertag (car-safe
187 (semantic--find-tags-by-macro
188 (semantic-tag-get-attribute (car tags) :destructor-flag)
189 (semantic-tag-type-members class))))
190 ;; Make sure the tag is public
191 (when (not (eq (semantic-tag-protection aftertag class) 'public))
192 (setq aftertag nil))
193 )
194
195 (if (not aftertag)
196 (setq aftertag (car-safe
197 (semantic--find-tags-by-macro
198 (semantic-tag-get-attribute (car tags) :constructor-flag)
199 (semantic-tag-type-members class))))
200 ;; Make sure the tag is public
201 (when (not (eq (semantic-tag-protection aftertag class) 'public))
202 (setq aftertag nil))
203 )
204
205 (when (not aftertag)
206 (setq aftertag (semantic-find-first-tag-by-name
207 "public" (semantic-tag-type-members class))))
208
209 (when (not aftertag)
210 (setq aftertag (car (semantic-tag-type-members class))))
211
212 (if aftertag
213 (let ((te (semantic-tag-end aftertag)))
214 (when (not te)
215 (message "Unknown location for tag-end in %s:" (semantic-tag-name aftertag)))
216 (goto-char te)
217 ;; If there is a comment immediatly after aftertag, skip over it.
218 (when (looking-at (concat "\\s-*\n?\\s-*" semantic-lex-comment-regex))
219 (let ((pos (point))
220 (rnext (semantic-find-tag-by-overlay-next (point))))
221 (forward-comment 1)
222 ;; Make sure the comment we skipped didn't say anything about
223 ;; the rnext tag.
224 (when (and rnext
225 (re-search-backward
226 (regexp-quote (semantic-tag-name rnext)) pos t))
227 ;; It did mention rnext, so go back to our starting position.
228 (goto-char pos)
229 )
230 ))
231 )
232
233 ;; At the very beginning of the class.
234 (goto-char (semantic-tag-end class))
235 (forward-sexp -1)
236 (forward-char 1)
237
238 )
239
240 (end-of-line)
241 (forward-char 1)
242 ))
243
244(defun srecode-position-new-field (class inclass)
245 "Select a position for a new field for CLASS.
246If INCLASS is non-nil, then the cursor is already in the class
247and should not be moved during point selection."
248
249 ;; If we aren't in the class, get the cursor there, pronto!
250 (when (not inclass)
251
252 (error "You must position the cursor where to insert the new field")
253
254 (let ((kids (semantic-find-tags-by-class
255 'variable (semantic-tag-type-members class))))
256 (cond (kids
257 (semantic-go-to-tag (car kids) class))
258 (t
259 (semantic-go-to-tag class)))
260 )
261
262 (switch-to-buffer (current-buffer))
263
264 ;; Once the cursor is in our class, ask the user to position
265 ;; the cursor to keep going.
266 )
267
268 (if (or srecode-insert-getset-fully-automatic-flag
269 (y-or-n-p "Insert new field here? "))
270 nil
271 (error "You must position the cursor where to insert the new field first"))
272 )
273
274
275
276(defun srecode-auto-choose-field (point)
277 "Choose a field for the get/set methods.
278Base selection on the field related to POINT."
279 (save-excursion
280 (when point
281 (goto-char point))
282
283 (let ((field (semantic-current-tag-of-class 'variable)))
284
285 ;; If we get a field, make sure the user gets a chance to choose.
286 (when field
287 (if srecode-insert-getset-fully-automatic-flag
288 nil
289 (when (not (y-or-n-p
290 (format "Use field %s? " (semantic-tag-name field))))
291 (setq field nil))
292 ))
293 field)))
294
295(defun srecode-query-for-field (class)
296 "Query for a field in CLASS."
297 (let* ((kids (semantic-find-tags-by-class
298 'variable (semantic-tag-type-members class)))
299 (sel (completing-read "Use Field: " kids))
300 )
301
302 (or (semantic-find-tags-by-name sel kids)
303 sel)
304 ))
305
306(defun srecode-auto-choose-class (point)
307 "Choose a class based on locatin of POINT."
308 (save-excursion
309 (when point
310 (goto-char point))
311
312 (let ((tag (semantic-current-tag-of-class 'type)))
313
314 (when (or (not tag)
315 (not (string= (semantic-tag-type tag) "class")))
316 ;; The current tag is not a class. Are we in a fcn
317 ;; that is a method?
318 (setq tag (semantic-current-tag-of-class 'function))
319
320 (when (and tag
321 (semantic-tag-function-parent tag))
322 (let ((p (semantic-tag-function-parent tag)))
323 ;; @TODO : Copied below out of semantic-analyze
324 ;; Turn into a routine.
325
326 (let* ((searchname (cond ((stringp p) p)
327 ((semantic-tag-p p)
328 (semantic-tag-name p))
329 ((and (listp p) (stringp (car p)))
330 (car p))))
331 (ptag (semantic-analyze-find-tag searchname
332 'type nil)))
333 (when ptag (setq tag ptag ))
334 ))))
335
336 (when (or (not tag)
337 (not (semantic-tag-of-class-p tag 'type))
338 (not (string= (semantic-tag-type tag) "class")))
339 ;; We are not in a class that needs a get/set method.
340 ;; Analyze the current context, and derive a class name.
341 (let* ((ctxt (semantic-analyze-current-context))
342 (pfix nil)
343 (ans nil))
344 (when ctxt
345 (setq pfix (reverse (oref ctxt prefix)))
346 (while (and (not ans) pfix)
347 ;; Start at the end and back up to the first class.
348 (when (and (semantic-tag-p (car pfix))
349 (semantic-tag-of-class-p (car pfix) 'type)
350 (string= (semantic-tag-type (car pfix))
351 "class"))
352 (setq ans (car pfix)))
353 (setq pfix (cdr pfix))))
354 (setq tag ans)))
355
356 tag)))
357
358(provide 'srecode/getset)
359
360;; Local variables:
361;; generated-autoload-file: "loaddefs.el"
362;; generated-autoload-feature: srecode/loaddefs
363;; generated-autoload-load-name: "srecode/getset"
364;; End:
365
366;;; srecode/getset.el ends here
diff --git a/lisp/cedet/srecode/insert.el b/lisp/cedet/srecode/insert.el
new file mode 100644
index 00000000000..743c8e8e652
--- /dev/null
+++ b/lisp/cedet/srecode/insert.el
@@ -0,0 +1,983 @@
1;;; srecode/insert --- Insert srecode templates to an output stream.
2
3;;; Copyright (C) 2005, 2007, 2008, 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <zappo@gnu.org>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;
24;; Define and implements specific inserter objects.
25;;
26;; Manage the insertion process for a template.
27;;
28
29(require 'srecode/compile)
30(require 'srecode/find)
31(require 'srecode/dictionary)
32
33(defvar srecode-template-inserter-point)
34(declare-function srecode-overlaid-activate "srecode/fields")
35(declare-function srecode-template-inserted-region "srecode/fields")
36
37;;; Code:
38
39(defcustom srecode-insert-ask-variable-method 'ask
40 "Determine how to ask for a dictionary value when inserting a template.
41Only the ASK style inserter will query the user for a value.
42Dictionary value references that ask begin with the ? character.
43Possible values are:
44 'ask - Prompt in the minibuffer as the value is inserted.
45 'field - Use the dictionary macro name as the inserted value,
46 and place a field there. Matched fields change together.
47
48NOTE: The field feature does not yet work with XEmacs."
49 :group 'srecode
50 :type '(choice (const :tag "Ask" ask)
51 (cons :tag "Field" field)))
52
53(defvar srecode-insert-with-fields-in-progress nil
54 "Non-nil means that we are actively inserting a template with fields.")
55
56;;; INSERTION COMMANDS
57;;
58;; User level commands for inserting stuff.
59(defvar srecode-insertion-start-context nil
60 "The context that was at point at the beginning of the template insertion.")
61
62(defun srecode-insert-again ()
63 "Insert the previously inserted template (by name) again."
64 (interactive)
65 (let ((prev (car srecode-read-template-name-history)))
66 (if prev
67 (srecode-insert prev)
68 (call-interactively 'srecode-insert))))
69
70;;;###autoload
71(defun srecode-insert (template-name &rest dict-entries)
72 "Inesrt the template TEMPLATE-NAME into the current buffer at point.
73DICT-ENTRIES are additional dictionary values to add."
74 (interactive (list (srecode-read-template-name "Template Name: ")))
75 (if (not (srecode-table))
76 (error "No template table found for mode %s" major-mode))
77 (let ((newdict (srecode-create-dictionary))
78 (temp (srecode-template-get-table (srecode-table) template-name))
79 (srecode-insertion-start-context (srecode-calculate-context))
80 )
81 (if (not temp)
82 (error "No Template named %s" template-name))
83 (while dict-entries
84 (srecode-dictionary-set-value newdict
85 (car dict-entries)
86 (car (cdr dict-entries)))
87 (setq dict-entries (cdr (cdr dict-entries))))
88 ;;(srecode-resolve-arguments temp newdict)
89 (srecode-insert-fcn temp newdict)
90 ;; Don't put code here. We need to return the end-mark
91 ;; for this insertion step.
92 ))
93
94(defun srecode-insert-fcn (template dictionary &optional stream skipresolver)
95 "Insert TEMPLATE using DICTIONARY into STREAM.
96Optional SKIPRESOLVER means to avoid refreshing the tag list,
97or resolving any template arguments. It is assumed the caller
98has set everything up already."
99 ;; Perform the insertion.
100 (let ((standard-output (or stream (current-buffer)))
101 (end-mark nil))
102 (unless skipresolver
103 ;; Make sure the semantic tags are up to date.
104 (semantic-fetch-tags)
105 ;; Resolve the arguments
106 (srecode-resolve-arguments template dictionary))
107 ;; Insert
108 (if (bufferp standard-output)
109 ;; If there is a buffer, turn off various hooks. This will cause
110 ;; the mod hooks to be buffered up during the insert, but
111 ;; prevent tools like font-lock from fontifying mid-template.
112 ;; Especialy important during insertion of complex comments that
113 ;; cause the new font-lock to comment-color stuff after the inserted
114 ;; comment.
115 ;;
116 ;; I'm not sure about the motion hooks. It seems like a good
117 ;; idea though.
118 ;;
119 ;; Borrowed these concepts out of font-lock.
120 ;;
121 ;; I tried `combine-after-change-calls', but it did not have
122 ;; the effect I wanted.
123 (let ((start (point)))
124 (let ((inhibit-point-motion-hooks t)
125 (inhibit-modification-hooks t)
126 )
127 (srecode--insert-into-buffer template dictionary)
128 )
129 ;; Now call those after change functions.
130 (run-hook-with-args 'after-change-functions
131 start (point) 0)
132 )
133 (srecode-insert-method template dictionary))
134 ;; Handle specialization of the POINT inserter.
135 (when (and (bufferp standard-output)
136 (slot-boundp 'srecode-template-inserter-point 'point)
137 )
138 (set-buffer standard-output)
139 (setq end-mark (point-marker))
140 (goto-char (oref srecode-template-inserter-point point)))
141 (oset-default 'srecode-template-inserter-point point eieio-unbound)
142
143 ;; Return the end-mark.
144 (or end-mark (point)))
145 )
146
147(defun srecode--insert-into-buffer (template dictionary)
148 "Insert a TEMPLATE with DICTIONARY into a buffer.
149Do not call this function yourself. Instead use:
150 `srecode-insert' - Inserts by name.
151 `srecode-insert-fcn' - Insert with objects.
152This function handles the case from one of the above functions when
153the template is inserted into a buffer. It looks
154at `srecode-insert-ask-variable-method' to decide if unbound dictionary
155entries ask questions or insert editable fields.
156
157Buffer based features related to change hooks is handled one level up."
158 ;; This line prevents the field archive from being let bound
159 ;; while the field insert tool is loaded via autoloads during
160 ;; the insert.
161 (when (eq srecode-insert-ask-variable-method 'field)
162 (require 'srecode-fields))
163
164 (let ((srecode-field-archive nil) ; Prevent field leaks during insert
165 (start (point)) ; Beginning of the region.
166 )
167 ;; This sub-let scopes the 'in-progress' piece so we know
168 ;; when to setup the end-template.
169 (let ((srecode-insert-with-fields-in-progress
170 (if (eq srecode-insert-ask-variable-method 'field) t nil))
171 )
172 (srecode-insert-method template dictionary)
173 )
174 ;; If we are not in-progress, and we insert fields, then
175 ;; create the end-template with fields editable area.
176 (when (and (not srecode-insert-with-fields-in-progress)
177 (eq srecode-insert-ask-variable-method 'field) ; Only if user asked
178 srecode-field-archive ; Only if there were fields created
179 )
180 (let ((reg
181 ;; Create the field-driven editable area.
182 (srecode-template-inserted-region
183 "TEMPLATE" :start start :end (point))))
184 (srecode-overlaid-activate reg))
185 )
186 ;; We return with 'point being the end of the template insertion
187 ;; area. Return value is not important.
188 ))
189
190;;; TEMPLATE ARGUMENTS
191;;
192;; Some templates have arguments. Each argument is assocaited with
193;; a function that can resolve the inputs needed.
194(defun srecode-resolve-arguments (temp dict)
195 "Resolve all the arguments needed by the template TEMP.
196Apply anything learned to the dictionary DICT."
197 (srecode-resolve-argument-list (oref temp args) dict temp))
198
199(defun srecode-resolve-argument-list (args dict &optional temp)
200 "Resolve arguments in the argument list ARGS.
201ARGS is a list of symbols, such as :blank, or :file.
202Apply values to DICT.
203Optional argument TEMP is the template that is getting it's arguments resolved."
204 (let ((fcn nil))
205 (while args
206 (setq fcn (intern-soft (concat "srecode-semantic-handle-"
207 (symbol-name (car args)))))
208 (if (not fcn)
209 (error "Error resolving template argument %S" (car args)))
210 (if temp
211 (condition-case nil
212 ;; Allow some to accept a 2nd argument optionally.
213 ;; They throw an error if not available, so try again.
214 (funcall fcn dict temp)
215 (wrong-number-of-arguments (funcall fcn dict)))
216 (funcall fcn dict))
217 (setq args (cdr args)))
218 ))
219
220;;; INSERTION STACK & METHOD
221;;
222;; Code managing the top-level insert method and the current
223;; insertion stack.
224;;
225(defmethod srecode-push ((st srecode-template))
226 "Push the srecoder template ST onto the active stack."
227 (oset st active (cons st (oref st active))))
228
229(defmethod srecode-pop :STATIC ((st srecode-template))
230 "Pop the srecoder template ST onto the active stack.
231ST can be a class, or an object."
232 (oset st active (cdr (oref st active))))
233
234(defmethod srecode-peek :STATIC ((st srecode-template))
235 "Fetch the topmost active template record. ST can be a class."
236 (car (oref st active)))
237
238(defmethod srecode-insert-method ((st srecode-template) dictionary)
239 "Insert the srecoder template ST."
240 ;; Merge any template entries into the input dictionary.
241 (when (slot-boundp st 'dictionary)
242 (srecode-dictionary-merge dictionary (oref st dictionary)))
243 ;; Do an insertion.
244 (unwind-protect
245 (let ((c (oref st code)))
246 (srecode-push st)
247 (srecode-insert-code-stream c dictionary))
248 ;; Poping the stack is protected
249 (srecode-pop st)))
250
251(defun srecode-insert-code-stream (code dictionary)
252 "Insert the CODE from a template into `standard-output'.
253Use DICTIONARY to resolve any macros."
254 (while code
255 (cond ((stringp (car code))
256 (princ (car code)))
257 (t
258 (srecode-insert-method (car code) dictionary)))
259 (setq code (cdr code))))
260
261;;; INSERTERS
262;;
263;; Specific srecode inserters.
264;; The base class is from srecode-compile.
265;;
266;; Each inserter handles various macro codes from the temlate.
267;; The `code' slot specifies a character used to identify which
268;; inserter is to be created.
269;;
270(defclass srecode-template-inserter-newline (srecode-template-inserter)
271 ((key :initform "\n"
272 :allocation :class
273 :documentation
274 "The character code used to identify inserters of this style.")
275 (hard :initform nil
276 :initarg :hard
277 :documentation
278 "Is this a hard newline (always inserted) or optional?
279Optional newlines don't insert themselves if they are on a blank line
280by themselves.")
281 )
282 "Insert a newline, and possibly do indenting.
283Specify the :indent argument to enable automatic indentation when newlines
284occur in your template.")
285
286(defmethod srecode-insert-method ((sti srecode-template-inserter-newline)
287 dictionary)
288 "Insert the STI inserter."
289 ;; To be safe, indent the previous line since the template will
290 ;; change what is there to indent
291 (let ((i (srecode-dictionary-lookup-name dictionary "INDENT"))
292 (inbuff (bufferp standard-output))
293 (doit t)
294 (pm (point-marker)))
295 (when (and inbuff (not (oref sti hard)))
296 ;; If this is not a hard newline, we need do the calculation
297 ;; and set "doit" to nil.
298 (beginning-of-line)
299 (save-restriction
300 (narrow-to-region (point) pm)
301 (when (looking-at "\\s-*$")
302 (setq doit nil)))
303 (goto-char pm)
304 )
305 ;; Do indentation reguardless of the newline.
306 (when (and (eq i t) inbuff)
307 (indent-according-to-mode)
308 (goto-char pm))
309
310 (when doit
311 (princ "\n")
312 ;; Indent after the newline, particularly for numeric indents.
313 (cond ((and (eq i t) (bufferp standard-output))
314 ;; WARNING - indent according to mode requires that standard-output
315 ;; is a buffer!
316 ;; @todo - how to indent in a string???
317 (setq pm (point-marker))
318 (indent-according-to-mode)
319 (goto-char pm))
320 ((numberp i)
321 (princ (make-string i " ")))
322 ((stringp i)
323 (princ i))))))
324
325(defmethod srecode-dump ((ins srecode-template-inserter-newline) indent)
326 "Dump the state of the SRecode template inserter INS."
327 (call-next-method)
328 (when (oref ins hard)
329 (princ " : hard")
330 ))
331
332(defclass srecode-template-inserter-blank (srecode-template-inserter)
333 ((key :initform "\r"
334 :allocation :class
335 :documentation
336 "The character represeinting this inserter style.
337Can't be blank, or it might be used by regular variable insertion.")
338 (where :initform 'begin
339 :initarg :where
340 :documentation
341 "This should be 'begin or 'end, indicating where to insrt a CR.
342When set to 'begin, it will insert a CR if we are not at 'bol'.
343When set to 'end it will insert a CR if we are not at 'eol'")
344 ;; @TODO - Add slot and control for the number of blank
345 ;; lines before and after point.
346 )
347 "Insert a newline before and after a template, and possibly do indenting.
348Specify the :blank argument to enable this inserter.")
349
350(defmethod srecode-insert-method ((sti srecode-template-inserter-blank)
351 dictionary)
352 "Make sure there is no text before or after point."
353 (let ((i (srecode-dictionary-lookup-name dictionary "INDENT"))
354 (inbuff (bufferp standard-output))
355 (pm (point-marker)))
356 (when (and inbuff
357 ;; Don't do this if we are not the active template.
358 (= (length (oref srecode-template active)) 1))
359
360 (when (and (eq i t) inbuff (not (eq (oref sti where) 'begin)))
361 (indent-according-to-mode)
362 (goto-char pm))
363
364 (cond ((and (eq (oref sti where) 'begin) (not (bolp)))
365 (princ "\n"))
366 ((eq (oref sti where) 'end)
367 ;; If there is whitespace after pnt, then clear it out.
368 (when (looking-at "\\s-*$")
369 (delete-region (point) (point-at-eol)))
370 (when (not (eolp))
371 (princ "\n")))
372 )
373 (setq pm (point-marker))
374 (when (and (eq i t) inbuff (not (eq (oref sti where) 'end)))
375 (indent-according-to-mode)
376 (goto-char pm))
377 )))
378
379(defclass srecode-template-inserter-comment (srecode-template-inserter)
380 ((key :initform ?!
381 :allocation :class
382 :documentation
383 "The character code used to identify inserters of this style.")
384 )
385 "Allow comments within template coding. This inserts nothing.")
386
387(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-comment)
388 escape-start escape-end)
389 "Insert an example using inserter INS.
390Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
391 (princ " ")
392 (princ escape-start)
393 (princ "! Miscellaneous text commenting in your template. ")
394 (princ escape-end)
395 (terpri)
396 )
397
398(defmethod srecode-insert-method ((sti srecode-template-inserter-comment)
399 dictionary)
400 "Don't insert anything for comment macros in STI."
401 nil)
402
403
404(defclass srecode-template-inserter-variable (srecode-template-inserter)
405 ((key :initform nil
406 :allocation :class
407 :documentation
408 "The character code used to identify inserters of this style."))
409 "Insert the value of a dictionary entry
410If there is no entry, insert nothing.")
411
412(defvar srecode-inserter-variable-current-dictionary nil
413 "The active dictionary when calling a variable filter.")
414
415(defmethod srecode-insert-variable-secondname-handler
416 ((sti srecode-template-inserter-variable) dictionary value secondname)
417 "For VALUE handle SECONDNAME behaviors for this variable inserter.
418Return the result as a string.
419By default, treat as a function name.
420If SECONDNAME is nil, return VALUE."
421 (if secondname
422 (let ((fcnpart (read secondname)))
423 (if (fboundp fcnpart)
424 (let ((srecode-inserter-variable-current-dictionary dictionary))
425 (funcall fcnpart value))
426 ;; Else, warn.
427 (error "Variable insertion second arg %s is not a function."
428 secondname)))
429 value))
430
431(defmethod srecode-insert-method ((sti srecode-template-inserter-variable)
432 dictionary)
433 "Insert the STI inserter."
434 ;; Convert the name into a name/fcn pair
435 (let* ((name (oref sti :object-name))
436 (fcnpart (oref sti :secondname))
437 (val (srecode-dictionary-lookup-name
438 dictionary name))
439 (do-princ t)
440 )
441 ;; Alert if a macro wasn't found.
442 (when (not val)
443 (message "Warning: macro %S was not found in the dictionary." name)
444 (setq val ""))
445 ;; If there was a functional part, call that function.
446 (cond ;; Strings
447 ((stringp val)
448 (setq val (srecode-insert-variable-secondname-handler
449 sti dictionary val fcnpart)))
450 ;; Compound data value
451 ((srecode-dictionary-compound-value-child-p val)
452 ;; Force FCN to be a symbol
453 (when fcnpart (setq fcnpart (read fcnpart)))
454 ;; Convert compound value to a string with the fcn.
455 (setq val (srecode-compound-toString val fcnpart dictionary))
456 ;; If the value returned is nil, then it may be a special
457 ;; field inserter that requires us to set do-princ to nil.
458 (when (not val)
459 (setq do-princ nil)
460 )
461 )
462 ;; Dictionaries... not allowed in this style
463 ((srecode-dictionary-child-p val)
464 (error "Macro %s cannot insert a dictionary. Use section macros instead."
465 name))
466 ;; Other stuff... convert
467 (t
468 (error "Macro %s cannot insert arbitrary data." name)
469 ;;(if (and val (not (stringp val)))
470 ;; (setq val (format "%S" val))))
471 ))
472 ;; Output the dumb thing unless the type of thing specifically
473 ;; did the inserting forus.
474 (when do-princ
475 (princ val))))
476
477(defclass srecode-template-inserter-ask (srecode-template-inserter-variable)
478 ((key :initform ??
479 :allocation :class
480 :documentation
481 "The character code used to identify inserters of this style.")
482 (prompt :initarg :prompt
483 :initform nil
484 :documentation
485 "The prompt used to query for this dictionary value.")
486 (defaultfcn :initarg :defaultfcn
487 :initform nil
488 :documentation
489 "The function which can calculate a default value.")
490 (read-fcn :initarg :read-fcn
491 :initform 'read-string
492 :documentation
493 "The function used to read in the text for this prompt.")
494 )
495 "Insert the value of a dictionary entry
496If there is no entry, prompt the user for the value to use.
497The prompt text used is derived from the previous PROMPT command in the
498template file.")
499
500(defmethod srecode-inserter-apply-state ((ins srecode-template-inserter-ask) STATE)
501 "For the template inserter INS, apply information from STATE.
502Loop over the prompts to see if we have a match."
503 (let ((prompts (oref STATE prompts))
504 )
505 (while prompts
506 (when (string= (semantic-tag-name (car prompts))
507 (oref ins :object-name))
508 (oset ins :prompt
509 (semantic-tag-get-attribute (car prompts) :text))
510 (oset ins :defaultfcn
511 (semantic-tag-get-attribute (car prompts) :default))
512 (oset ins :read-fcn
513 (or (semantic-tag-get-attribute (car prompts) :read)
514 'read-string))
515 )
516 (setq prompts (cdr prompts)))
517 ))
518
519(defmethod srecode-insert-method ((sti srecode-template-inserter-ask)
520 dictionary)
521 "Insert the STI inserter."
522 (let ((val (srecode-dictionary-lookup-name
523 dictionary (oref sti :object-name))))
524 (if val
525 ;; Does some extra work. Oh well.
526 (call-next-method)
527
528 ;; How is our -ask value determined?
529 (if srecode-insert-with-fields-in-progress
530 ;; Setup editable fields.
531 (setq val (srecode-insert-method-field sti dictionary))
532 ;; Ask the question...
533 (setq val (srecode-insert-method-ask sti dictionary)))
534
535 ;; After asking, save in the dictionary so that
536 ;; the user can use the same name again later.
537 (srecode-dictionary-set-value
538 (srecode-root-dictionary dictionary)
539 (oref sti :object-name) val)
540
541 ;; Now that this value is safely stowed in the dictionary,
542 ;; we can do what regular inserters do.
543 (call-next-method))))
544
545(defmethod srecode-insert-ask-default ((sti srecode-template-inserter-ask)
546 dictionary)
547 "Derive the default value for an askable inserter STI.
548DICTIONARY is used to derive some values."
549 (let ((defaultfcn (oref sti :defaultfcn)))
550 (cond ((stringp defaultfcn)
551 defaultfcn)
552 ((functionp defaultfcn)
553 (funcall defaultfcn))
554 ((and (listp defaultfcn)
555 (eq (car defaultfcn) 'macro))
556 (srecode-dictionary-lookup-name
557 dictionary (cdr defaultfcn)))
558 ((null defaultfcn)
559 "")
560 (t
561 (error "Unknown default for prompt: %S"
562 defaultfcn)))))
563
564(defmethod srecode-insert-method-ask ((sti srecode-template-inserter-ask)
565 dictionary)
566 "Do the \"asking\" for the template inserter STI.
567Use DICTIONARY to resolve values."
568 (let* ((prompt (oref sti prompt))
569 (default (srecode-insert-ask-default sti dictionary))
570 (reader (oref sti :read-fcn))
571 (val nil)
572 )
573 (cond ((eq reader 'y-or-n-p)
574 (if (y-or-n-p (or prompt
575 (format "%s? "
576 (oref sti :object-name))))
577 (setq val default)
578 (setq val "")))
579 ((eq reader 'read-char)
580 (setq val (format
581 "%c"
582 (read-char (or prompt
583 (format "Char for %s: "
584 (oref sti :object-name))))))
585 )
586 (t
587 (save-excursion
588 (setq val (funcall reader
589 (or prompt
590 (format "Specify %s: "
591 (oref sti :object-name)))
592 default
593 )))))
594 ;; Return our derived value.
595 val)
596 )
597
598(defmethod srecode-insert-method-field ((sti srecode-template-inserter-ask)
599 dictionary)
600 "Create an editable field for the template inserter STI.
601Use DICTIONARY to resolve values."
602 (let* ((default (srecode-insert-ask-default sti dictionary))
603 (compound-value
604 (srecode-field-value (oref sti :object-name)
605 :firstinserter sti
606 :defaultvalue default))
607 )
608 ;; Return this special compound value as the thing to insert.
609 ;; This special compound value will repeat our asked question
610 ;; across multiple locations.
611 compound-value))
612
613(defmethod srecode-dump ((ins srecode-template-inserter-ask) indent)
614 "Dump the state of the SRecode template inserter INS."
615 (call-next-method)
616 (princ " : \"")
617 (princ (oref ins prompt))
618 (princ "\"")
619 )
620
621(defclass srecode-template-inserter-width (srecode-template-inserter-variable)
622 ((key :initform ?|
623 :allocation :class
624 :documentation
625 "The character code used to identify inserters of this style.")
626 )
627 "Inserts the value of a dictionary variable with a specific width.
628The second argument specifies the width, and a pad, seperated by a colon.
629thus a specification of `10:left' will insert the value of A
630to 10 characters, with spaces added to the left. Use `right' for adding
631spaces to the right.")
632
633(defmethod srecode-insert-variable-secondname-handler
634 ((sti srecode-template-inserter-width) dictionary value width)
635 "For VALUE handle WIDTH behaviors for this variable inserter.
636Return the result as a string.
637By default, treat as a function name."
638 (if width
639 ;; Trim or pad to new length
640 (let* ((split (split-string width ":"))
641 (width (string-to-number (nth 0 split)))
642 (second (nth 1 split))
643 (pad (cond ((or (null second) (string= "right" second))
644 'right)
645 ((string= "left" second)
646 'left)
647 (t
648 (error "Unknown pad type %s" second)))))
649 (if (>= (length value) width)
650 ;; Simple case - too long.
651 (substring value 0 width)
652 ;; We need to pad on one side or the other.
653 (let ((padchars (make-string (- width (length value)) ? )))
654 (if (eq pad 'left)
655 (concat padchars value)
656 (concat value padchars)))))
657 (error "Width not specified for variable/width inserter.")))
658
659(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-width)
660 escape-start escape-end)
661 "Insert an example using inserter INS.
662Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
663 (princ " ")
664 (princ escape-start)
665 (princ "|A:10:right")
666 (princ escape-end)
667 (terpri)
668 )
669
670(defvar srecode-template-inserter-point-override nil
671 "When non-nil, the point inserter will do this functin instead.")
672
673(defclass srecode-template-inserter-point (srecode-template-inserter)
674 ((key :initform ?^
675 :allocation :class
676 :documentation
677 "The character code used to identify inserters of this style.")
678 (point :type (or null marker)
679 :allocation :class
680 :documentation
681 "Record the value of (point) in this class slot.
682It is the responsibility of the inserter algorithm to clear this
683after a successful insertion."))
684 "Record the value of (point) when inserted.
685The cursor is placed at the ^ macro after insertion.
686Some inserter macros, such as `srecode-template-inserter-include-wrap'
687will place text at the ^ macro from the included macro.")
688
689(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-point)
690 escape-start escape-end)
691 "Insert an example using inserter INS.
692Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
693 (princ " ")
694 (princ escape-start)
695 (princ "^")
696 (princ escape-end)
697 (terpri)
698 )
699
700(defmethod srecode-insert-method ((sti srecode-template-inserter-point)
701 dictionary)
702 "Insert the STI inserter.
703Save point in the class allocated 'point' slot.
704If `srecode-template-inserter-point-override' then this generalized
705marker will do something else. See `srecode-template-inserter-include-wrap'
706as an example."
707 (if srecode-template-inserter-point-override
708 ;; Disable the old override while we do this.
709 (let ((over srecode-template-inserter-point-override)
710 (srecode-template-inserter-point-override nil))
711 (funcall over dictionary)
712 )
713 (oset sti point (point-marker))
714 ))
715
716(defclass srecode-template-inserter-subtemplate (srecode-template-inserter)
717 ()
718 "Wrap a section of a template under the control of a macro."
719 :abstract t)
720
721(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-subtemplate)
722 escape-start escape-end)
723 "Insert an example using inserter INS.
724Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
725 (call-next-method)
726 (princ " Template Text to control")
727 (terpri)
728 (princ " ")
729 (princ escape-start)
730 (princ "/VARNAME")
731 (princ escape-end)
732 (terpri)
733 )
734
735(defmethod srecode-insert-subtemplate ((sti srecode-template-inserter-subtemplate)
736 dict slot)
737 "Insert a subtemplate for the inserter STI with dictionary DICT."
738 ;; make sure that only dictionaries are used.
739 (when (not (srecode-dictionary-child-p dict))
740 (error "Only section dictionaries allowed for %s"
741 (object-name-string sti)))
742 ;; Output the code from the sub-template.
743 (srecode-insert-method (slot-value sti slot) dict)
744 )
745
746(defmethod srecode-insert-method-helper ((sti srecode-template-inserter-subtemplate)
747 dictionary slot)
748 "Do the work for inserting the STI inserter.
749Loops over the embedded CODE which was saved here during compilation.
750The template to insert is stored in SLOT."
751 (let ((dicts (srecode-dictionary-lookup-name
752 dictionary (oref sti :object-name))))
753 ;; If there is no section dictionary, then don't output anything
754 ;; from this section.
755 (while dicts
756 (srecode-insert-subtemplate sti (car dicts) slot)
757 (setq dicts (cdr dicts)))))
758
759(defmethod srecode-insert-method ((sti srecode-template-inserter-subtemplate)
760 dictionary)
761 "Insert the STI inserter.
762Calls back to `srecode-insert-method-helper' for this class."
763 (srecode-insert-method-helper sti dictionary 'template))
764
765
766(defclass srecode-template-inserter-section-start (srecode-template-inserter-subtemplate)
767 ((key :initform ?#
768 :allocation :class
769 :documentation
770 "The character code used to identify inserters of this style.")
771 (template :initarg :template
772 :documentation
773 "A Template used to frame the codes from this inserter.")
774 )
775 "Apply values from a sub-dictionary to a template section.
776The dictionary saved at the named dictionary entry will be
777applied to the text between the section start and the
778`srecode-template-inserter-section-end' macro.")
779
780(defmethod srecode-parse-input ((ins srecode-template-inserter-section-start)
781 tag input STATE)
782 "For the section inserter INS, parse INPUT.
783Shorten input until the END token is found.
784Return the remains of INPUT."
785 (let* ((out (srecode-compile-split-code tag input STATE
786 (oref ins :object-name))))
787 (oset ins template (srecode-template
788 (object-name-string ins)
789 :context nil
790 :args nil
791 :code (cdr out)))
792 (car out)))
793
794(defmethod srecode-dump ((ins srecode-template-inserter-section-start) indent)
795 "Dump the state of the SRecode template inserter INS."
796 (call-next-method)
797 (princ "\n")
798 (srecode-dump-code-list (oref (oref ins template) code)
799 (concat indent " "))
800 )
801
802(defclass srecode-template-inserter-section-end (srecode-template-inserter)
803 ((key :initform ?/
804 :allocation :class
805 :documentation
806 "The character code used to identify inserters of this style.")
807 )
808 "All template segments between the secion-start and section-end
809are treated specially.")
810
811(defmethod srecode-insert-method ((sti srecode-template-inserter-section-end)
812 dictionary)
813 "Insert the STI inserter."
814 )
815
816(defmethod srecode-match-end ((ins srecode-template-inserter-section-end) name)
817
818 "For the template inserter INS, do I end a section called NAME?"
819 (string= name (oref ins :object-name)))
820
821(defclass srecode-template-inserter-include (srecode-template-inserter-subtemplate)
822 ((key :initform ?>
823 :allocation :class
824 :documentation
825 "The character code used to identify inserters of this style.")
826 (includedtemplate
827 :initarg :includedtemplate
828 :documentation
829 "The template included for this inserter."))
830 "Include a different template into this one.
831The included template will have additional dictionary entries from the subdictionary
832stored specified by this macro.")
833
834(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-include)
835 escape-start escape-end)
836 "Insert an example using inserter INS.
837Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
838 (princ " ")
839 (princ escape-start)
840 (princ ">DICTNAME:contextname:templatename")
841 (princ escape-end)
842 (terpri)
843 )
844
845(defmethod srecode-insert-include-lookup ((sti srecode-template-inserter-include)
846 dictionary)
847 "For the template inserter STI, lookup the template to include.
848Finds the template with this macro function part and stores it in
849this template instance."
850 (let* ((templatenamepart (oref sti :secondname))
851 )
852 ;; If there was no template name, throw an error
853 (if (not templatenamepart)
854 (error "Include macro %s needs a template name." (oref sti :object-name)))
855 ;; Find the template by name, and save it.
856 (if (or (not (slot-boundp sti 'includedtemplate))
857 (not (oref sti includedtemplate)))
858 (let ((tmpl (srecode-template-get-table (srecode-table)
859 templatenamepart))
860 (active (oref srecode-template active))
861 ctxt)
862 (when (not tmpl)
863 ;; If it isn't just available, scan back through
864 ;; the active template stack, searching for a matching
865 ;; context.
866 (while (and (not tmpl) active)
867 (setq ctxt (oref (car active) context))
868 (setq tmpl (srecode-template-get-table (srecode-table)
869 templatenamepart
870 ctxt))
871 (when (not tmpl)
872 (when (slot-boundp (car active) 'table)
873 (let ((app (oref (oref (car active) table) application)))
874 (when app
875 (setq tmpl (srecode-template-get-table
876 (srecode-table)
877 templatenamepart
878 ctxt app)))
879 )))
880 (setq active (cdr active)))
881 (when (not tmpl)
882 ;; If it wasn't in this context, look to see if it
883 ;; defines it's own context
884 (setq tmpl (srecode-template-get-table (srecode-table)
885 templatenamepart)))
886 )
887 (oset sti :includedtemplate tmpl)))
888
889 (if (not (oref sti includedtemplate))
890 ;; @todo - Call into a debugger to help find the template in question.
891 (error "No template \"%s\" found for include macro `%s'"
892 templatenamepart (oref sti :object-name)))
893 ))
894
895(defmethod srecode-insert-method ((sti srecode-template-inserter-include)
896 dictionary)
897 "Insert the STI inserter.
898Finds the template with this macro function part, and inserts it
899with the dictionaries found in the dictinary."
900 (srecode-insert-include-lookup sti dictionary)
901 ;; Insert the template.
902 ;; Our baseclass has a simple way to do this.
903 (if (srecode-dictionary-lookup-name dictionary (oref sti :object-name))
904 ;; If we have a value, then call the next method
905 (srecode-insert-method-helper sti dictionary 'includedtemplate)
906 ;; If we don't have a special dictitonary, then just insert with the
907 ;; current dictionary.
908 (srecode-insert-subtemplate sti dictionary 'includedtemplate))
909 )
910
911;;
912;; This template combines the include template and the sectional template.
913;; It will first insert the included template, then insert the embedded
914;; template wherever the $^$ in the included template was.
915;;
916;; Since it uses dual inheretance, it will magically get the end-matching
917;; behavior of #, with the including feature of >.
918;;
919(defclass srecode-template-inserter-include-wrap (srecode-template-inserter-include srecode-template-inserter-section-start)
920 ((key :initform ?<
921 :allocation :class
922 :documentation
923 "The character code used to identify inserters of this style.")
924 )
925 "Include a different template into this one, and add text at the ^ macro.
926The included template will have additional dictionary entries from the subdictionary
927stored specified by this macro. If the included macro includes a ^ macro,
928then the text between this macro and the end macro will be inserted at
929the ^ macro.")
930
931(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-include-wrap)
932 escape-start escape-end)
933 "Insert an example using inserter INS.
934Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
935 (princ " ")
936 (princ escape-start)
937 (princ "<DICTNAME:contextname:templatename")
938 (princ escape-end)
939 (terpri)
940 (princ " Template Text to insert at ^ macro")
941 (terpri)
942 (princ " ")
943 (princ escape-start)
944 (princ "/DICTNAME")
945 (princ escape-end)
946 (terpri)
947 )
948
949(defmethod srecode-insert-method ((sti srecode-template-inserter-include-wrap)
950 dictionary)
951 "Insert the template STI.
952This will first insert the include part via inheritance, then
953insert the section it wraps into the location in the included
954template where a ^ inserter occurs."
955 ;; Step 1: Look up the included inserter
956 (srecode-insert-include-lookup sti dictionary)
957 ;; Step 2: Temporarilly override the point inserter.
958 (let* ((vaguely-unique-name sti)
959 (srecode-template-inserter-point-override
960 (lambda (dict2)
961 (if (srecode-dictionary-lookup-name
962 dict2 (oref vaguely-unique-name :object-name))
963 ;; Insert our sectional part with looping.
964 (srecode-insert-method-helper
965 vaguely-unique-name dict2 'template)
966 ;; Insert our sectional part just once.
967 (srecode-insert-subtemplate vaguely-unique-name
968 dict2 'template))
969 )))
970 ;; Do a regular insertion for an include, but with our override in
971 ;; place.
972 (call-next-method)
973 ))
974
975(provide 'srecode/insert)
976
977;; Local variables:
978;; generated-autoload-file: "loaddefs.el"
979;; generated-autoload-feature: srecode/loaddefs
980;; generated-autoload-load-name: "srecode/insert"
981;; End:
982
983;;; srecode/insert.el ends here
diff --git a/lisp/cedet/srecode/java.el b/lisp/cedet/srecode/java.el
new file mode 100644
index 00000000000..325cf215ee8
--- /dev/null
+++ b/lisp/cedet/srecode/java.el
@@ -0,0 +1,62 @@
1;;; srecode-java.el --- Srecode Java support
2
3;; Copyright (C) 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <eric@siege-engine.com>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;
24;; Special support for the Java language.
25
26;;; Code:
27
28(require 'srecode/dictionary)
29
30;;;###autoload
31(defun srecode-semantic-handle-:java (dict)
32 "Add macros into the dictionary DICT based on the current java file.
33Adds the following:
34FILENAME_AS_PACKAGE - file/dir converted into a java package name.
35FILENAME_AS_CLASS - file converted to a Java class name."
36 ;; A symbol representing
37 (let* ((fsym (file-name-nondirectory (buffer-file-name)))
38 (fnox (file-name-sans-extension fsym))
39 (dir (file-name-directory (buffer-file-name)))
40 (fpak fsym)
41 )
42 (while (string-match "\\.\\| " fpak)
43 (setq fpak (replace-match "_" t t fpak)))
44 (if (string-match "src/" dir)
45 (setq dir (substring dir (match-end 0)))
46 (setq dir (file-name-nondirectory (directory-file-name dir))))
47 (while (string-match "/" dir)
48 (setq dir (replace-match "_" t t dir)))
49 (srecode-dictionary-set-value dict "FILENAME_AS_PACKAGE"
50 (concat dir "." fpak))
51 (srecode-dictionary-set-value dict "FILENAME_AS_CLASS" fnox)
52 ))
53
54(provide 'srecode/java)
55
56;; Local variables:
57;; generated-autoload-file: "loaddefs.el"
58;; generated-autoload-feature: srecode/loaddefs
59;; generated-autoload-load-name: "srecode/java"
60;; End:
61
62;;; srecode/java.el ends here
diff --git a/lisp/cedet/srecode/map.el b/lisp/cedet/srecode/map.el
new file mode 100644
index 00000000000..e36b19b80e2
--- /dev/null
+++ b/lisp/cedet/srecode/map.el
@@ -0,0 +1,415 @@
1;;; srecode/map.el --- Manage a template file map
2
3;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <eric@siege-engine.com>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;
24;; Read template files, and build a map of where they can be found.
25;; Save the map to disk, and refer to it when bootstrapping a new
26;; Emacs session with srecode.
27
28(require 'semantic)
29(require 'eieio-base)
30(require 'srecode)
31
32;;; Code:
33
34;; The defcustom is given at the end of the file.
35(defvar srecode-map-load-path)
36
37(defun srecode-map-base-template-dir ()
38 "Find the base template directory for SRecode."
39 (let* ((lib (locate-library "srecode.el"))
40 (dir (file-name-directory lib)))
41 (expand-file-name "templates/" dir)
42 ))
43
44;;; Current MAP
45;;
46
47(defvar srecode-current-map nil
48 "The current map for global SRecode templtes.")
49
50(defcustom srecode-map-save-file (expand-file-name "~/.srecode/srecode-map")
51 "The save location for SRecode's map file.
52If the save file is nil, then the MAP is not saved between sessions."
53 :group 'srecode
54 :type 'file)
55
56(defclass srecode-map (eieio-persistent)
57 ((fileheaderline :initform ";; SRECODE TEMPLATE MAP")
58 (files :initarg :files
59 :initform nil
60 :type list
61 :documentation
62 "An alist of files and the major-mode that they cover.")
63 (apps :initarg :apps
64 :initform nil
65 :type list
66 :documentation
67 "An alist of applications.
68Each app keys to an alist of files and modes (as above.)")
69 )
70 "A map of srecode templates.")
71
72(defmethod srecode-map-entry-for-file ((map srecode-map) file)
73 "Return the entry in MAP for FILE."
74 (assoc file (oref map files)))
75
76(defmethod srecode-map-entries-for-mode ((map srecode-map) mode)
77 "Return the entries in MAP for major MODE."
78 (let ((ans nil))
79 (dolist (f (oref map files))
80 (when (mode-local-use-bindings-p mode (cdr f))
81 (setq ans (cons f ans))))
82 ans))
83
84(defmethod srecode-map-entry-for-app ((map srecode-map) app)
85 "Return the entry in MAP for APP'lication."
86 (assoc app (oref map apps))
87 )
88
89(defmethod srecode-map-entries-for-app-and-mode ((map srecode-map) app mode)
90 "Return the entries in MAP for major MODE."
91 (let ((ans nil)
92 (appentry (srecode-map-entry-for-app map app)))
93 (dolist (f (cdr appentry))
94 (when (eq (cdr f) mode)
95 (setq ans (cons f ans))))
96 ans))
97
98(defmethod srecode-map-entry-for-file-anywhere ((map srecode-map) file)
99 "Search in all entry points in MAP for FILE.
100Return a list ( APP . FILE-ASSOC ) where APP is nil
101in the global map."
102 (or
103 ;; Look in the global entry
104 (let ((globalentry (srecode-map-entry-for-file map file)))
105 (when globalentry
106 (cons nil globalentry)))
107 ;; Look in each app.
108 (let ((match nil))
109 (dolist (app (oref map apps))
110 (let ((appmatch (assoc file (cdr app))))
111 (when appmatch
112 (setq match (cons app appmatch)))))
113 match)
114 ;; Other?
115 ))
116
117(defmethod srecode-map-delete-file-entry ((map srecode-map) file)
118 "Update MAP to exclude FILE from the file list."
119 (let ((entry (srecode-map-entry-for-file map file)))
120 (when entry
121 (object-remove-from-list map 'files entry))))
122
123(defmethod srecode-map-update-file-entry ((map srecode-map) file mode)
124 "Update a MAP entry for FILE to be used with MODE.
125Return non-nil if the MAP was changed."
126 (let ((entry (srecode-map-entry-for-file map file))
127 (dirty t))
128 (cond
129 ;; It is already a match.. do nothing.
130 ((and entry (eq (cdr entry) mode))
131 (setq dirty nil))
132 ;; We have a non-matching entry. Change the cdr.
133 (entry
134 (setcdr entry mode))
135 ;; No entry, just add it to the list.
136 (t
137 (object-add-to-list map 'files (cons file mode))
138 ))
139 dirty))
140
141(defmethod srecode-map-delete-file-entry-from-app ((map srecode-map) file app)
142 "Delete from MAP the FILE entry within the APP'lication."
143 (let* ((appe (srecode-map-entry-for-app map app))
144 (fentry (assoc file (cdr appe))))
145 (setcdr appe (delete fentry (cdr appe))))
146 )
147
148(defmethod srecode-map-update-app-file-entry ((map srecode-map) file mode app)
149 "Update the MAP entry for FILE to be used with MODE within APP.
150Return non-nil if the map was changed."
151 (let* ((appentry (srecode-map-entry-for-app map app))
152 (appfileentry (assoc file (cdr appentry)))
153 (dirty t)
154 )
155 (cond
156 ;; Option 1 - We have this file in this application already
157 ;; with the correct mode.
158 ((and appfileentry (eq (cdr appfileentry) mode))
159 (setq dirty nil)
160 )
161 ;; Option 2 - We have a non-matching entry. Change Cdr.
162 (appfileentry
163 (setcdr appfileentry mode))
164 (t
165 ;; For option 3 & 4 - remove the entry from any other lists
166 ;; we can find.
167 (let ((any (srecode-map-entry-for-file-anywhere map file)))
168 (when any
169 (if (null (car any))
170 ;; Global map entry
171 (srecode-map-delete-file-entry map file)
172 ;; Some app
173 (let ((appentry (srecode-map-entry-for-app map app)))
174 (setcdr appentry (delete (cdr any) (cdr appentry))))
175 )))
176 ;; Now do option 3 and 4
177 (cond
178 ;; Option 3 - No entry for app. Add to the list.
179 (appentry
180 (setcdr appentry (cons (cons file mode) (cdr appentry)))
181 )
182 ;; Option 4 - No app entry. Add app to list with this file.
183 (t
184 (object-add-to-list map 'apps (list app (cons file mode)))
185 )))
186 )
187 dirty))
188
189
190;;; MAP Updating
191;;
192;;;###autoload
193(defun srecode-get-maps (&optional reset)
194 "Get a list of maps relevant to the current buffer.
195Optional argument RESET forces a reset of the current map."
196 (interactive "P")
197 ;; Always update the map, but only do a full reset if
198 ;; the user asks for one.
199 (srecode-map-update-map (not reset))
200
201 (if (interactive-p)
202 ;; Dump this map.
203 (with-output-to-temp-buffer "*SRECODE MAP*"
204 (princ " -- SRecode Global map --\n")
205 (srecode-maps-dump-file-list (oref srecode-current-map files))
206 (princ "\n -- Application Maps --\n")
207 (dolist (ap (oref srecode-current-map apps))
208 (let ((app (car ap))
209 (files (cdr ap)))
210 (princ app)
211 (princ " :\n")
212 (srecode-maps-dump-file-list files))
213 (princ "\n"))
214 (princ "\nUse:\n\n M-x customize-variable RET srecode-map-load-path RET")
215 (princ "\n To change the path where SRecode loads templates from.")
216 )
217 ;; Eventually, I want to return many maps to search through.
218 (list srecode-current-map)))
219
220(eval-when-compile (require 'data-debug))
221
222(defun srecode-adebug-maps ()
223 "Run ADEBUG on the output of `srecode-get-maps'."
224 (interactive)
225 (require 'data-debug)
226 (let ((start (current-time))
227 (p (srecode-get-maps t)) ;; Time the reset.
228 (end (current-time))
229 )
230 (message "Updating the map took %.2f seconds."
231 (semantic-elapsed-time start end))
232 (data-debug-new-buffer "*SRECODE ADEBUG*")
233 (data-debug-insert-stuff-list p "*")))
234
235(defun srecode-maps-dump-file-list (flist)
236 "Dump a file list FLIST to `standard-output'."
237 (princ "Mode\t\t\tFilename\n")
238 (princ "------\t\t\t------------------\n")
239 (dolist (fe flist)
240 (prin1 (cdr fe))
241 (princ "\t")
242 (when (> (* 2 8) (length (symbol-name (cdr fe))))
243 (princ "\t"))
244 (when (> 8 (length (symbol-name (cdr fe))))
245 (princ "\t"))
246 (princ (car fe))
247 (princ "\n")
248 ))
249
250(defun srecode-map-file-still-valid-p (filename map)
251 "Return t if FILENAME should be in MAP still."
252 (let ((valid nil))
253 (and (file-exists-p filename)
254 (progn
255 (dolist (p srecode-map-load-path)
256 (when (and (< (length p) (length filename))
257 (string= p (substring filename 0 (length p))))
258 (setq valid t))
259 )
260 valid))
261 ))
262
263(defun srecode-map-update-map (&optional fast)
264 "Update the current map from `srecode-map-load-path'.
265Scans all the files on the path, and makes sure we have entries
266for them.
267If option FAST is non-nil, then only parse a file for the mode-string
268if that file is NEW, otherwise assume the mode has not changed."
269 (interactive)
270
271 ;; When no map file, we are configured to not use a save file.
272 (if (not srecode-map-save-file)
273 ;; 0) Create a MAP when in no save file mode.
274 (when (not srecode-current-map)
275 (setq srecode-current-map (srecode-map "SRecode Map"))
276 (message "SRecode map created in non-save mode.")
277 )
278
279 ;; 1) Do we even have a MAP or save file?
280 (when (and (not srecode-current-map)
281 (not (file-exists-p srecode-map-save-file)))
282 (when (not (file-exists-p (file-name-directory srecode-map-save-file)))
283 ;; Only bother with this interactively, not during a build
284 ;; or test.
285 (when (not noninteractive)
286 ;; No map, make the dir?
287 (if (y-or-n-p (format "Create dir %s? "
288 (file-name-directory srecode-map-save-file)))
289 (make-directory (file-name-directory srecode-map-save-file))
290 ;; No make, change save file
291 (customize-variable 'srecode-map-save-file)
292 (error "Change your SRecode map file"))))
293 ;; Have a dir. Make the object.
294 (setq srecode-current-map
295 (srecode-map "SRecode Map"
296 :file srecode-map-save-file)))
297
298 ;; 2) Do we not have a current map? If so load.
299 (when (not srecode-current-map)
300 (setq srecode-current-map
301 (eieio-persistent-read srecode-map-save-file))
302 )
303
304 )
305
306 ;;
307 ;; We better have a MAP object now.
308 ;;
309 (let ((dirty nil))
310 ;; 3) - Purge dead files from the file list.
311 (dolist (entry (copy-sequence (oref srecode-current-map files)))
312 (when (not (srecode-map-file-still-valid-p
313 (car entry) srecode-current-map))
314 (srecode-map-delete-file-entry srecode-current-map (car entry))
315 (setq dirty t)
316 ))
317 (dolist (app (copy-sequence (oref srecode-current-map apps)))
318 (dolist (entry (copy-sequence (cdr app)))
319 (when (not (srecode-map-file-still-valid-p
320 (car entry) srecode-current-map))
321 (srecode-map-delete-file-entry-from-app
322 srecode-current-map (car entry) (car app))
323 (setq dirty t)
324 )))
325 ;; 4) - Find new files and add them to the map.
326 (dolist (dir srecode-map-load-path)
327 (when (file-exists-p dir)
328 (dolist (f (directory-files dir t "\\.srt$"))
329 (when (and (not (backup-file-name-p f))
330 (not (auto-save-file-name-p f))
331 (file-readable-p f))
332 (let ((fdirty (srecode-map-validate-file-for-mode f fast)))
333 (setq dirty (or dirty fdirty))))
334 )))
335 ;; Only do the save if we are dirty, or if we are in an interactive
336 ;; Emacs.
337 (when (and dirty (not noninteractive)
338 (slot-boundp srecode-current-map :file))
339 (eieio-persistent-save srecode-current-map))
340 ))
341
342(defun srecode-map-validate-file-for-mode (file fast)
343 "Read and validate FILE via the parser. Return the mode.
344Argument FAST implies that the file should not be reparsed if there
345is already an entry for it.
346Return non-nil if the map changed."
347 (when (or (not fast)
348 (not (srecode-map-entry-for-file-anywhere srecode-current-map file)))
349 (let ((buff-orig (get-file-buffer file))
350 (dirty nil))
351 (save-excursion
352 (if buff-orig
353 (set-buffer buff-orig)
354 (set-buffer (get-buffer-create " *srecode-map-tmp*"))
355 (insert-file-contents file nil nil nil t)
356 ;; Force it to be ready to parse.
357 (srecode-template-mode)
358 (let ((semantic-init-hooks nil))
359 (semantic-new-buffer-fcn))
360 )
361
362 (semantic-fetch-tags)
363 (let* ((mode-tag
364 (semantic-find-first-tag-by-name "mode" (current-buffer)))
365 (val nil)
366 (app-tag
367 (semantic-find-first-tag-by-name "application" (current-buffer)))
368 (app nil))
369 (if mode-tag
370 (setq val (car (semantic-tag-variable-default mode-tag)))
371 (error "There should be a mode declaration in %s" file))
372 (when app-tag
373 (setq app (car (semantic-tag-variable-default app-tag))))
374
375 (setq dirty
376 (if app
377 (srecode-map-update-app-file-entry srecode-current-map
378 file
379 (read val)
380 (read app))
381 (srecode-map-update-file-entry srecode-current-map
382 file
383 (read val))))
384 )
385 )
386 dirty)))
387
388
389;;; THE PATH
390;;
391;; We need to do this last since the setter needs the above code.
392
393(defun srecode-map-load-path-set (sym val)
394 "Set SYM to the new VAL, then update the srecode map."
395 (set-default sym val)
396 (srecode-map-update-map t))
397
398(defcustom srecode-map-load-path
399 (list (srecode-map-base-template-dir)
400 (expand-file-name "~/.srecode/")
401 )
402 "*Global load path for SRecode template files."
403 :group 'srecode
404 :type '(repeat file)
405 :set 'srecode-map-load-path-set)
406
407(provide 'srecode/map)
408
409;; Local variables:
410;; generated-autoload-file: "loaddefs.el"
411;; generated-autoload-feature: srecode/loaddefs
412;; generated-autoload-load-name: "srecode/map"
413;; End:
414
415;;; srecode/map.el ends here
diff --git a/lisp/cedet/srecode/mode.el b/lisp/cedet/srecode/mode.el
new file mode 100644
index 00000000000..3100a392cf2
--- /dev/null
+++ b/lisp/cedet/srecode/mode.el
@@ -0,0 +1,420 @@
1;;; srecode/mode.el --- Minor mode for managing and using SRecode templates
2
3;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <eric@siege-engine.com>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;
24;; Minor mode for working with SRecode template files.
25;;
26;; Depends on Semantic for minor-mode convenience functions.
27
28(require 'mode-local)
29(require 'srecode)
30(require 'srecode/insert)
31(require 'srecode/find)
32(require 'srecode/map)
33;; (require 'senator)
34(require 'semantic/decorate)
35(require 'semantic/wisent)
36
37(eval-when-compile (require 'semantic/find))
38
39;;; Code:
40
41(defcustom global-srecode-minor-mode nil
42 "Non-nil in buffers with Semantic Recoder macro keybindings."
43 :group 'srecode
44 :type 'boolean
45 :require 'srecode-mode
46 :initialize 'custom-initialize-default
47 :set (lambda (sym val)
48 (global-srecode-minor-mode (if val 1 -1))))
49
50(defvar srecode-minor-mode nil
51 "Non-nil in buffers with Semantic Recoder macro keybindings.")
52(make-variable-buffer-local 'srecode-minor-mode)
53
54(defcustom srecode-minor-mode-hook nil
55 "Hook run at the end of the function `srecode-minor-mode'."
56 :group 'srecode
57 :type 'hook)
58
59;; We don't want to waste space. There is a menu after all.
60;;(add-to-list 'minor-mode-alist '(srecode-minor-mode ""))
61
62(defvar srecode-prefix-key [(control ?c) ?/]
63 "The common prefix key in srecode minor mode.")
64
65(defvar srecode-prefix-map
66 (let ((km (make-sparse-keymap)))
67 ;; Basic template codes
68 (define-key km "/" 'srecode-insert)
69 (define-key km [insert] 'srecode-insert)
70 (define-key km "." 'srecode-insert-again)
71 (define-key km "E" 'srecode-edit)
72 ;; Template indirect binding
73 (let ((k ?a))
74 (while (<= k ?z)
75 (define-key km (format "%c" k) 'srecode-bind-insert)
76 (setq k (1+ k))))
77 km)
78 "Keymap used behind the srecode prefix key in in srecode minor mode.")
79
80(defvar srecode-menu-bar
81 (list
82 "SRecoder"
83 (senator-menu-item
84 ["Insert Template"
85 srecode-insert
86 :active t
87 :help "Insert a template by name."
88 ])
89 (senator-menu-item
90 ["Insert Template Again"
91 srecode-insert-again
92 :active t
93 :help "Run the same template as last time again."
94 ])
95 (senator-menu-item
96 ["Edit Template"
97 srecode-edit
98 :active t
99 :help "Edit a template for this language by name."
100 ])
101 "---"
102 '( "Insert ..." :filter srecode-minor-mode-templates-menu )
103 `( "Generate ..." :filter srecode-minor-mode-generate-menu )
104 "---"
105 (senator-menu-item
106 ["Customize..."
107 (customize-group "srecode")
108 :active t
109 :help "Customize SRecode options"
110 ])
111 (list
112 "Debugging Tools..."
113 (senator-menu-item
114 ["Dump Template MAP"
115 srecode-get-maps
116 :active t
117 :help "Calculate (if needed) and display the current template file map."
118 ])
119 (senator-menu-item
120 ["Dump Tables"
121 srecode-dump-templates
122 :active t
123 :help "Dump the current template table."
124 ])
125 (senator-menu-item
126 ["Dump Dictionary"
127 srecode-dictionary-dump
128 :active t
129 :help "Calculate a dump a dictionary for point."
130 ])
131 )
132 )
133 "Menu for srecode minor mode.")
134
135(defvar srecode-minor-menu nil
136 "Menu keymap build from `srecode-menu-bar'.")
137
138(defcustom srecode-takeover-INS-key nil
139 "Use the insert key for inserting templates."
140 :group 'srecode
141 :type 'boolean)
142
143(defvar srecode-mode-map
144 (let ((km (make-sparse-keymap)))
145 (define-key km srecode-prefix-key srecode-prefix-map)
146 (easy-menu-define srecode-minor-menu km "Srecode Minor Mode Menu"
147 srecode-menu-bar)
148 (when srecode-takeover-INS-key
149 (define-key km [insert] srecode-prefix-map))
150 km)
151 "Keymap for srecode minor mode.")
152
153;;;###autoload
154(defun srecode-minor-mode (&optional arg)
155 "Toggle srecode minor mode.
156With prefix argument ARG, turn on if positive, otherwise off. The
157minor mode can be turned on only if semantic feature is available and
158the current buffer was set up for parsing. Return non-nil if the
159minor mode is enabled.
160
161\\{srecode-mode-map}"
162 (interactive
163 (list (or current-prefix-arg
164 (if srecode-minor-mode 0 1))))
165 ;; Flip the bits.
166 (setq srecode-minor-mode
167 (if arg
168 (>
169 (prefix-numeric-value arg)
170 0)
171 (not srecode-minor-mode)))
172 ;; If we are turning things on, make sure we have templates for
173 ;; this mode first.
174 (when srecode-minor-mode
175 (when (not (apply
176 'append
177 (mapcar (lambda (map)
178 (srecode-map-entries-for-mode map major-mode))
179 (srecode-get-maps))))
180 (setq srecode-minor-mode nil))
181 )
182 ;; Run hooks if we are turning this on.
183 (when srecode-minor-mode
184 (run-hooks 'srecode-minor-mode-hook))
185 srecode-minor-mode)
186
187;;;###autoload
188(defun global-srecode-minor-mode (&optional arg)
189 "Toggle global use of srecode minor mode.
190If ARG is positive, enable, if it is negative, disable.
191If ARG is nil, then toggle."
192 (interactive "P")
193 (setq global-srecode-minor-mode
194 (semantic-toggle-minor-mode-globally
195 'srecode-minor-mode arg)))
196
197;; Use the semantic minor mode magic stuff.
198(semantic-add-minor-mode 'srecode-minor-mode "" srecode-mode-map)
199
200;;; Menu Filters
201;;
202(defun srecode-minor-mode-templates-menu (menu-def)
203 "Create a menu item of cascading filters active for this mode.
204MENU-DEF is the menu to bind this into."
205 ;; Doing this SEGVs Emacs on windows.
206 ;;(srecode-load-tables-for-mode major-mode)
207
208 (let* ((modetable (srecode-get-mode-table major-mode))
209 (subtab (when modetable (oref modetable :tables)))
210 (context nil)
211 (active nil)
212 (ltab nil)
213 (temp nil)
214 (alltabs nil)
215 )
216 (if (not subtab)
217 ;; No tables, show a "load the tables" option.
218 (list (vector "Load Mode Tables..."
219 (lambda ()
220 (interactive)
221 (srecode-load-tables-for-mode major-mode))
222 ))
223 ;; Build something
224 (setq context (car-safe (srecode-calculate-context)))
225
226 (while subtab
227 (setq ltab (oref (car subtab) templates))
228 (while ltab
229 (setq temp (car ltab))
230
231 ;; Do something with this template.
232
233 (let* ((ctxt (oref temp context))
234 (ctxtcons (assoc ctxt alltabs))
235 (bind (if (slot-boundp temp 'binding)
236 (oref temp binding)))
237 (name (object-name-string temp)))
238
239 (when (not ctxtcons)
240 (if (string= context ctxt)
241 ;; If this context is not in the current list of contexts
242 ;; is equal to the current context, then manage the
243 ;; active list instead
244 (setq active
245 (setq ctxtcons (or active (cons ctxt nil))))
246 ;; This is not an active context, add it to alltabs.
247 (setq ctxtcons (cons ctxt nil))
248 (setq alltabs (cons ctxtcons alltabs))))
249
250 (let ((new (vector
251 (if bind
252 (concat name " (" bind ")")
253 name)
254 `(lambda () (interactive)
255 (srecode-insert (concat ,ctxt ":" ,name)))
256 t)))
257
258 (setcdr ctxtcons (cons
259 new
260 (cdr ctxtcons)))))
261
262 (setq ltab (cdr ltab)))
263 (setq subtab (cdr subtab)))
264
265 ;; Now create the menu
266 (easy-menu-filter-return
267 (easy-menu-create-menu
268 "Semantic Recoder Filters"
269 (append (cdr active)
270 alltabs)
271 ))
272 )))
273
274(defvar srecode-minor-mode-generators nil
275 "List of code generators to be displayed in the srecoder menu.")
276
277(defun srecode-minor-mode-generate-menu (menu-def)
278 "Create a menu item of cascading filters active for this mode.
279MENU-DEF is the menu to bind this into."
280 ;; Doing this SEGVs Emacs on windows.
281 ;;(srecode-load-tables-for-mode major-mode)
282 (let ((allgeneratorapps nil))
283
284 (dolist (gen srecode-minor-mode-generators)
285 (setq allgeneratorapps
286 (cons (vector (cdr gen) (car gen))
287 allgeneratorapps))
288 (message "Adding %S to srecode menu" (car gen))
289 )
290
291 (easy-menu-filter-return
292 (easy-menu-create-menu
293 "Semantic Recoder Generate Filters"
294 allgeneratorapps)))
295 )
296
297;;; Minor Mode commands
298;;
299(defun srecode-bind-insert ()
300 "Bound insert for Srecode macros.
301This command will insert whichever srecode template has a binding
302to the current key."
303 (interactive)
304 (let* ((k last-command-event)
305 (ctxt (srecode-calculate-context))
306 ;; Find the template with the binding K
307 (template (srecode-template-get-table-for-binding
308 (srecode-table) k ctxt)))
309 ;; test it.
310 (when (not template)
311 (error "No template bound to %c" k))
312 ;; insert
313 (srecode-insert template)
314 ))
315
316(defun srecode-edit (template-name)
317 "Switch to the template buffer for TEMPLATE-NAME.
318Template is chosen based on the mode of the starting buffer."
319 ;; @todo - Get a template stack from the last run template, and show
320 ;; those too!
321 (interactive (list (srecode-read-template-name
322 "Template Name: "
323 (car srecode-read-template-name-history))))
324 (if (not (srecode-table))
325 (error "No template table found for mode %s" major-mode))
326 (let ((temp (srecode-template-get-table (srecode-table) template-name)))
327 (if (not temp)
328 (error "No Template named %s" template-name))
329 ;; We need a template specific table, since tables chain.
330 (let ((tab (oref temp :table))
331 (names nil)
332 )
333 (find-file (oref tab :file))
334 (setq names (semantic-find-tags-by-name (oref temp :object-name)
335 (current-buffer)))
336 (cond ((= (length names) 1)
337 (semantic-go-to-tag (car names))
338 (semantic-momentary-highlight-tag (car names)))
339 ((> (length names) 1)
340 (let* ((ctxt (semantic-find-tags-by-name (oref temp :context)
341 (current-buffer)))
342 (cls (semantic-find-tags-by-class 'context ctxt))
343 )
344 (while (and names
345 (< (semantic-tag-start (car names))
346 (semantic-tag-start (car cls))))
347 (setq names (cdr names)))
348 (if names
349 (progn
350 (semantic-go-to-tag (car names))
351 (semantic-momentary-highlight-tag (car names)))
352 (error "Can't find template %s" template-name))
353 ))
354 (t (error "Can't find template %s" template-name)))
355 )))
356
357(defun srecode-add-code-generator (function name &optional binding)
358 "Add the srecoder code generator FUNCTION with NAME to the menu.
359Optional BINDING specifies the keybinding to use in the srecoder map.
360BINDING should be a capital letter. Lower case letters are reserved
361for individual templates.
362Optional MODE specifies a major mode this function applies to.
363Do not specify a mode if this function could be applied to most
364programming modes."
365 ;; Update the menu generating part.
366 (let ((remloop nil))
367 (while (setq remloop (assoc function srecode-minor-mode-generators))
368 (setq srecode-minor-mode-generators
369 (remove remloop srecode-minor-mode-generators))))
370
371 (add-to-list 'srecode-minor-mode-generators
372 (cons function name))
373
374 ;; Remove this function from any old bindings.
375 (when binding
376 (let ((oldkey (where-is-internal function
377 (list srecode-prefix-map)
378 t t t)))
379 (if (or (not oldkey)
380 (and (= (length oldkey) 1)
381 (= (length binding) 1)
382 (= (aref oldkey 0) (aref binding 0))))
383 ;; Its the same.
384 nil
385 ;; Remove the old binding
386 (define-key srecode-prefix-map oldkey nil)
387 )))
388
389 ;; Update Keybings
390 (let ((oldbinding (lookup-key srecode-prefix-map binding)))
391
392 ;; During development, allow overrides.
393 (when (and oldbinding
394 (not (eq oldbinding function))
395 (or (eq this-command 'eval-defun) (eq this-command 'checkdoc-eval-defun))
396 (y-or-n-p (format "Override old binding %s? " oldbinding)))
397 (setq oldbinding nil))
398
399 (if (not oldbinding)
400 (define-key srecode-prefix-map binding function)
401 (if (eq function oldbinding)
402 nil
403 ;; Not the same.
404 (message "Conflict binding %S binding to srecode map."
405 binding))))
406 )
407
408;; Add default code generators:
409(srecode-add-code-generator 'srecode-document-insert-comment "Comments" "C")
410(srecode-add-code-generator 'srecode-insert-getset "Get/Set" "G")
411
412(provide 'srecode/mode)
413
414;; Local variables:
415;; generated-autoload-file: "loaddefs.el"
416;; generated-autoload-feature: srecode/loaddefs
417;; generated-autoload-load-name: "srecode/mode"
418;; End:
419
420;;; srecode/mode.el ends here
diff --git a/lisp/cedet/srecode/semantic.el b/lisp/cedet/srecode/semantic.el
new file mode 100644
index 00000000000..178ec44a8de
--- /dev/null
+++ b/lisp/cedet/srecode/semantic.el
@@ -0,0 +1,431 @@
1;;; srecode/semantic.el --- Semantic specific extensions to SRecode.
2
3;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <eric@siege-engine.com>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;
24;; Semantic specific extensions to the Semantic Recoder.
25;;
26;; I realize it is the "Semantic Recoder", but most of srecode
27;; is a template library and set of user interfaces unrelated to
28;; semantic in the specific.
29;;
30;; This file defines the following:
31;; - :tag argument handling.
32;; - <more goes here>
33
34;;; Code:
35
36(require 'srecode/insert)
37(require 'srecode/dictionary)
38(require 'semantic/find)
39(require 'semantic/format)
40(require 'ring)
41;;(require 'senator)
42
43
44;;; The SEMANTIC TAG inserter
45;;
46;; Put a tag into the dictionary that can be used w/ arbitrary
47;; lisp expressions.
48
49(defclass srecode-semantic-tag (srecode-dictionary-compound-value)
50 ((prime :initarg :prime
51 :type semantic-tag
52 :documentation
53 "This is the primary insertion tag.")
54 )
55 "Wrap up a collection of semantic tag information.
56This class will be used to derive dictionary values.")
57
58(defmethod srecode-compound-toString((cp srecode-semantic-tag)
59 function
60 dictionary)
61 "Convert the compound dictionary value CP to a string.
62If FUNCTION is non-nil, then FUNCTION is somehow applied to an
63aspect of the compound value."
64 (if (not function)
65 ;; Just format it in some handy dandy way.
66 (semantic-format-tag-prototype (oref cp :prime))
67 ;; Otherwise, apply the function to the tag itself.
68 (funcall function (oref cp :prime))
69 ))
70
71
72;;; Managing the `current' tag
73;;
74
75(defvar srecode-semantic-selected-tag nil
76 "The tag selected by a :tag template argument.
77If this is nil, then `senator-tag-ring' is used.")
78
79(defun srecode-semantic-tag-from-kill-ring ()
80 "Create an `srecode-semantic-tag' from the senator kill ring."
81 (if (ring-empty-p senator-tag-ring)
82 (error "You must use `senator-copy-tag' to provide a tag to this template"))
83 (ring-ref senator-tag-ring 0))
84
85
86;;; TAG in a DICTIONARY
87;;
88(defvar srecode-semantic-apply-tag-augment-hook nil
89 "A function called for each tag added to a dictionary.
90The hook is called with two arguments, the TAG and DICT
91to be augmented.")
92
93(define-overload srecode-semantic-apply-tag-to-dict (tagobj dict)
94 "Insert fewatures of TAGOBJ into the dictionary DICT.
95TAGOBJ is an object of class `srecode-semantic-tag'. This class
96is a compound inserter value.
97DICT is a dictionary object.
98At a minimum, this function will create dictionary macro for NAME.
99It is also likely to create macros for TYPE (data type), function arguments,
100variable default values, and other things."
101 )
102
103(defun srecode-semantic-apply-tag-to-dict-default (tagobj dict)
104 "Insert features of TAGOBJ into dictionary DICT."
105 ;; Store the sst into the dictionary.
106 (srecode-dictionary-set-value dict "TAG" tagobj)
107
108 ;; Pull out the tag for the individual pieces.
109 (let ((tag (oref tagobj :prime)))
110
111 (srecode-dictionary-set-value dict "NAME" (semantic-tag-name tag))
112 (srecode-dictionary-set-value dict "TYPE" (semantic-format-tag-type tag nil))
113
114 (run-hook-with-args 'srecode-semantic-apply-tag-augment-hook tag dict)
115
116 (cond
117 ;;
118 ;; FUNCTION
119 ;;
120 ((eq (semantic-tag-class tag) 'function)
121 ;; FCN ARGS
122 (let ((args (semantic-tag-function-arguments tag)))
123 (while args
124 (let ((larg (car args))
125 (subdict (srecode-dictionary-add-section-dictionary
126 dict "ARGS")))
127 ;; Clean up elements in the arg list.
128 (if (stringp larg)
129 (setq larg (semantic-tag-new-variable
130 larg nil nil)))
131 ;; Apply the sub-argument to the subdictionary.
132 (srecode-semantic-apply-tag-to-dict
133 (srecode-semantic-tag (semantic-tag-name larg)
134 :prime larg)
135 subdict)
136 )
137 ;; Next!
138 (setq args (cdr args))))
139 ;; PARENTS
140 (let ((p (semantic-tag-function-parent tag)))
141 (when p
142 (srecode-dictionary-set-value dict "PARENT" p)
143 ))
144 ;; EXCEPTIONS (java/c++)
145 (let ((exceptions (semantic-tag-get-attribute tag :throws)))
146 (while exceptions
147 (let ((subdict (srecode-dictionary-add-section-dictionary
148 dict "THROWS")))
149 (srecode-dictionary-set-value subdict "NAME" (car exceptions))
150 )
151 (setq exceptions (cdr exceptions)))
152 )
153 )
154 ;;
155 ;; VARIABLE
156 ;;
157 ((eq (semantic-tag-class tag) 'variable)
158 (when (semantic-tag-variable-default tag)
159 (let ((subdict (srecode-dictionary-add-section-dictionary
160 dict "HAVEDEFAULT")))
161 (srecode-dictionary-set-value
162 subdict "VALUE" (semantic-tag-variable-default tag))))
163 )
164 ;;
165 ;; TYPE
166 ;;
167 ((eq (semantic-tag-class tag) 'type)
168 (dolist (p (semantic-tag-type-superclasses tag))
169 (let ((sd (srecode-dictionary-add-section-dictionary
170 dict "PARENTS")))
171 (srecode-dictionary-set-value sd "NAME" p)
172 ))
173 (dolist (i (semantic-tag-type-interfaces tag))
174 (let ((sd (srecode-dictionary-add-section-dictionary
175 dict "INTERFACES")))
176 (srecode-dictionary-set-value sd "NAME" i)
177 ))
178; NOTE : The members are too complicated to do via a template.
179; do it via the insert-tag solution instead.
180;
181; (dolist (mem (semantic-tag-type-members tag))
182; (let ((subdict (srecode-dictionary-add-section-dictionary
183; dict "MEMBERS")))
184; (when (stringp mem)
185; (setq mem (semantic-tag-new-variable mem nil nil)))
186; (srecode-semantic-apply-tag-to-dict
187; (srecode-semantic-tag (semantic-tag-name mem)
188; :prime mem)
189; subdict)))
190 ))))
191
192
193;;; ARGUMENT HANDLERS
194
195;;; :tag ARGUMENT HANDLING
196;;
197;; When a :tag argument is required, identify the current :tag,
198;; and apply it's parts into the dictionary.
199(defun srecode-semantic-handle-:tag (dict)
200 "Add macroes into the dictionary DICT based on the current :tag."
201 ;; We have a tag, start adding "stuff" into the dictionary.
202 (let ((tag (or srecode-semantic-selected-tag
203 (srecode-semantic-tag-from-kill-ring))))
204 (when (not tag)
205 "No tag for current template. Use the semantic kill-ring.")
206 (srecode-semantic-apply-tag-to-dict
207 (srecode-semantic-tag (semantic-tag-name tag)
208 :prime tag)
209 dict)))
210
211;;; :tagtype ARGUMENT HANDLING
212;;
213;; When a :tagtype argument is required, identify the current tag, of
214;; cf class 'type. Apply those parameters to the dictionary.
215
216(defun srecode-semantic-handle-:tagtype (dict)
217 "Add macroes into the dictionary DICT based on a tag of class type at point.
218Assumes the cursor is in a tag of class type. If not, throw an error."
219 (let ((typetag (or srecode-semantic-selected-tag
220 (semantic-current-tag-of-class 'type))))
221 (when (not typetag)
222 (error "Cursor is not in a TAG of class 'type"))
223 (srecode-semantic-apply-tag-to-dict
224 typetag
225 dict)))
226
227
228;;; INSERT A TAG API
229;;
230;; Routines that take a tag, and insert into a buffer.
231(define-overload srecode-semantic-find-template (class prototype ctxt)
232 "Find a template for a tag of class CLASS based on context.
233PROTOTYPE is non-nil if we want a prototype template instead."
234 )
235
236(defun srecode-semantic-find-template-default (class prototype ctxt)
237 "Find a template for tag CLASS based on context.
238PROTOTYPE is non-nil if we need a prototype.
239CTXT is the pre-calculated context."
240 (let* ((top (car ctxt))
241 (tname (if (stringp class)
242 class
243 (symbol-name class)))
244 (temp nil)
245 )
246 ;; Try to find a template.
247 (setq temp (or
248 (when prototype
249 (srecode-template-get-table (srecode-table)
250 (concat tname "-tag-prototype")
251 top))
252 (when prototype
253 (srecode-template-get-table (srecode-table)
254 (concat tname "-prototype")
255 top))
256 (srecode-template-get-table (srecode-table)
257 (concat tname "-tag")
258 top)
259 (srecode-template-get-table (srecode-table)
260 tname
261 top)
262 (when (and (not (string= top "declaration"))
263 prototype)
264 (srecode-template-get-table (srecode-table)
265 (concat tname "-prototype")
266 "declaration"))
267 (when (and (not (string= top "declaration"))
268 prototype)
269 (srecode-template-get-table (srecode-table)
270 (concat tname "-tag-prototype")
271 "declaration"))
272 (when (not (string= top "declaration"))
273 (srecode-template-get-table (srecode-table)
274 (concat tname "-tag")
275 "declaration"))
276 (when (not (string= top "declaration"))
277 (srecode-template-get-table (srecode-table)
278 tname
279 "declaration"))
280 ))
281 temp))
282
283(defun srecode-semantic-insert-tag (tag &optional style-option
284 point-insert-fcn
285 &rest dict-entries)
286 "Insert TAG into a buffer useing srecode templates at point.
287
288Optional STYLE-OPTION is a list of minor configuration of styles,
289such as the symbol 'prototype for prototype functions, or
290'system for system includes, and 'doxygen, for a doxygen style
291comment.
292
293Optional third argument POINT-INSERT-FCN is a hook that is run after
294TAG is inserted that allows an opportunity to fill in the body of
295some thing. This hook function is called with one argument, the TAG
296being inserted.
297
298The rest of the arguments are DICT-ENTRIES. DICT-ENTRIES
299is of the form ( NAME1 VALUE1 NAME2 VALUE2 ... NAMEn VALUEn).
300
301The exact template used is based on the current context.
302The template used is found within the toplevel context as calculated
303by `srecode-calculate-context', such as `declaration', `classdecl',
304or `code'.
305
306For various conditions, this function looks for a template with
307the name CLASS-tag, where CLASS is the tag class. If it cannot
308find that, it will look for that template in the
309`declaration'context (if the current context was not `declaration').
310
311If PROTOTYPE is specified, it will first look for templates with
312the name CLASS-tag-prototype, or CLASS-prototype as above.
313
314See `srecode-semantic-apply-tag-to-dict' for details on what is in
315the dictionary when the templates are called.
316
317This function returns to location in the buffer where the
318inserted tag ENDS, and will leave point inside the inserted
319text based on any occurance of a point-inserter. Templates such
320as `function' will leave point where code might be inserted."
321 (srecode-load-tables-for-mode major-mode)
322 (let* ((ctxt (srecode-calculate-context))
323 (top (car ctxt))
324 (tname (symbol-name (semantic-tag-class tag)))
325 (dict (srecode-create-dictionary))
326 (temp nil)
327 (errtype tname)
328 (prototype (memq 'prototype style-option))
329 )
330 ;; Try some special cases.
331 (cond ((and (semantic-tag-of-class-p tag 'function)
332 (semantic-tag-get-attribute tag :constructor-flag))
333 (setq temp (srecode-semantic-find-template
334 "constructor" prototype ctxt))
335 )
336
337 ((and (semantic-tag-of-class-p tag 'function)
338 (semantic-tag-get-attribute tag :destructor-flag))
339 (setq temp (srecode-semantic-find-template
340 "destructor" prototype ctxt))
341 )
342
343 ((and (semantic-tag-of-class-p tag 'function)
344 (semantic-tag-function-parent tag))
345 (setq temp (srecode-semantic-find-template
346 "method" prototype ctxt))
347 )
348
349 ((and (semantic-tag-of-class-p tag 'variable)
350 (semantic-tag-get-attribute tag :constant-flag))
351 (setq temp (srecode-semantic-find-template
352 "variable-const" prototype ctxt))
353 )
354 )
355
356 (when (not temp)
357 ;; Try the basics
358 (setq temp (srecode-semantic-find-template
359 tname prototype ctxt)))
360
361 ;; Try some backup template names.
362 (when (not temp)
363 (cond
364 ;; Types might split things up based on the type's type.
365 ((and (eq (semantic-tag-class tag) 'type)
366 (semantic-tag-type tag))
367 (setq temp (srecode-semantic-find-template
368 (semantic-tag-type tag) prototype ctxt))
369 (setq errtype (concat errtype " or " (semantic-tag-type tag)))
370 )
371 ;; A function might be an externally declared method.
372 ((and (eq (semantic-tag-class tag) 'function)
373 (semantic-tag-function-parent tag))
374 (setq temp (srecode-semantic-find-template
375 "method" prototype ctxt)))
376 (t
377 nil)
378 ))
379
380 ;; Can't find one? Drat!
381 (when (not temp)
382 (error "Cannot find template %s in %s for inserting tag %S"
383 errtype top (semantic-format-tag-summarize tag)))
384
385 ;; Resolve Arguments
386 (let ((srecode-semantic-selected-tag tag))
387 (srecode-resolve-arguments temp dict))
388
389 ;; Resolve TAG into the dictionary. We may have a :tag arg
390 ;; from the macro such that we don't need to do this.
391 (when (not (srecode-dictionary-lookup-name dict "TAG"))
392 (let ((tagobj (srecode-semantic-tag (semantic-tag-name tag) :prime tag))
393 )
394 (srecode-semantic-apply-tag-to-dict tagobj dict)))
395
396 ;; Insert dict-entries into the dictionary LAST so that previous
397 ;; items can be overriden.
398 (let ((entries dict-entries))
399 (while entries
400 (srecode-dictionary-set-value dict
401 (car entries)
402 (car (cdr entries)))
403 (setq entries (cdr (cdr entries)))))
404
405 ;; Insert the template.
406 (let ((endpt (srecode-insert-fcn temp dict nil t)))
407
408 (run-hook-with-args 'point-insert-fcn tag)
409 ;;(sit-for 1)
410
411 (cond
412 ((semantic-tag-of-class-p tag 'type)
413 ;; Insert all the members at the current insertion point.
414 (dolist (m (semantic-tag-type-members tag))
415
416 (when (stringp m)
417 (setq m (semantic-tag-new-variable m nil nil)))
418
419 ;; We do prototypes w/in the class decl?
420 (let ((me (srecode-semantic-insert-tag m '(prototype))))
421 (goto-char me))
422
423 ))
424 )
425
426 endpt)
427 ))
428
429(provide 'srecode/semantic)
430
431;;; srecode/semantic.el ends here
diff --git a/lisp/cedet/srecode/srt-mode.el b/lisp/cedet/srecode/srt-mode.el
new file mode 100644
index 00000000000..004e4a86848
--- /dev/null
+++ b/lisp/cedet/srecode/srt-mode.el
@@ -0,0 +1,775 @@
1;;; srecode/srt-mode.el --- Major mode for writing screcode macros
2
3;; Copyright (C) 2005, 2007, 2008, 2009 Free Software Foundation, Inc.
4
5;; This file is part of GNU Emacs.
6
7;; GNU Emacs is free software: you can redistribute it and/or modify
8;; it under the terms of the GNU General Public License as published by
9;; the Free Software Foundation, either version 3 of the License, or
10;; (at your option) any later version.
11
12;; GNU Emacs is distributed in the hope that it will be useful,
13;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;; GNU General Public License for more details.
16
17;; You should have received a copy of the GNU General Public License
18;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
19
20;;; Commentary:
21
22;; Originally named srecode-template-mode.el in the CEDET repository.
23
24(require 'srecode/compile)
25(require 'srecode/ctxt)
26(require 'srecode/template)
27
28(require 'semantic)
29(require 'semantic/analyze)
30(require 'semantic/wisent)
31(eval-when-compile
32 (require 'semantic/find))
33
34(declare-function srecode-create-dictionary "srecode/dictionary")
35(declare-function srecode-resolve-argument-list "srecode/insert")
36
37;;; Code:
38(defvar srecode-template-mode-syntax-table
39 (let ((table (make-syntax-table (standard-syntax-table))))
40 (modify-syntax-entry ?\; ". 12" table) ;; SEMI, Comment start ;;
41 (modify-syntax-entry ?\n ">" table) ;; Comment end
42 (modify-syntax-entry ?$ "." table) ;; Punctuation
43 (modify-syntax-entry ?: "." table) ;; Punctuation
44 (modify-syntax-entry ?< "." table) ;; Punctuation
45 (modify-syntax-entry ?> "." table) ;; Punctuation
46 (modify-syntax-entry ?# "." table) ;; Punctuation
47 (modify-syntax-entry ?! "." table) ;; Punctuation
48 (modify-syntax-entry ?? "." table) ;; Punctuation
49 (modify-syntax-entry ?\" "\"" table) ;; String
50 (modify-syntax-entry ?\- "_" table) ;; Symbol
51 (modify-syntax-entry ?\\ "\\" table) ;; Quote
52 (modify-syntax-entry ?\` "'" table) ;; Prefix ` (backquote)
53 (modify-syntax-entry ?\' "'" table) ;; Prefix ' (quote)
54 (modify-syntax-entry ?\, "'" table) ;; Prefix , (comma)
55
56 table)
57 "Syntax table used in semantic recoder macro buffers.")
58
59(defface srecode-separator-face
60 '((t (:weight bold :strike-through t)))
61 "Face used for decorating separators in srecode template mode."
62 :group 'srecode)
63
64(defvar srecode-font-lock-keywords
65 '(
66 ;; Template
67 ("^\\(template\\)\\s-+\\(\\w*\\)\\(\\( \\(:\\w+\\)\\|\\)+\\)$"
68 (1 font-lock-keyword-face)
69 (2 font-lock-function-name-face)
70 (3 font-lock-builtin-face ))
71 ("^\\(sectiondictionary\\)\\s-+\""
72 (1 font-lock-keyword-face))
73 ("^\\(bind\\)\\s-+\""
74 (1 font-lock-keyword-face))
75 ;; Variable type setting
76 ("^\\(set\\)\\s-+\\(\\w+\\)\\s-+"
77 (1 font-lock-keyword-face)
78 (2 font-lock-variable-name-face))
79 ("^\\(show\\)\\s-+\\(\\w+\\)\\s-*$"
80 (1 font-lock-keyword-face)
81 (2 font-lock-variable-name-face))
82 ("\\<\\(macro\\)\\s-+\""
83 (1 font-lock-keyword-face))
84 ;; Context type setting
85 ("^\\(context\\)\\s-+\\(\\w+\\)"
86 (1 font-lock-keyword-face)
87 (2 font-lock-builtin-face))
88 ;; Prompting setting
89 ("^\\(prompt\\)\\s-+\\(\\w+\\)"
90 (1 font-lock-keyword-face)
91 (2 font-lock-variable-name-face))
92 ("\\(default\\(macro\\)?\\)\\s-+\\(\\(\\w\\|\\s_\\)+\\)"
93 (1 font-lock-keyword-face)
94 (3 font-lock-type-face))
95 ("\\<\\(default\\(macro\\)?\\)\\>" (1 font-lock-keyword-face))
96 ("\\<\\(read\\)\\s-+\\(\\(\\w\\|\\s_\\)+\\)"
97 (1 font-lock-keyword-face)
98 (2 font-lock-type-face))
99
100 ;; Macro separators
101 ("^----\n" 0 'srecode-separator-face)
102
103 ;; Macro Matching
104 (srecode-template-mode-macro-escape-match 1 font-lock-string-face)
105 ((lambda (limit)
106 (srecode-template-mode-font-lock-macro-helper
107 limit "\\(\\??\\w+\\)[^ \t\n{}$#@&*()]*"))
108 1 font-lock-variable-name-face)
109 ((lambda (limit)
110 (srecode-template-mode-font-lock-macro-helper
111 limit "\\([#/]\\w+\\)[^ \t\n{}$#@&*()]*"))
112 1 font-lock-keyword-face)
113 ((lambda (limit)
114 (srecode-template-mode-font-lock-macro-helper
115 limit "\\([<>]\\w*\\):\\(\\w+\\):\\(\\w+\\)"))
116 (1 font-lock-keyword-face)
117 (2 font-lock-builtin-face)
118 (3 font-lock-type-face))
119 ((lambda (limit)
120 (srecode-template-mode-font-lock-macro-helper
121 limit "\\([<>?]?\\w*\\):\\(\\w+\\)"))
122 (1 font-lock-keyword-face)
123 (2 font-lock-type-face))
124 ((lambda (limit)
125 (srecode-template-mode-font-lock-macro-helper
126 limit "!\\([^{}$]*\\)"))
127 1 font-lock-comment-face)
128
129 )
130 "Keywords for use with srecode macros and font-lock.")
131
132(defun srecode-template-mode-font-lock-macro-helper (limit expression)
133 "Match against escape characters.
134Don't scan past LIMIT. Match with EXPRESSION."
135 (let* ((done nil)
136 (md nil)
137 (es (regexp-quote (srecode-template-get-escape-start)))
138 (ee (regexp-quote (srecode-template-get-escape-end)))
139 (regex (concat es expression ee))
140 )
141 (while (not done)
142 (save-match-data
143 (if (re-search-forward regex limit t)
144 (when (equal (car (srecode-calculate-context)) "code")
145 (setq md (match-data)
146 done t))
147 (setq done t))))
148 (set-match-data md)
149 ;; (when md (message "Found a match!"))
150 (when md t)))
151
152(defun srecode-template-mode-macro-escape-match (limit)
153 "Match against escape characters.
154Don't scan past LIMIT."
155 (let* ((done nil)
156 (md nil)
157 (es (regexp-quote (srecode-template-get-escape-start)))
158 (ee (regexp-quote (srecode-template-get-escape-end)))
159 (regex (concat "\\(" es "\\|" ee "\\)"))
160 )
161 (while (not done)
162 (save-match-data
163 (if (re-search-forward regex limit t)
164 (when (equal (car (srecode-calculate-context)) "code")
165 (setq md (match-data)
166 done t))
167 (setq done t))))
168 (set-match-data md)
169 ;;(when md (message "Found a match!"))
170 (when md t)))
171
172(defvar srecode-font-lock-macro-keywords nil
173 "Dynamically generated `font-lock' keywords for srecode templates.
174Once the escape_start, and escape_end sequences are known, then
175we can tell font lock about them.")
176
177(defvar srecode-template-mode-map
178 (let ((km (make-sparse-keymap)))
179 (define-key km "\C-c\C-c" 'srecode-compile-templates)
180 (define-key km "\C-c\C-m" 'srecode-macro-help)
181 (define-key km "/" 'srecode-self-insert-complete-end-macro)
182 km)
183 "Keymap used in srecode mode.")
184
185;;;###autoload
186(defun srecode-template-mode ()
187 "Major-mode for writing srecode macros."
188 (interactive)
189 (kill-all-local-variables)
190 (setq major-mode 'srecode-template-mode
191 mode-name "SRecoder"
192 comment-start ";;"
193 comment-end "")
194 (set (make-local-variable 'parse-sexp-ignore-comments) t)
195 (set (make-local-variable 'comment-start-skip)
196 "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *")
197 (set-syntax-table srecode-template-mode-syntax-table)
198 (use-local-map srecode-template-mode-map)
199 (set (make-local-variable 'font-lock-defaults)
200 '(srecode-font-lock-keywords
201 nil ;; perform string/comment fontification
202 nil ;; keywords are case sensitive.
203 ;; This puts _ & - as a word constituant,
204 ;; simplifying our keywords significantly
205 ((?_ . "w") (?- . "w"))))
206 (run-hooks 'srecode-template-mode-hook))
207
208;;;###autoload
209(defalias 'srt-mode 'srecode-template-mode)
210
211;;; Template Commands
212;;
213(defun srecode-self-insert-complete-end-macro ()
214 "Self insert the current key, then autocomplete the end macro."
215 (interactive)
216 (call-interactively 'self-insert-command)
217 (when (and (semantic-current-tag)
218 (semantic-tag-of-class-p (semantic-current-tag) 'function)
219 )
220 (let* ((es (srecode-template-get-escape-start))
221 (ee (srecode-template-get-escape-end))
222 (name (save-excursion
223 (forward-char (- (length es)))
224 (forward-char -1)
225 (if (looking-at (regexp-quote es))
226 (srecode-up-context-get-name (point) t))))
227 )
228 (when name
229 (insert name)
230 (insert ee))))
231 )
232
233
234(defun srecode-macro-help ()
235 "Provide help for working with macros in a tempalte."
236 (interactive)
237 (let* ((root 'srecode-template-inserter)
238 (chl (aref (class-v root) class-children))
239 (ess (srecode-template-get-escape-start))
240 (ees (srecode-template-get-escape-end))
241 )
242 (with-output-to-temp-buffer "*SRecode Macros*"
243 (princ "Description of known SRecode Template Macros.")
244 (terpri)
245 (terpri)
246 (while chl
247 (let* ((C (car chl))
248 (name (symbol-name C))
249 (key (when (slot-exists-p C 'key)
250 (oref C key)))
251 (showexample t)
252 )
253 (setq chl (cdr chl))
254 (setq chl (append (aref (class-v C) class-children) chl))
255
256 (catch 'skip
257 (when (eq C 'srecode-template-inserter-section-end)
258 (throw 'skip nil))
259
260 (when (class-abstract-p C)
261 (throw 'skip nil))
262
263 (princ "`")
264 (princ name)
265 (princ "'")
266 (when (slot-exists-p C 'key)
267 (when key
268 (princ " - Character Key: ")
269 (if (stringp key)
270 (progn
271 (setq showexample nil)
272 (cond ((string= key "\n")
273 (princ "\"\\n\"")
274 )
275 (t
276 (prin1 key)
277 )))
278 (prin1 (format "%c" key))
279 )))
280 (terpri)
281 (princ (documentation-property C 'variable-documentation))
282 (terpri)
283 (when showexample
284 (princ "Example:")
285 (terpri)
286 (srecode-inserter-prin-example C ess ees)
287 )
288
289 (terpri)
290
291 ) ;; catch
292 );; let*
293 ))))
294
295
296;;; Misc Language Overrides
297;;
298(define-mode-local-override semantic-ia-insert-tag
299 srecode-template-mode (tag)
300 "Insert the SRecode TAG into the current buffer."
301 (insert (semantic-tag-name tag)))
302
303
304;;; Local Context Parsing.
305
306(defun srecode-in-macro-p (&optional point)
307 "Non-nil if POINT is inside a macro bounds.
308If the ESCAPE_START and END are different sequences,
309a simple search is used. If ESCAPE_START and END are the same
310characteres, start at the beginning of the line, and find out
311how many occur."
312 (let ((tag (semantic-current-tag))
313 (es (regexp-quote (srecode-template-get-escape-start)))
314 (ee (regexp-quote (srecode-template-get-escape-end)))
315 (start (or point (point)))
316 )
317 (when (and tag (semantic-tag-of-class-p tag 'function))
318 (if (string= es ee)
319 (save-excursion
320 (beginning-of-line)
321 (while (re-search-forward es start t 2))
322 (if (re-search-forward es start t)
323 ;; If there is a single, the the answer is yes.
324 t
325 ;; If there wasn't another, then the answer is no.
326 nil)
327 )
328 ;; ES And EE are not the same.
329 (save-excursion
330 (and (re-search-backward es (semantic-tag-start tag) t)
331 (>= (or (re-search-forward ee (semantic-tag-end tag) t)
332 ;; No end match means an incomplete macro.
333 start)
334 start)))
335 ))))
336
337(defun srecode-up-context-get-name (&optional point find-unmatched)
338 "Move up one context as for `semantic-up-context', and return the name.
339Moves point to the opening characters of the section macro text.
340If there is no upper context, return nil.
341Starts at POINT if provided.
342If FIND-UNMATCHED is specified as non-nil, then we are looking for an unmatched
343section."
344 (when point (goto-char (point)))
345 (let* ((tag (semantic-current-tag))
346 (es (regexp-quote (srecode-template-get-escape-start)))
347 (start (concat es "[#<]\\(\\w+\\)"))
348 (orig (point))
349 (name nil)
350 (res nil))
351 (when (semantic-tag-of-class-p tag 'function)
352 (while (and (not res)
353 (re-search-backward start (semantic-tag-start tag) t))
354 (when (save-excursion
355 (setq name (match-string 1))
356 (let ((endr (concat es "/" name)))
357 (if (re-search-forward endr (semantic-tag-end tag) t)
358 (< orig (point))
359 (if (not find-unmatched)
360 (error "Unmatched Section Template")
361 ;; We found what we want.
362 t))))
363 (setq res (point)))
364 )
365 ;; Restore in no result found.
366 (goto-char (or res orig))
367 name)))
368
369(define-mode-local-override semantic-up-context
370 srecode-template-mode (&optional point)
371 "Move up one context in the current code.
372Moves out one named section."
373 (not (srecode-up-context-get-name point)))
374
375(define-mode-local-override semantic-beginning-of-context
376 srecode-template-mode (&optional point)
377 "Move to the beginning of the current context.
378Moves the the beginning of one named section."
379 (if (semantic-up-context point)
380 t
381 (let ((es (regexp-quote (srecode-template-get-escape-start)))
382 (ee (regexp-quote (srecode-template-get-escape-end))))
383 (re-search-forward es) ;; move over the start chars.
384 (re-search-forward ee) ;; Move after the end chars.
385 nil)))
386
387(define-mode-local-override semantic-end-of-context
388 srecode-template-mode (&optional point)
389 "Move to the beginning of the current context.
390Moves the the beginning of one named section."
391 (let ((name (srecode-up-context-get-name point))
392 (tag (semantic-current-tag))
393 (es (regexp-quote (srecode-template-get-escape-start))))
394 (if (not name)
395 t
396 (unless (re-search-forward (concat es "/" name) (semantic-tag-end tag) t)
397 (error "Section %s has no end" name))
398 (goto-char (match-beginning 0))
399 nil)))
400
401(define-mode-local-override semantic-get-local-variables
402 srecode-template-mode (&optional point)
403 "Get local variables from an SRecode template."
404 (save-excursion
405 (when point (goto-char (point)))
406 (let* ((tag (semantic-current-tag))
407 (name (save-excursion
408 (srecode-up-context-get-name (point))))
409 (subdicts (semantic-tag-get-attribute tag :dictionaries))
410 (global nil)
411 )
412 (dolist (D subdicts)
413 (setq global (cons (semantic-tag-new-variable (car D) nil)
414 global)))
415 (if name
416 ;; Lookup any subdictionaries in TAG.
417 (let ((res nil))
418
419 (while (and (not res) subdicts)
420 ;; Find the subdictionary with the same name. Those variables
421 ;; are now local to this section.
422 (when (string= (car (car subdicts)) name)
423 (setq res (cdr (car subdicts))))
424 (setq subdicts (cdr subdicts)))
425 ;; Pre-pend our global vars.
426 (append global res))
427 ;; If we aren't in a subsection, just do the global variables
428 global
429 ))))
430
431(define-mode-local-override semantic-get-local-arguments
432 srecode-template-mode (&optional point)
433 "Get local arguments from an SRecode template."
434 (require 'srecode/insert)
435 (save-excursion
436 (when point (goto-char (point)))
437 (let* ((tag (semantic-current-tag))
438 (args (semantic-tag-function-arguments tag))
439 (argsym (mapcar 'intern args))
440 (argvars nil)
441 ;; Create a temporary dictionary in which the
442 ;; arguments can be resolved so we can extract
443 ;; the results.
444 (dict (srecode-create-dictionary t))
445 )
446 ;; Resolve args into our temp dictionary
447 (srecode-resolve-argument-list argsym dict)
448
449 (maphash
450 (lambda (key entry)
451 (setq argvars
452 (cons (semantic-tag-new-variable key nil entry)
453 argvars)))
454 (oref dict namehash))
455
456 argvars)))
457
458(define-mode-local-override semantic-ctxt-current-symbol
459 srecode-template-mode (&optional point)
460 "Return the current symbol under POINT.
461Return nil if point is not on/in a template macro."
462 (let ((macro (srecode-parse-this-macro point)))
463 (cdr macro))
464 )
465
466(defun srecode-parse-this-macro (&optional point)
467 "Return the current symbol under POINT.
468Return nil if point is not on/in a template macro.
469The first element is the key for the current macro, such as # for a
470section or ? for an ask variable."
471 (save-excursion
472 (if point (goto-char point))
473 (let ((tag (semantic-current-tag))
474 (es (regexp-quote (srecode-template-get-escape-start)))
475 (ee (regexp-quote (srecode-template-get-escape-end)))
476 (start (point))
477 (macrostart nil)
478 (raw nil)
479 )
480 (when (and tag (semantic-tag-of-class-p tag 'function)
481 (srecode-in-macro-p point)
482 (re-search-backward es (semantic-tag-start tag) t))
483 (setq macrostart (match-end 0))
484 (goto-char macrostart)
485 ;; We have a match
486 (when (not (re-search-forward ee (semantic-tag-end tag) t))
487 (goto-char start) ;; Pretend we are ok for completion
488 (set-match-data (list start start))
489 )
490
491 (if (> start (point))
492 ;; If our starting point is after the found point, that
493 ;; means we are not inside the macro. Retur nil.
494 nil
495 ;; We are inside the macro, extract the text so far.
496 (let* ((macroend (match-beginning 0))
497 (raw (buffer-substring-no-properties
498 macrostart macroend))
499 (STATE (srecode-compile-state "TMP"))
500 (inserter (condition-case nil
501 (srecode-compile-parse-inserter
502 raw STATE)
503 (error nil)))
504 )
505 (when inserter
506 (let ((base
507 (cons (oref inserter :object-name)
508 (if (and (slot-boundp inserter :secondname)
509 (oref inserter :secondname))
510 (split-string (oref inserter :secondname)
511 ":")
512 nil)))
513 (key (oref inserter key)))
514 (cond ((null key)
515 ;; A plain variable
516 (cons nil base))
517 (t
518 ;; A complex variable thingy.
519 (cons (format "%c" key)
520 base)))))
521 )
522 )))
523 ))
524
525(define-mode-local-override semantic-analyze-current-context
526 srecode-template-mode (point)
527 "Provide a Semantic analysis in SRecode template mode."
528 (let* ((context-return nil)
529 (prefixandbounds (semantic-ctxt-current-symbol-and-bounds))
530 (prefix (car prefixandbounds))
531 (bounds (nth 2 prefixandbounds))
532 (key (car (srecode-parse-this-macro (point))))
533 (prefixsym nil)
534 (prefix-var nil)
535 (prefix-context nil)
536 (prefix-function nil)
537 (prefixclass (semantic-ctxt-current-class-list))
538 (globalvar (semantic-find-tags-by-class 'variable (current-buffer)))
539 (argtype 'macro)
540 (scope (semantic-calculate-scope point))
541 )
542
543 (oset scope fullscope (append (oref scope localvar) globalvar))
544
545 (when prefix
546 ;; First, try to find the variable for the first
547 ;; entry in the prefix list.
548 (setq prefix-var (semantic-find-first-tag-by-name
549 (car prefix) (oref scope fullscope)))
550
551 (cond
552 ((and (or (not key) (string= key "?"))
553 (> (length prefix) 1))
554 ;; Variables can have lisp function names.
555 (with-mode-local emacs-lisp-mode
556 (let ((fcns (semanticdb-find-tags-by-name (car (last prefix)))))
557 (setq prefix-function (car (semanticdb-find-result-nth fcns 0)))
558 (setq argtype 'elispfcn)))
559 )
560 ((or (string= key "<") (string= key ">"))
561 ;; Includes have second args that is the template name.
562 (if (= (length prefix) 3)
563 (let ((contexts (semantic-find-tags-by-class
564 'context (current-buffer))))
565 (setq prefix-context
566 (or (semantic-find-first-tag-by-name
567 (nth 1 prefix) contexts)
568 ;; Calculate from location
569 (semantic-tag
570 (symbol-name
571 (srecode-template-current-context))
572 'context)))
573 (setq argtype 'template))
574 (setq prefix-context
575 ;; Calculate from location
576 (semantic-tag
577 (symbol-name (srecode-template-current-context))
578 'context))
579 (setq argtype 'template)
580 )
581 ;; The last one?
582 (when (> (length prefix) 1)
583 (let ((toc (srecode-template-find-templates-of-context
584 (read (semantic-tag-name prefix-context))))
585 )
586 (setq prefix-function
587 (or (semantic-find-first-tag-by-name
588 (car (last prefix)) toc)
589 ;; Not in this buffer? Search the master
590 ;; templates list.
591 nil))
592 ))
593 )
594 )
595
596 (setq prefixsym
597 (cond ((= (length prefix) 3)
598 (list (or prefix-var (nth 0 prefix))
599 (or prefix-context (nth 1 prefix))
600 (or prefix-function (nth 2 prefix))))
601 ((= (length prefix) 2)
602 (list (or prefix-var (nth 0 prefix))
603 (or prefix-function (nth 1 prefix))))
604 ((= (length prefix) 1)
605 (list (or prefix-var (nth 0 prefix)))
606 )))
607
608 (setq context-return
609 (semantic-analyze-context-functionarg
610 "context-for-srecode"
611 :buffer (current-buffer)
612 :scope scope
613 :bounds bounds
614 :prefix (or prefixsym
615 prefix)
616 :prefixtypes nil
617 :prefixclass prefixclass
618 :errors nil
619 ;; Use the functionarg analyzer class so we
620 ;; can save the current key, and the index
621 ;; into the macro part we are completing on.
622 :function (list key)
623 :index (length prefix)
624 :argument (list argtype)
625 ))
626
627 context-return)))
628
629(define-mode-local-override semantic-analyze-possible-completions
630 srecode-template-mode (context)
631 "Return a list of possible completions based on NONTEXT."
632 (save-excursion
633 (set-buffer (oref context buffer))
634 (let* ((prefix (car (last (oref context :prefix))))
635 (prefixstr (cond ((stringp prefix)
636 prefix)
637 ((semantic-tag-p prefix)
638 (semantic-tag-name prefix))))
639; (completetext (cond ((semantic-tag-p prefix)
640; (semantic-tag-name prefix))
641; ((stringp prefix)
642; prefix)
643; ((stringp (car prefix))
644; (car prefix))))
645 (argtype (car (oref context :argument)))
646 (matches nil))
647
648 ;; Depending on what the analyzer is, we have different ways
649 ;; of creating completions.
650 (cond ((eq argtype 'template)
651 (setq matches (semantic-find-tags-for-completion
652 prefixstr (current-buffer)))
653 (setq matches (semantic-find-tags-by-class
654 'function matches))
655 )
656 ((eq argtype 'elispfcn)
657 (with-mode-local emacs-lisp-mode
658 (setq matches (semanticdb-find-tags-for-completion
659 prefixstr))
660 (setq matches (semantic-find-tags-by-class
661 'function matches))
662 )
663 )
664 ((eq argtype 'macro)
665 (let ((scope (oref context scope)))
666 (setq matches
667 (semantic-find-tags-for-completion
668 prefixstr (oref scope fullscope))))
669 )
670 )
671
672 matches)))
673
674
675
676;;; Utils
677;;
678(defun srecode-template-get-mode ()
679 "Get the supported major mode for this template file."
680 (let ((m (semantic-find-first-tag-by-name "mode" (current-buffer))))
681 (when m (read (semantic-tag-variable-default m)))))
682
683(defun srecode-template-get-escape-start ()
684 "Get the current escape_start characters."
685 (let ((es (semantic-find-first-tag-by-name "escape_start" (current-buffer)))
686 )
687 (if es (car (semantic-tag-get-attribute es :default-value))
688 "{{")))
689
690(defun srecode-template-get-escape-end ()
691 "Get the current escape_end characters."
692 (let ((ee (semantic-find-first-tag-by-name "escape_end" (current-buffer)))
693 )
694 (if ee (car (semantic-tag-get-attribute ee :default-value))
695 "}}")))
696
697(defun srecode-template-current-context (&optional point)
698 "Calculate the context encompassing POINT."
699 (save-excursion
700 (when point (goto-char (point)))
701 (let ((ct (semantic-current-tag)))
702 (when (not ct)
703 (setq ct (semantic-find-tag-by-overlay-prev)))
704
705 ;; Loop till we find the context.
706 (while (and ct (not (semantic-tag-of-class-p ct 'context)))
707 (setq ct (semantic-find-tag-by-overlay-prev
708 (semantic-tag-start ct))))
709
710 (if ct
711 (read (semantic-tag-name ct))
712 'declaration))))
713
714(defun srecode-template-find-templates-of-context (context &optional buffer)
715 "Find all the templates belonging to a particular CONTEXT.
716When optional BUFFER is provided, search that buffer."
717 (save-excursion
718 (when buffer (set-buffer buffer))
719 (let ((tags (semantic-fetch-available-tags))
720 (cc 'declaration)
721 (scan nil)
722 (ans nil))
723
724 (when (eq cc context)
725 (setq scan t))
726
727 (dolist (T tags)
728 ;; Handle contexts
729 (when (semantic-tag-of-class-p T 'context)
730 (setq cc (read (semantic-tag-name T)))
731 (when (eq cc context)
732 (setq scan t)))
733
734 ;; Scan
735 (when (and scan (semantic-tag-of-class-p T 'function))
736 (setq ans (cons T ans)))
737 )
738
739 (nreverse ans))))
740
741
742;;; MMM-Mode support ??
743;;(condition-case nil
744;; (require 'mmm-mode)
745;; (error (message "SRecoder Template Mode: No multi-mode not support.")))
746;;
747;;(defun srecode-template-add-submode ()
748;; "Add a submode to the current template file using mmm-mode.
749;;If mmm-mode isn't available, then do nothing."
750;; (if (not (featurep 'mmm-mode))
751;; nil ;; Nothing to do.
752;; ;; Else, set up mmm-mode in this buffer.
753;; (let ((submode (semantic-find-tags-by-name "mode")))
754;; (if (not submode)
755;; nil ;; Nothing to do.
756;; ;; Well, we have a mode, lets try turning on mmm-mode.
757;;
758;; ;; (mmm-mode-on)
759;;
760;;
761;;
762;; ))))
763;;
764
765(provide 'srecode/srt-mode)
766
767;; The autoloads in this file must go into the global loaddefs.el, not
768;; the srecode one, so that srecode-template-mode can be called from
769;; auto-mode-alist.
770
771;; Local variables:
772;; generated-autoload-load-name: "srecode/srt-mode"
773;; End:
774
775;;; srecode/srt-mode.el ends here
diff --git a/lisp/cedet/srecode/srt-wy.el b/lisp/cedet/srecode/srt-wy.el
new file mode 100644
index 00000000000..4446a66afca
--- /dev/null
+++ b/lisp/cedet/srecode/srt-wy.el
@@ -0,0 +1,277 @@
1;;; srecode/srt-wy.el --- Generated parser support file
2
3;; Copyright (C) 2005, 2007, 2008, 2009 Free Software Foundation, Inc.
4
5;; This file is part of GNU Emacs.
6
7;; GNU Emacs is free software: you can redistribute it and/or modify
8;; it under the terms of the GNU General Public License as published by
9;; the Free Software Foundation, either version 3 of the License, or
10;; (at your option) any later version.
11
12;; GNU Emacs is distributed in the hope that it will be useful,
13;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;; GNU General Public License for more details.
16
17;; You should have received a copy of the GNU General Public License
18;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
19
20;;; Commentary:
21
22;; Generated from srecode-template.wy in the CEDET repository.
23
24;;; Code:
25
26(require 'semantic/lex)
27
28
29;;; Prologue
30;;
31
32;;; Declarations
33;;
34(defconst srecode-template-wy--keyword-table
35 (semantic-lex-make-keyword-table
36 '(("set" . SET)
37 ("show" . SHOW)
38 ("macro" . MACRO)
39 ("context" . CONTEXT)
40 ("template" . TEMPLATE)
41 ("sectiondictionary" . SECTIONDICTIONARY)
42 ("prompt" . PROMPT)
43 ("default" . DEFAULT)
44 ("defaultmacro" . DEFAULTMACRO)
45 ("read" . READ)
46 ("bind" . BIND))
47 '(("bind" summary "bind \"<letter>\"")
48 ("read" summary "prompt <symbol> \"Describe Symbol: \" [default[macro] <lispsym>|\"valuetext\"] [read <lispsym>]")
49 ("defaultmacro" summary "prompt <symbol> \"Describe Symbol: \" [default[macro] <lispsym>|\"valuetext\"] [read <lispsym>]")
50 ("default" summary "prompt <symbol> \"Describe Symbol: \" [default[macro] <lispsym>|\"valuetext\"] [read <lispsym>]")
51 ("prompt" summary "prompt <symbol> \"Describe Symbol: \" [default[macro] <lispsym>|\"valuetext\"] [read <lispsym>]")
52 ("sectiondictionary" summary "sectiondictionary <name>\\n <dictionary entries>")
53 ("template" summary "template <name>\\n <template definition>")
54 ("context" summary "context <name>")
55 ("macro" summary "... macro \"string\" ...")
56 ("show" summary "show <name> ; to show a section")
57 ("set" summary "set <name> <value>")))
58 "Table of language keywords.")
59
60(defconst srecode-template-wy--token-table
61 (semantic-lex-make-type-table
62 '(("number"
63 (number))
64 ("string"
65 (string))
66 ("symbol"
67 (symbol))
68 ("property"
69 (property))
70 ("separator"
71 (TEMPLATE_BLOCK . "^----"))
72 ("newline"
73 (newline)))
74 '(("number" :declared t)
75 ("string" :declared t)
76 ("symbol" :declared t)
77 ("property" :declared t)
78 ("newline" :declared t)
79 ("punctuation" syntax "\\s.+")
80 ("punctuation" :declared t)
81 ("keyword" :declared t)))
82 "Table of lexical tokens.")
83
84(defconst srecode-template-wy--parse-table
85 (progn
86 (eval-when-compile
87 (require 'semantic/wisent/comp))
88 (wisent-compile-grammar
89 '((SET SHOW MACRO CONTEXT TEMPLATE SECTIONDICTIONARY PROMPT DEFAULT DEFAULTMACRO READ BIND newline TEMPLATE_BLOCK property symbol string number)
90 nil
91 (template_file
92 ((newline)
93 nil)
94 ((context))
95 ((prompt))
96 ((variable))
97 ((template)))
98 (context
99 ((CONTEXT symbol newline)
100 (wisent-raw-tag
101 (semantic-tag $2 'context))))
102 (prompt
103 ((PROMPT symbol string opt-default-fcn opt-read-fcn newline)
104 (wisent-raw-tag
105 (semantic-tag $2 'prompt :text
106 (read $3)
107 :default $4 :read $5))))
108 (opt-default-fcn
109 ((DEFAULT symbol)
110 (progn
111 (read $2)))
112 ((DEFAULT string)
113 (progn
114 (read $2)))
115 ((DEFAULTMACRO string)
116 (progn
117 (cons 'macro
118 (read $2))))
119 (nil nil))
120 (opt-read-fcn
121 ((READ symbol)
122 (progn
123 (read $2)))
124 (nil nil))
125 (variable
126 ((SET symbol insertable-string-list newline)
127 (wisent-raw-tag
128 (semantic-tag-new-variable $2 nil $3)))
129 ((SHOW symbol newline)
130 (wisent-raw-tag
131 (semantic-tag-new-variable $2 nil t))))
132 (insertable-string-list
133 ((insertable-string)
134 (list $1))
135 ((insertable-string-list insertable-string)
136 (append $1
137 (list $2))))
138 (insertable-string
139 ((string)
140 (read $1))
141 ((MACRO string)
142 (cons 'macro
143 (read $2))))
144 (template
145 ((TEMPLATE templatename opt-dynamic-arguments newline opt-string opt-section-dictionaries TEMPLATE_BLOCK newline opt-bind)
146 (wisent-raw-tag
147 (semantic-tag-new-function $2 nil $3 :documentation $5 :code $7 :dictionaries $6 :binding $9))))
148 (templatename
149 ((symbol))
150 ((PROMPT))
151 ((CONTEXT))
152 ((TEMPLATE))
153 ((DEFAULT))
154 ((MACRO))
155 ((DEFAULTMACRO))
156 ((READ))
157 ((SET)))
158 (opt-dynamic-arguments
159 ((property opt-dynamic-arguments)
160 (cons $1 $2))
161 (nil nil))
162 (opt-string
163 ((string newline)
164 (read $1))
165 (nil nil))
166 (opt-section-dictionaries
167 (nil nil)
168 ((section-dictionary-list)))
169 (section-dictionary-list
170 ((one-section-dictionary)
171 (list $1))
172 ((section-dictionary-list one-section-dictionary)
173 (append $1
174 (list $2))))
175 (one-section-dictionary
176 ((SECTIONDICTIONARY string newline variable-list)
177 (cons
178 (read $2)
179 $4)))
180 (variable-list
181 ((variable)
182 (wisent-cook-tag $1))
183 ((variable-list variable)
184 (append $1
185 (wisent-cook-tag $2))))
186 (opt-bind
187 ((BIND string newline)
188 (read $2))
189 (nil nil)))
190 '(template_file)))
191 "Parser table.")
192
193(defun srecode-template-wy--install-parser ()
194 "Setup the Semantic Parser."
195 (semantic-install-function-overrides
196 '((parse-stream . wisent-parse-stream)))
197 (setq semantic-parser-name "LALR"
198 semantic--parse-table srecode-template-wy--parse-table
199 semantic-debug-parser-source "srecode-template.wy"
200 semantic-flex-keywords-obarray srecode-template-wy--keyword-table
201 semantic-lex-types-obarray srecode-template-wy--token-table)
202 ;; Collect unmatched syntax lexical tokens
203 (semantic-make-local-hook 'wisent-discarding-token-functions)
204 (add-hook 'wisent-discarding-token-functions
205 'wisent-collect-unmatched-syntax nil t))
206
207
208;;; Analyzers
209;;
210(define-lex-keyword-type-analyzer srecode-template-wy--<keyword>-keyword-analyzer
211 "keyword analyzer for <keyword> tokens."
212 "\\(\\sw\\|\\s_\\)+")
213
214(define-lex-regex-type-analyzer srecode-template-wy--<symbol>-regexp-analyzer
215 "regexp analyzer for <symbol> tokens."
216 "\\(\\sw\\|\\s_\\)+"
217 nil
218 'symbol)
219
220(define-lex-sexp-type-analyzer srecode-template-wy--<string>-sexp-analyzer
221 "sexp analyzer for <string> tokens."
222 "\\s\""
223 'string)
224
225(define-lex-regex-type-analyzer srecode-template-wy--<number>-regexp-analyzer
226 "regexp analyzer for <number> tokens."
227 semantic-lex-number-expression
228 nil
229 'number)
230
231(define-lex-string-type-analyzer srecode-template-wy--<punctuation>-string-analyzer
232 "string analyzer for <punctuation> tokens."
233 "\\s.+"
234 nil
235 'punctuation)
236
237
238;;; Epilogue
239;;
240(define-lex-simple-regex-analyzer srecode-template-property-analyzer
241 "Detect and create a dynamic argument properties."
242 ":\\(\\w\\|\\s_\\)*" 'property 0)
243
244(define-lex-regex-analyzer srecode-template-separator-block
245 "Detect and create a template quote block."
246 "^----\n"
247 (semantic-lex-push-token
248 (semantic-lex-token
249 'TEMPLATE_BLOCK
250 (match-end 0)
251 (semantic-lex-unterminated-syntax-protection 'TEMPLATE_BLOCK
252 (goto-char (match-end 0))
253 (re-search-forward "^----$")
254 (match-beginning 0))))
255 (setq semantic-lex-end-point (point)))
256
257
258(define-lex wisent-srecode-template-lexer
259 "Lexical analyzer that handles SRecode Template buffers.
260It ignores whitespace, newlines and comments."
261 semantic-lex-newline
262 semantic-lex-ignore-whitespace
263 semantic-lex-ignore-newline
264 semantic-lex-ignore-comments
265 srecode-template-separator-block
266 srecode-template-wy--<keyword>-keyword-analyzer
267 srecode-template-property-analyzer
268 srecode-template-wy--<symbol>-regexp-analyzer
269 srecode-template-wy--<number>-regexp-analyzer
270 srecode-template-wy--<string>-sexp-analyzer
271 srecode-template-wy--<punctuation>-string-analyzer
272 semantic-lex-default-action
273 )
274
275(provide 'srecode/srt-wy)
276
277;;; srecode/srt-wy.el ends here
diff --git a/lisp/cedet/srecode/srt.el b/lisp/cedet/srecode/srt.el
new file mode 100644
index 00000000000..7f438ae5951
--- /dev/null
+++ b/lisp/cedet/srecode/srt.el
@@ -0,0 +1,106 @@
1;;; srecode/srt.el --- argument handlers for SRT files
2
3;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <eric@siege-engine.com>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;
24;; Filters for SRT files, the Semantic Recoder template files.
25
26;;; Code:
27
28(require 'eieio)
29(require 'srecode/dictionary)
30(require 'srecode/insert)
31
32(defvar srecode-read-variable-name-history nil
33 "History for `srecode-read-variable-name'.")
34
35(defun srecode-read-variable-name (prompt &optional initial hist default)
36 "Read in the name of a declaired variable in the current SRT file.
37PROMPT is the prompt to use.
38INITIAL is the initial string.
39HIST is the history value, otherwise `srecode-read-variable-name-history'
40 is used.
41DEFAULT is the default if RET is hit."
42 (let* ((newdict (srecode-create-dictionary))
43 (currfcn (semantic-current-tag))
44 )
45 (srecode-resolve-argument-list
46 (mapcar 'read
47 (semantic-tag-get-attribute currfcn :arguments))
48 newdict)
49
50 (with-slots (namehash) newdict
51 (completing-read prompt namehash nil nil initial
52 (or hist 'srecode-read-variable-name-history)
53 default))
54 ))
55
56(defvar srecode-read-major-mode-history nil
57 "History for `srecode-read-variable-name'.")
58
59(defun srecode-read-major-mode-name (prompt &optional initial hist default)
60 "Read in the name of a desired `major-mode'.
61PROMPT is the prompt to use.
62INITIAL is the initial string.
63HIST is the history value, otherwise `srecode-read-variable-name-history'
64 is used.
65DEFAULT is the default if RET is hit."
66 (completing-read prompt obarray
67 (lambda (s) (string-match "-mode$" (symbol-name s)))
68 nil initial (or hist 'srecode-read-major-mode-history))
69 )
70
71(defun srecode-semantic-handle-:srt (dict)
72 "Add macros into the dictionary DICT based on the current SRT file.
73Adds the following:
74ESCAPE_START - This files value of escape_start
75ESCAPE_END - This files value of escape_end
76MODE - The mode of this buffer. If not declared yet, guess."
77 (let* ((es (semantic-find-first-tag-by-name "escape_start" (current-buffer)))
78 (ee (semantic-find-first-tag-by-name "escape_end" (current-buffer)))
79 (mode-var (semantic-find-first-tag-by-name "mode" (current-buffer)))
80 (mode (if mode-var
81 (semantic-tag-variable-default mode-var)
82 nil))
83 )
84 (srecode-dictionary-set-value dict "ESCAPE_START"
85 (if es
86 (car (semantic-tag-variable-default es))
87 "{{"))
88 (srecode-dictionary-set-value dict "ESCAPE_END"
89 (if ee
90 (car (semantic-tag-variable-default ee))
91 "}}"))
92 (when (not mode)
93 (let* ((fname (file-name-nondirectory
94 (buffer-file-name (current-buffer))))
95 )
96 (when (string-match "-\\(\\w+\\)\\.srt" fname)
97 (setq mode (concat (match-string 1 fname) "-mode")))))
98
99 (when mode
100 (srecode-dictionary-set-value dict "MAJORMODE" mode))
101
102 ))
103
104(provide 'srecode/srt)
105
106;;; srecode/srt.el ends here
diff --git a/lisp/cedet/srecode/table.el b/lisp/cedet/srecode/table.el
new file mode 100644
index 00000000000..2591983c7a6
--- /dev/null
+++ b/lisp/cedet/srecode/table.el
@@ -0,0 +1,248 @@
1;;; srecode/table.el --- Tables of Semantic Recoders
2
3;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <eric@siege-engine.com>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;
24;; Semantic Recoder tables manage lists of templates and the major
25;; modes they are associated with.
26;;
27
28(require 'eieio)
29(require 'eieio-base)
30(require 'mode-local)
31(require 'srecode)
32
33(declare-function srecode-load-tables-for-mode "srecode/find")
34
35;;; Code:
36
37;;; TEMPLATE TABLE
38;;
39(defclass srecode-template-table ()
40 (;;
41 ;; Raw file tracking
42 ;;
43 (file :initarg :file
44 :type string
45 :documentation
46 "The name of the file this table was built from.")
47 (filesize :initarg :filesize
48 :type number
49 :documentation
50 "The size of the file when it was parsed.")
51 (filedate :initarg :filedate
52 :type cons
53 :documentation
54 "Date from the inode of the file when it was last edited.
55Format is from the `file-attributes' function.")
56 (major-mode :initarg :major-mode
57 :documentation
58 "The major mode this table of templates is associated with.")
59 ;;
60 ;; Template file sorting data
61 ;;
62 (application :initarg :application
63 :type symbol
64 :documentation
65 "Tracks the name of the application these templates belong to.
66If this is nil, then this template table belongs to a set of generic
67templates that can be used with no additional dictionary values.
68When it is non-nil, it is assumed the template macros need specialized
69Emacs Lisp code to fill in the dictoinary.")
70 (priority :initarg :priority
71 :type number
72 :documentation
73 "For file of this Major Mode, what is the priority of this file.
74When there are multiple template files with similar names, templates with
75the highest priority are scanned last, allowing them to override values in
76previous template files.")
77 ;;
78 ;; Parsed Data from the template file
79 ;;
80 (templates :initarg :templates
81 :type list
82 :documentation
83 "The list of templates compiled into this table.")
84 (namehash :initarg :namehash
85 :documentation
86 "Hash table containing the names of all the templates.")
87 (contexthash :initarg :contexthash
88 :documentation
89 "")
90 (variables :initarg :variables
91 :documentation
92 "AList of variables.
93These variables are used to initialize dictionaries.")
94 )
95 "Semantic recoder template table.
96A Table contains all templates from a single .srt file.
97Tracks various lookup hash tables.")
98
99;;; MODE TABLE
100;;
101(defvar srecode-mode-table-list nil
102 "List of all the SRecode mode table classes that have been built.")
103
104(defclass srecode-mode-table (eieio-instance-tracker)
105 ((tracking-symbol :initform 'srecode-mode-table-list)
106 (major-mode :initarg :major-mode
107 :documentation
108 "Table of template tables for this major-mode.")
109 (tables :initarg :tables
110 :documentation
111 "All the tables that have been defined for this major mode.")
112 )
113 "Track template tables for a particular major mode.
114Tracks all the template-tables for a specific major mode.")
115
116(defun srecode-get-mode-table (mode)
117 "Get the SRecoder mode table for the major mode MODE.
118Optional argument SOFT indicates to not make a new one if a table
119was not found."
120 (let ((ans nil))
121 (while (and (not ans) mode)
122 (setq ans (eieio-instance-tracker-find
123 mode 'major-mode 'srecode-mode-table-list)
124 mode (get-mode-local-parent mode)))
125 ans))
126
127(defun srecode-make-mode-table (mode)
128 "Get the SRecoder mode table for the major mode MODE."
129 (let ((old (eieio-instance-tracker-find
130 mode 'major-mode 'srecode-mode-table-list)))
131 (if old
132 old
133 (let* ((ms (if (stringp mode) mode (symbol-name mode)))
134 (new (srecode-mode-table ms
135 :major-mode mode
136 :tables nil)))
137 ;; Save this new mode table in that mode's variable.
138 (eval `(setq-mode-local ,mode srecode-table ,new))
139
140 new))))
141
142(defmethod srecode-mode-table-find ((mt srecode-mode-table) file)
143 "Look in the mode table MT for a template table from FILE.
144Return nil if there was none."
145 (object-assoc file 'file (oref mt tables)))
146
147(defun srecode-mode-table-new (mode file &rest init)
148 "Create a new template table for MODE in FILE.
149INIT are the initialization parametrs for the new template table."
150 (let* ((mt (srecode-make-mode-table mode))
151 (old (srecode-mode-table-find mt file))
152 (attr (file-attributes file))
153 (new (apply 'srecode-template-table
154 (file-name-nondirectory file)
155 :file file
156 :filesize (nth 7 attr)
157 :filedate (nth 5 attr)
158 :major-mode mode
159 init
160 )))
161 ;; Whack the old table.
162 (when old (object-remove-from-list mt 'tables old))
163 ;; Add the new table
164 (object-add-to-list mt 'tables new)
165 ;; Sort the list in reverse order. When other routines
166 ;; go front-to-back, the highest priority items are put
167 ;; into the search table first, allowing lower priority items
168 ;; to be the items found in the search table.
169 (object-sort-list mt 'tables (lambda (a b)
170 (> (oref a :priority)
171 (oref b :priority))))
172 ;; Return it.
173 new))
174
175(defun object-sort-list (object slot predicate)
176 "Sort the items in OBJECT's SLOT.
177Use PREDICATE is the same as for the `sort' function."
178 (when (slot-boundp object slot)
179 (when (listp (eieio-oref object slot))
180 (eieio-oset object slot (sort (eieio-oref object slot) predicate)))))
181
182;;; DEBUG
183;;
184;; Dump out information about the current srecoder compiled templates.
185;;
186(defun srecode-dump-templates (mode)
187 "Dump a list of the current templates for MODE."
188 (interactive "sMode: ")
189 (require 'srecode/find)
190 (let ((modesym (cond ((string= mode "")
191 major-mode)
192 ((not (string-match "-mode" mode))
193 (intern-soft (concat mode "-mode")))
194 (t
195 (intern-soft mode)))))
196 (srecode-load-tables-for-mode modesym)
197 (let ((tmp (srecode-get-mode-table modesym))
198 )
199 (if (not tmp)
200 (error "No table found for mode %S" modesym))
201 (with-output-to-temp-buffer "*SRECODE DUMP*"
202 (srecode-dump tmp))
203 )))
204
205(defmethod srecode-dump ((tab srecode-mode-table))
206 "Dump the contents of the SRecode mode table TAB."
207 (princ "MODE TABLE FOR ")
208 (princ (oref tab :major-mode))
209 (princ "\n--------------------------------------------\n\nNumber of tables: ")
210 (let ((subtab (oref tab :tables)))
211 (princ (length subtab))
212 (princ "\n\n")
213 (while subtab
214 (srecode-dump (car subtab))
215 (setq subtab (cdr subtab)))
216 ))
217
218(defmethod srecode-dump ((tab srecode-template-table))
219 "Dump the contents of the SRecode template table TAB."
220 (princ "Template Table for ")
221 (princ (object-name-string tab))
222 (princ "\nPriority: ")
223 (prin1 (oref tab :priority))
224 (when (oref tab :application)
225 (princ "\nApplication: ")
226 (princ (oref tab :application)))
227 (princ "\n\nVariables:\n")
228 (let ((vars (oref tab variables)))
229 (while vars
230 (princ (car (car vars)))
231 (princ "\t")
232 (if (< (length (car (car vars))) 9)
233 (princ "\t"))
234 (prin1 (cdr (car vars)))
235 (princ "\n")
236 (setq vars (cdr vars))))
237 (princ "\n\nTemplates:\n")
238 (let ((temp (oref tab templates)))
239 (while temp
240 (srecode-dump (car temp))
241 (setq temp (cdr temp))))
242 )
243
244
245(provide 'srecode/table)
246
247;;; srecode/table.el ends here
248
diff --git a/lisp/cedet/srecode/template.el b/lisp/cedet/srecode/template.el
new file mode 100644
index 00000000000..fee960f5852
--- /dev/null
+++ b/lisp/cedet/srecode/template.el
@@ -0,0 +1,69 @@
1;;; srecode-template.el --- SRecoder template language parser support.
2
3;;; Copyright (C) 2005, 2007, 2008 Free Software Foundation, Inc.
4
5;; This file is part of GNU Emacs.
6
7;; GNU Emacs is free software: you can redistribute it and/or modify
8;; it under the terms of the GNU General Public License as published by
9;; the Free Software Foundation, either version 3 of the License, or
10;; (at your option) any later version.
11
12;; GNU Emacs is distributed in the hope that it will be useful,
13;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;; GNU General Public License for more details.
16
17;; You should have received a copy of the GNU General Public License
18;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
19
20;;; Commentary:
21;;
22;; Parser setup for the semantic recoder template parser.
23
24;;; Code:
25(require 'semantic)
26(require 'semantic/ctxt)
27(require 'semantic/wisent)
28(require 'srecode/srt-wy)
29
30(define-mode-local-override semantic-tag-components
31 srecode-template-mode (tag)
32 "Return sectiondictionary tags."
33 (when (semantic-tag-of-class-p tag 'function)
34 (let ((dicts (semantic-tag-get-attribute tag :dictionaries))
35 (ans nil))
36 (while dicts
37 (setq ans (append ans (cdr (car dicts))))
38 (setq dicts (cdr dicts)))
39 ans)
40 ))
41
42(defun srecode-template-setup-parser ()
43 "Setup buffer for parse."
44 (srecode-template-wy--install-parser)
45
46 (setq
47 ;; Lexical Analysis
48 semantic-lex-analyzer 'wisent-srecode-template-lexer
49 ;; Parsing
50 ;; Environment
51 semantic-imenu-summary-function 'semantic-format-tag-name
52 imenu-create-index-function 'semantic-create-imenu-index
53 semantic-command-separation-character "\n"
54 semantic-lex-comment-regex ";;"
55 ;; Speedbar
56 semantic-symbol->name-assoc-list
57 '((function . "Template")
58 (variable . "Variable")
59 )
60 ;; Navigation
61 senator-step-at-tag-classes '(function variable)
62 ))
63
64;;;;###autoload
65(add-hook 'srecode-template-mode-hook 'srecode-template-setup-parser)
66
67(provide 'srecode/template)
68
69;;; srecode/template.el ends here
diff --git a/lisp/cedet/srecode/texi.el b/lisp/cedet/srecode/texi.el
new file mode 100644
index 00000000000..6c223f1cc5a
--- /dev/null
+++ b/lisp/cedet/srecode/texi.el
@@ -0,0 +1,282 @@
1;;; srecode-texi.el --- Srecode texinfo support.
2
3;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <eric@siege-engine.com>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;
24;; Texinfo semantic recoder support.
25;;
26;; Contains some handlers, and a few simple texinfo srecoder applications.
27
28(require 'semantic)
29(require 'semantic/texi)
30(require 'srecode/semantic)
31
32;;; Code:
33
34(defun srecode-texi-add-menu (newnode)
35 "Add an item into the current menu. Add @node statements as well.
36Argument NEWNODE is the name of the new node."
37 (interactive "sName of new node: ")
38 (srecode-load-tables-for-mode major-mode)
39 (semantic-fetch-tags)
40 (let ((currnode (reverse (semantic-find-tag-by-overlay)))
41 (nodebounds nil))
42 (when (not currnode)
43 (error "Cannot find node to put menu item into"))
44 (setq currnode (car currnode))
45 (setq nodebounds (semantic-tag-texi-section-text-bounds currnode))
46 ;; Step 1:
47 ;; Limit search within this node.
48 ;; Step 2:
49 ;; Find the menu. If there isn't one, add one to the end.
50 ;; Step 3:
51 ;; Add new item to end of menu list.
52 ;; Step 4:
53 ;; Find correct node new item should show up after, and stick
54 ;; the new node there.
55 (if (string= (semantic-texi-current-environment) "menu")
56 ;; We are already in a menu, so insert the new item right here.
57 (beginning-of-line)
58 ;; Else, try to find a menu item to append to.
59 (goto-char (car nodebounds))
60 (if (not (re-search-forward "^@menu" (car (cdr nodebounds)) t))
61 (progn
62 (goto-char (car (cdr nodebounds)))
63 (if (not (y-or-n-p "Add menu here? "))
64 (error "Abort"))
65 (srecode-insert "declaration:menu"))
66 ;; Else, find the end
67 (re-search-forward "@end menu")
68 (beginning-of-line)))
69 ;; At this point, we are in a menu... or not.
70 ;; If we are, do stuff, else error.
71 (when (string= (semantic-texi-current-environment) "menu")
72 (let ((menuname newnode)
73 (returnpoint nil))
74 (srecode-insert "declaration:menuitem" "NAME" menuname)
75 (set-mark (point))
76 (setq returnpoint (make-marker))
77 ;; Update the bound since we added text
78 (setq nodebounds (semantic-tag-texi-section-text-bounds currnode))
79 (beginning-of-line)
80 (forward-char -1)
81 (beginning-of-line)
82 (let ((end nil))
83 (if (not (looking-at "\\* \\([^:]+\\):"))
84 (setq end (car (cdr nodebounds)))
85 (let* ((nname (match-string 1))
86 (tag
87 (semantic-deep-find-tags-by-name nname (current-buffer))))
88 (when tag
89 (setq end (semantic-tag-end (car tag))))
90 ))
91 (when (not end)
92 (goto-char returnpoint)
93 (error "Could not find location for new node" ))
94 (when end
95 (goto-char end)
96 (when (bolp) (forward-char -1))
97 (insert "\n")
98 (if (eq (semantic-current-tag) currnode)
99 (srecode-insert "declaration:subnode" "NAME" menuname)
100 (srecode-insert "declaration:node" "NAME" menuname))
101 )
102 )))
103 ))
104
105;;;###autoload
106(defun srecode-semantic-handle-:texi (dict)
107 "Add macros into the dictionary DICT based on the current texinfo file.
108Adds the following:
109 LEVEL - chapter, section, subsection, etc
110 NEXTLEVEL - One below level"
111
112 ;; LEVEL and NEXTLEVEL calculation
113 (semantic-fetch-tags)
114 (let ((tags (reverse (semantic-find-tag-by-overlay)))
115 (level nil))
116 (while (and tags (not (semantic-tag-of-class-p (car tags) 'section)))
117 (setq tags (cdr tags)))
118 (when tags
119 (save-excursion
120 (goto-char (semantic-tag-start (car tags)))
121 (when (looking-at "@node")
122 (forward-line 1)
123 (beginning-of-line))
124 (when (looking-at "@\\(\\w+\\)")
125 (setq level (match-string 1))
126 )))
127 (srecode-dictionary-set-value dict "LEVEL" (or level "chapter"))
128 (let ((nl (assoc level '( ( nil . "top" )
129 ("top" . "chapter")
130 ("chapter" . "section")
131 ("section" . "subsection")
132 ("subsection" . "subsubsection")
133 ("subsubsection" . "subsubsection")
134 ))))
135 (srecode-dictionary-set-value dict "NEXTLEVEL" (cdr nl))))
136 )
137
138;;;###autoload
139(defun srecode-semantic-handle-:texitag (dict)
140 "Add macros into the dictionary DICT based on the current :tag file.
141Adds the following:
142 TAGDOC - Texinfo formatted doc string for :tag."
143
144 ;; If we also have a TAG, what is the doc?
145 (let ((tag (srecode-dictionary-lookup-name dict "TAG"))
146 (doc nil)
147 )
148
149 ;; If the user didn't apply :tag, then do so now.
150 (when (not tag)
151 (srecode-semantic-handle-:tag dict))
152
153 (setq tag (srecode-dictionary-lookup-name dict "TAG"))
154
155 (when (not tag)
156 (error "No tag to insert for :texitag template argument"))
157
158 ;; Extract the tag out of the compound object.
159 (setq tag (oref tag :prime))
160
161 ;; Extract the doc string
162 (setq doc (semantic-documentation-for-tag tag))
163
164 (when doc
165 (srecode-dictionary-set-value dict "TAGDOC"
166 (srecode-texi-massage-to-texinfo
167 tag (semantic-tag-buffer tag)
168 doc)))
169 ))
170
171;;; OVERRIDES
172;;
173;; Override some semantic and srecode features with texi specific
174;; versions.
175
176(define-mode-local-override semantic-insert-foreign-tag
177 texinfo-mode (foreign-tag)
178 "Insert TAG from a foreign buffer in TAGFILE.
179Assume TAGFILE is a source buffer, and create a documentation
180thingy from it using the `document' tool."
181 (let ((srecode-semantic-selected-tag foreign-tag))
182 ;; @todo - choose of the many types of tags to insert,
183 ;; or put all that logic into srecode.
184 (srecode-insert "declaration:function")))
185
186
187
188;;; Texinfo mangling.
189
190(define-overloadable-function srecode-texi-texify-docstring
191 (docstring)
192 "Texify the doc string DOCSTRING.
193Takes plain text formatting that may exist, and converts it to
194using TeXinfo formatting.")
195
196(defun srecode-texi-texify-docstring-default (docstring)
197 "Texify the doc string DOCSTRING.
198Takes a few very generic guesses as to what the formatting is."
199 (let ((case-fold-search nil)
200 (start 0))
201 (while (string-match
202 "\\(^\\|[^{]\\)\\<\\([A-Z0-9_-]+\\)\\>\\($\\|[^}]\\)"
203 docstring start)
204 (let ((ms (match-string 2 docstring)))
205 ;(when (eq mode 'emacs-lisp-mode)
206 ; (setq ms (downcase ms)))
207
208 (when (not (or (string= ms "A")
209 (string= ms "a")
210 ))
211 (setq docstring (concat (substring docstring 0 (match-beginning 2))
212 "@var{"
213 ms
214 "}"
215 (substring docstring (match-end 2))))))
216 (setq start (match-end 2)))
217 ;; Return our modified doc string.
218 docstring))
219
220(defun srecode-texi-massage-to-texinfo (tag buffer string)
221 "Massage TAG's documentation from BUFFER as STRING.
222This is to take advantage of TeXinfo's markup symbols."
223 (save-excursion
224 (if buffer
225 (progn (set-buffer buffer)
226 (srecode-texi-texify-docstring string))
227 ;; Else, no buffer, so lets do something else
228 (with-mode-local texinfo-mode
229 (srecode-texi-texify-docstring string)))))
230
231(define-mode-local-override srecode-texi-texify-docstring emacs-lisp-mode
232 (string)
233 "Take STRING, (a normal doc string), and convert it into a texinfo string.
234For instances where CLASS is the class being referenced, do not Xref
235that class.
236
237 `function' => @dfn{function}
238 `variable' => @code{variable}
239 `class' => @code{class} @xref{class}
240 `unknown' => @code{unknonwn}
241 \"text\" => ``text''
242 'quoteme => @code{quoteme}
243 non-nil => non-@code{nil}
244 t => @code{t}
245 :tag => @code{:tag}
246 [ stuff ] => @code{[ stuff ]}
247 Key => @kbd{Key} (key is C\\-h, M\\-h, SPC, RET, TAB and the like)
248 ... => @dots{}"
249 (while (string-match "`\\([-a-zA-Z0-9<>.]+\\)'" string)
250 (let* ((vs (substring string (match-beginning 1) (match-end 1)))
251 (v (intern-soft vs)))
252 (setq string
253 (concat
254 (replace-match (concat
255 (if (fboundp v)
256 "@dfn{" "@code{")
257 vs "}")
258 nil t string)))))
259 (while (string-match "\\( \\|^\\)\\(nil\\|t\\|'[-a-zA-Z0-9]+\\|:[-a-zA-Z0-9]+\\)\\([. ,]\\|$\\)" string)
260 (setq string (replace-match "@code{\\2}" t nil string 2)))
261 (while (string-match "\\( \\|^\\)\\(\\(non-\\)\\(nil\\)\\)\\([. ,]\\|$\\)" string)
262 (setq string (replace-match "\\3@code{\\4}" t nil string 2)))
263 (while (string-match "\\( \\|^\\)\\(\\[[^]]+\\]\\)\\( \\|$\\)" string)
264 (setq string (replace-match "@code{\\2}" t nil string 2)))
265 (while (string-match "\\( \\|^\\)\\(\\(\\(C-\\|M-\\|S-\\)+\\([^ \t\n]\\|RET\\|SPC\\|TAB\\)\\)\\|\\(RET\\|SPC\\|TAB\\)\\)\\( \\|\\s.\\|$\\)" string)
266 (setq string (replace-match "@kbd{\\2}" t nil string 2)))
267 (while (string-match "\"\\(.+\\)\"" string)
268 (setq string (replace-match "``\\1''" t nil string 0)))
269 (while (string-match "\\.\\.\\." string)
270 (setq string (replace-match "@dots{}" t nil string 0)))
271 ;; Also do base docstring type.
272 (srecode-texi-texify-docstring-default string))
273
274(provide 'srecode/texi)
275
276;; Local variables:
277;; generated-autoload-file: "loaddefs.el"
278;; generated-autoload-feature: srecode/loaddefs
279;; generated-autoload-load-name: "srecode/texi"
280;; End:
281
282;;; srecode/texi.el ends here
diff --git a/lisp/files.el b/lisp/files.el
index c72faf3c677..0e70d673e8e 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -2203,6 +2203,7 @@ since only a single case-insensitive search through the alist is made."
2203 ("\\.f9[05]\\'" . f90-mode) 2203 ("\\.f9[05]\\'" . f90-mode)
2204 ("\\.indent\\.pro\\'" . fundamental-mode) ; to avoid idlwave-mode 2204 ("\\.indent\\.pro\\'" . fundamental-mode) ; to avoid idlwave-mode
2205 ("\\.\\(pro\\|PRO\\)\\'" . idlwave-mode) 2205 ("\\.\\(pro\\|PRO\\)\\'" . idlwave-mode)
2206 ("\\.srt\\'" . srecode-template-mode) ; in the CEDET library
2206 ("\\.prolog\\'" . prolog-mode) 2207 ("\\.prolog\\'" . prolog-mode)
2207 ("\\.tar\\'" . tar-mode) 2208 ("\\.tar\\'" . tar-mode)
2208 ;; The list of archive file extensions should be in sync with 2209 ;; The list of archive file extensions should be in sync with
diff --git a/test/cedet/srecode-tests.el b/test/cedet/srecode-tests.el
new file mode 100644
index 00000000000..0c13936829d
--- /dev/null
+++ b/test/cedet/srecode-tests.el
@@ -0,0 +1,266 @@
1;;; From srecode-fields:
2
3(require 'srecode/fields)
4
5(defvar srecode-field-utest-text
6 "This is a test buffer.
7
8It is filled with some text."
9 "Text for tests.")
10
11(defun srecode-field-utest ()
12 "Test the srecode field manager."
13 (interactive)
14 (if (featurep 'xemacs)
15 (message "There is no XEmacs support for SRecode Fields.")
16 (srecode-field-utest-impl)))
17
18(defun srecode-field-utest-impl ()
19 "Implementation of the SRecode field utest."
20 (save-excursion
21 (find-file "/tmp/srecode-field-test.txt")
22
23 (erase-buffer)
24 (goto-char (point-min))
25 (insert srecode-field-utest-text)
26 (set-buffer-modified-p nil)
27
28 ;; Test basic field generation.
29 (let ((srecode-field-archive nil)
30 (f nil))
31
32 (end-of-line)
33 (forward-word -1)
34
35 (setq f (srecode-field "Test"
36 :name "TEST"
37 :start 6
38 :end 8))
39
40 (when (or (not (slot-boundp f 'overlay)) (not (oref f overlay)))
41 (error "Field test: Overlay info not created for field"))
42
43 (when (and (overlay-p (oref f overlay))
44 (not (overlay-get (oref f overlay) 'srecode-init-only)))
45 (error "Field creation overlay is not tagged w/ init flag"))
46
47 (srecode-overlaid-activate f)
48
49 (when (or (not (overlay-p (oref f overlay)))
50 (overlay-get (oref f overlay) 'srecode-init-only))
51 (error "New field overlay not created during activation"))
52
53 (when (not (= (length srecode-field-archive) 1))
54 (error "Field test: Incorrect number of elements in the field archive"))
55 (when (not (eq f (car srecode-field-archive)))
56 (error "Field test: Field did not auto-add itself to the field archive"))
57
58 (when (not (overlay-get (oref f overlay) 'keymap))
59 (error "Field test: Overlay keymap not set"))
60
61 (when (not (string= "is" (srecode-overlaid-text f)))
62 (error "Field test: Expected field text 'is', not %s"
63 (srecode-overlaid-text f)))
64
65 ;; Test deletion.
66 (srecode-delete f)
67
68 (when (slot-boundp f 'overlay)
69 (error "Field test: Overlay not deleted after object delete"))
70 )
71
72 ;; Test basic region construction.
73 (let* ((srecode-field-archive nil)
74 (reg nil)
75 (fields
76 (list
77 (srecode-field "Test1" :name "TEST-1" :start 5 :end 10)
78 (srecode-field "Test2" :name "TEST-2" :start 15 :end 20)
79 (srecode-field "Test3" :name "TEST-3" :start 25 :end 30)
80
81 (srecode-field "Test4" :name "TEST-4" :start 35 :end 35))
82 ))
83
84 (when (not (= (length srecode-field-archive) 4))
85 (error "Region Test: Found %d fields. Expected 4"
86 (length srecode-field-archive)))
87
88 (setq reg (srecode-template-inserted-region "REG"
89 :start 4
90 :end 40))
91
92 (srecode-overlaid-activate reg)
93
94 ;; Make sure it was cleared.
95 (when srecode-field-archive
96 (error "Region Test: Did not clear field archive"))
97
98 ;; Auto-positioning.
99 (when (not (eq (point) 5))
100 (error "Region Test: Did not reposition on first field"))
101
102 ;; Active region
103 (when (not (eq (srecode-active-template-region) reg))
104 (error "Region Test: Active region not set"))
105
106 ;; Various sizes
107 (mapc (lambda (T)
108 (if (string= (object-name-string T) "Test4")
109 (progn
110 (when (not (srecode-empty-region-p T))
111 (error "Field %s is not empty"
112 (object-name T)))
113 )
114 (when (not (= (srecode-region-size T) 5))
115 (error "Calculated size of %s was not 5"
116 (object-name T)))))
117 fields)
118
119 ;; Make sure things stay up after a 'command'.
120 (srecode-field-post-command)
121 (when (not (eq (srecode-active-template-region) reg))
122 (error "Region Test: Active region did not stay up"))
123
124 ;; Test field movement.
125 (when (not (eq (srecode-overlaid-at-point 'srecode-field)
126 (nth 0 fields)))
127 (error "Region Test: Field %s not under point"
128 (object-name (nth 0 fields))))
129
130 (srecode-field-next)
131
132 (when (not (eq (srecode-overlaid-at-point 'srecode-field)
133 (nth 1 fields)))
134 (error "Region Test: Field %s not under point"
135 (object-name (nth 1 fields))))
136
137 (srecode-field-prev)
138
139 (when (not (eq (srecode-overlaid-at-point 'srecode-field)
140 (nth 0 fields)))
141 (error "Region Test: Field %s not under point"
142 (object-name (nth 0 fields))))
143
144 ;; Move cursor out of the region and have everything cleaned up.
145 (goto-char 42)
146 (srecode-field-post-command)
147 (when (srecode-active-template-region)
148 (error "Region Test: Active region did not clear on move out"))
149
150 (mapc (lambda (T)
151 (when (slot-boundp T 'overlay)
152 (error "Overlay did not clear off of of field %s"
153 (object-name T))))
154 fields)
155
156 ;; End of LET
157 )
158
159 ;; Test variable linkage.
160 (let* ((srecode-field-archive nil)
161 (f1 (srecode-field "Test1" :name "TEST" :start 6 :end 8))
162 (f2 (srecode-field "Test2" :name "TEST" :start 28 :end 30))
163 (f3 (srecode-field "Test3" :name "NOTTEST" :start 35 :end 40))
164 (reg (srecode-template-inserted-region "REG" :start 4 :end 40))
165 )
166 (srecode-overlaid-activate reg)
167
168 (when (not (string= (srecode-overlaid-text f1)
169 (srecode-overlaid-text f2)))
170 (error "Linkage Test: Init strings are not ="))
171 (when (string= (srecode-overlaid-text f1)
172 (srecode-overlaid-text f3))
173 (error "Linkage Test: Init string on dissimilar fields is now the same"))
174
175 (goto-char 7)
176 (insert "a")
177
178 (when (not (string= (srecode-overlaid-text f1)
179 (srecode-overlaid-text f2)))
180 (error "Linkage Test: mid-insert strings are not ="))
181 (when (string= (srecode-overlaid-text f1)
182 (srecode-overlaid-text f3))
183 (error "Linkage Test: mid-insert string on dissimilar fields is now the same"))
184
185 (goto-char 9)
186 (insert "t")
187
188 (when (not (string= (srecode-overlaid-text f1) "iast"))
189 (error "Linkage Test: tail-insert failed to captured added char"))
190 (when (not (string= (srecode-overlaid-text f1)
191 (srecode-overlaid-text f2)))
192 (error "Linkage Test: tail-insert strings are not ="))
193 (when (string= (srecode-overlaid-text f1)
194 (srecode-overlaid-text f3))
195 (error "Linkage Test: tail-insert string on dissimilar fields is now the same"))
196
197 (goto-char 6)
198 (insert "b")
199
200 (when (not (string= (srecode-overlaid-text f1) "biast"))
201 (error "Linkage Test: tail-insert failed to captured added char"))
202 (when (not (string= (srecode-overlaid-text f1)
203 (srecode-overlaid-text f2)))
204 (error "Linkage Test: tail-insert strings are not ="))
205 (when (string= (srecode-overlaid-text f1)
206 (srecode-overlaid-text f3))
207 (error "Linkage Test: tail-insert string on dissimilar fields is now the same"))
208
209 ;; Cleanup
210 (srecode-delete reg)
211 )
212
213 (set-buffer-modified-p nil)
214
215 (message " All field tests passed.")
216 ))
217
218;;; From srecode-document:
219
220(require 'srecode/doc)
221
222(defun srecode-document-function-comment-extract-test ()
223 "Test old comment extraction.
224Dump out the extracted dictionary."
225 (interactive)
226
227 (srecode-load-tables-for-mode major-mode)
228 (srecode-load-tables-for-mode major-mode 'document)
229
230 (if (not (srecode-table))
231 (error "No template table found for mode %s" major-mode))
232
233 (let* ((temp (srecode-template-get-table (srecode-table)
234 "function-comment"
235 "declaration"
236 'document))
237 (fcn-in (semantic-current-tag)))
238
239 (if (not temp)
240 (error "No templates for function comments"))
241
242 ;; Try to figure out the tag we want to use.
243 (when (or (not fcn-in)
244 (not (semantic-tag-of-class-p fcn-in 'function)))
245 (error "No tag of class 'function to insert comment for"))
246
247 (let ((lextok (semantic-documentation-comment-preceeding-tag fcn-in 'lex))
248 )
249
250 (when (not lextok)
251 (error "No comment to attempt an extraction"))
252
253 (let ((s (semantic-lex-token-start lextok))
254 (e (semantic-lex-token-end lextok))
255 (extract nil))
256
257 (pulse-momentary-highlight-region s e)
258
259 ;; Extract text from the existing comment.
260 (setq extract (srecode-extract temp s e))
261
262 (with-output-to-temp-buffer "*SRECODE DUMP*"
263 (princ "EXTRACTED DICTIONARY FOR ")
264 (princ (semantic-tag-name fcn-in))
265 (princ "\n--------------------------------------------\n")
266 (srecode-dump extract))))))
generated by cgit v1.2.1 (git 2.18.0) at 2026-01-22 13:25:33 +0000