Mercurial > emacs
annotate lisp/cedet/srecode/semantic.el @ 108712:056a00ed4b81
Use terminfo rather than termcap on recent NetBSD.
* configure.in: On NetBSD, if terminfo is found, use it in preference
to termcap. (Bug#6190)
author | Glenn Morris <rgm@gnu.org> |
---|---|
date | Wed, 19 May 2010 23:37:29 -0700 |
parents | 1d1d5d9bd884 |
children | 67ff8ad45bd5 |
rev | line source |
---|---|
104498 | 1 ;;; srecode/semantic.el --- Semantic specific extensions to SRecode. |
2 | |
106815 | 3 ;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc. |
104498 | 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) | |
105260
bbd7017a25d9
CEDET (development tools) package merged.
Chong Yidong <cyd@stupidchicken.com>
parents:
104498
diff
changeset
|
40 (require 'semantic/senator) |
104498 | 41 (require 'ring) |
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. | |
56 This 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. | |
62 If FUNCTION is non-nil, then FUNCTION is somehow applied to an | |
63 aspect 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. | |
77 If 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. | |
90 The hook is called with two arguments, the TAG and DICT | |
91 to be augmented.") | |
92 | |
93 (define-overload srecode-semantic-apply-tag-to-dict (tagobj dict) | |
94 "Insert fewatures of TAGOBJ into the dictionary DICT. | |
95 TAGOBJ is an object of class `srecode-semantic-tag'. This class | |
96 is a compound inserter value. | |
97 DICT is a dictionary object. | |
98 At a minimum, this function will create dictionary macro for NAME. | |
99 It is also likely to create macros for TYPE (data type), function arguments, | |
100 variable 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) | |
105328 | 200 "Add macros into the dictionary DICT based on the current :tag." |
104498 | 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) | |
105328 | 217 "Add macros into the dictionary DICT based on a tag of class type at point. |
104498 | 218 Assumes 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. | |
233 PROTOTYPE 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. | |
238 PROTOTYPE is non-nil if we need a prototype. | |
239 CTXT 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) | |
105328 | 286 "Insert TAG into a buffer using srecode templates at point. |
104498 | 287 |
288 Optional STYLE-OPTION is a list of minor configuration of styles, | |
289 such as the symbol 'prototype for prototype functions, or | |
290 'system for system includes, and 'doxygen, for a doxygen style | |
291 comment. | |
292 | |
293 Optional third argument POINT-INSERT-FCN is a hook that is run after | |
294 TAG is inserted that allows an opportunity to fill in the body of | |
295 some thing. This hook function is called with one argument, the TAG | |
296 being inserted. | |
297 | |
298 The rest of the arguments are DICT-ENTRIES. DICT-ENTRIES | |
299 is of the form ( NAME1 VALUE1 NAME2 VALUE2 ... NAMEn VALUEn). | |
300 | |
301 The exact template used is based on the current context. | |
302 The template used is found within the toplevel context as calculated | |
303 by `srecode-calculate-context', such as `declaration', `classdecl', | |
304 or `code'. | |
305 | |
306 For various conditions, this function looks for a template with | |
307 the name CLASS-tag, where CLASS is the tag class. If it cannot | |
308 find that, it will look for that template in the | |
309 `declaration'context (if the current context was not `declaration'). | |
310 | |
311 If PROTOTYPE is specified, it will first look for templates with | |
312 the name CLASS-tag-prototype, or CLASS-prototype as above. | |
313 | |
314 See `srecode-semantic-apply-tag-to-dict' for details on what is in | |
315 the dictionary when the templates are called. | |
316 | |
317 This function returns to location in the buffer where the | |
318 inserted tag ENDS, and will leave point inside the inserted | |
105328 | 319 text based on any occurrence of a point-inserter. Templates such |
104498 | 320 as `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 | |
105377 | 431 ;; arch-tag: b87ccbd6-bd87-48bc-8182-1043a9052d79 |
104498 | 432 ;;; srecode/semantic.el ends here |