Commit | Line | Data |
---|---|---|
996bc9bf | 1 | ;;; semantic/tag.el --- tag creation and access |
9d389824 | 2 | |
9bf6c65c | 3 | ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008, |
114f9c96 | 4 | ;; 2009, 2010 Free Software Foundation, Inc. |
9d389824 CY |
5 | |
6 | ;; Author: Eric M. Ludlam <zappo@gnu.org> | |
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 | ;; I. The core production of semantic is the list of tags produced by the | |
26 | ;; different parsers. This file provides 3 APIs related to tag access: | |
27 | ;; | |
28 | ;; 1) Primitive Tag Access | |
29 | ;; There is a set of common features to all tags. These access | |
30 | ;; functions can get these values. | |
31 | ;; 2) Standard Tag Access | |
32 | ;; A Standard Tag should be produced by most traditional languages | |
33 | ;; with standard styles common to typed object oriented languages. | |
34 | ;; These functions can access these data elements from a tag. | |
35 | ;; 3) Generic Tag Access | |
36 | ;; Access to tag structure in a more direct way. | |
37 | ;; ** May not be forward compatible. | |
38 | ;; | |
39 | ;; II. There is also an API for tag creation. Use `semantic-tag' to create | |
40 | ;; a new tag. | |
41 | ;; | |
9bf6c65c | 42 | ;; III. Tag Comparison. Allows explicit or comparative tests to see |
9d389824 CY |
43 | ;; if two tags are the same. |
44 | ||
9d389824 CY |
45 | ;;; Code: |
46 | ;; | |
47 | ||
48 | ;; Keep this only so long as we have obsolete fcns. | |
49 | (require 'semantic/fw) | |
a175a831 CY |
50 | (require 'semantic/lex) |
51 | ||
a175a831 CY |
52 | (declare-function semantic-analyze-split-name "semantic/analyze/fcn") |
53 | (declare-function semantic-fetch-tags "semantic") | |
54 | (declare-function semantic-clear-toplevel-cache "semantic") | |
9d389824 | 55 | |
aa8724ae | 56 | (defconst semantic-tag-version "2.0pre7" |
9d389824 CY |
57 | "Version string of semantic tags made with this code.") |
58 | ||
59 | (defconst semantic-tag-incompatible-version "1.0" | |
60 | "Version string of semantic tags which are not currently compatible. | |
61 | These old style tags may be loaded from a file with semantic db. | |
62 | In this case, we must flush the old tags and start over.") | |
63 | \f | |
64 | ;;; Primitive Tag access system: | |
65 | ;; | |
66 | ;; Raw tags in semantic are lists of 5 elements: | |
67 | ;; | |
68 | ;; (NAME CLASS ATTRIBUTES PROPERTIES OVERLAY) | |
69 | ;; | |
70 | ;; Where: | |
71 | ;; | |
72 | ;; - NAME is a string that represents the tag name. | |
73 | ;; | |
74 | ;; - CLASS is a symbol that represent the class of the tag (for | |
75 | ;; example, usual classes are `type', `function', `variable', | |
76 | ;; `include', `package', `code'). | |
77 | ;; | |
78 | ;; - ATTRIBUTES is a public list of attributes that describes | |
79 | ;; language data represented by the tag (for example, a variable | |
80 | ;; can have a `:constant-flag' attribute, a function an `:arguments' | |
81 | ;; attribute, etc.). | |
82 | ;; | |
83 | ;; - PROPERTIES is a private list of properties used internally. | |
84 | ;; | |
85 | ;; - OVERLAY represent the location of data described by the tag. | |
86 | ;; | |
87 | ||
88 | (defsubst semantic-tag-name (tag) | |
89 | "Return the name of TAG. | |
90 | For functions, variables, classes, typedefs, etc., this is the identifier | |
91 | that is being defined. For tags without an obvious associated name, this | |
92 | may be the statement type, e.g., this may return @code{print} for python's | |
93 | print statement." | |
94 | (car tag)) | |
95 | ||
96 | (defsubst semantic-tag-class (tag) | |
97 | "Return the class of TAG. | |
98 | That is, the symbol 'variable, 'function, 'type, or other. | |
99 | There is no limit to the symbols that may represent the class of a tag. | |
100 | Each parser generates tags with classes defined by it. | |
101 | ||
102 | For functional languages, typical tag classes are: | |
103 | ||
104 | @table @code | |
105 | @item type | |
106 | Data types, named map for a memory block. | |
107 | @item function | |
108 | A function or method, or named execution location. | |
109 | @item variable | |
110 | A variable, or named storage for data. | |
111 | @item include | |
112 | Statement that represents a file from which more tags can be found. | |
113 | @item package | |
9bf6c65c | 114 | Statement that declares this file's package name. |
9d389824 CY |
115 | @item code |
116 | Code that has not name or binding to any other symbol, such as in a script. | |
117 | @end table | |
118 | " | |
119 | (nth 1 tag)) | |
120 | ||
121 | (defsubst semantic-tag-attributes (tag) | |
122 | "Return the list of public attributes of TAG. | |
123 | That is a property list: (ATTRIBUTE-1 VALUE-1 ATTRIBUTE-2 VALUE-2...)." | |
124 | (nth 2 tag)) | |
125 | ||
126 | (defsubst semantic-tag-properties (tag) | |
127 | "Return the list of private properties of TAG. | |
128 | That is a property list: (PROPERTY-1 VALUE-1 PROPERTY-2 VALUE-2...)." | |
129 | (nth 3 tag)) | |
130 | ||
131 | (defsubst semantic-tag-overlay (tag) | |
132 | "Return the OVERLAY part of TAG. | |
133 | That is, an overlay or an unloaded buffer representation. | |
134 | This function can also return an array of the form [ START END ]. | |
135 | This occurs for tags that are not currently linked into a buffer." | |
136 | (nth 4 tag)) | |
137 | ||
138 | (defsubst semantic--tag-overlay-cdr (tag) | |
139 | "Return the cons cell whose car is the OVERLAY part of TAG. | |
140 | That function is for internal use only." | |
141 | (nthcdr 4 tag)) | |
142 | ||
143 | (defsubst semantic--tag-set-overlay (tag overlay) | |
144 | "Set the overlay part of TAG with OVERLAY. | |
145 | That function is for internal use only." | |
146 | (setcar (semantic--tag-overlay-cdr tag) overlay)) | |
147 | ||
148 | (defsubst semantic-tag-start (tag) | |
149 | "Return the start location of TAG." | |
150 | (let ((o (semantic-tag-overlay tag))) | |
151 | (if (semantic-overlay-p o) | |
152 | (semantic-overlay-start o) | |
153 | (aref o 0)))) | |
154 | ||
155 | (defsubst semantic-tag-end (tag) | |
156 | "Return the end location of TAG." | |
157 | (let ((o (semantic-tag-overlay tag))) | |
158 | (if (semantic-overlay-p o) | |
159 | (semantic-overlay-end o) | |
160 | (aref o 1)))) | |
161 | ||
162 | (defsubst semantic-tag-bounds (tag) | |
163 | "Return the location (START END) of data TAG describes." | |
164 | (list (semantic-tag-start tag) | |
165 | (semantic-tag-end tag))) | |
166 | ||
167 | (defun semantic-tag-set-bounds (tag start end) | |
168 | "In TAG, set the START and END location of data it describes." | |
169 | (let ((o (semantic-tag-overlay tag))) | |
170 | (if (semantic-overlay-p o) | |
171 | (semantic-overlay-move o start end) | |
172 | (semantic--tag-set-overlay tag (vector start end))))) | |
173 | ||
174 | (defun semantic-tag-in-buffer-p (tag) | |
175 | "Return the buffer TAG resides in IFF tag is already in a buffer. | |
176 | If a tag is not in a buffer, return nil." | |
177 | (let ((o (semantic-tag-overlay tag))) | |
178 | ;; TAG is currently linked to a buffer, return it. | |
179 | (when (and (semantic-overlay-p o) | |
180 | (semantic-overlay-live-p o)) | |
181 | (semantic-overlay-buffer o)))) | |
182 | ||
183 | (defsubst semantic--tag-get-property (tag property) | |
184 | "From TAG, extract the value of PROPERTY. | |
185 | Return the value found, or nil if PROPERTY is not one of the | |
186 | properties of TAG. | |
187 | That function is for internal use only." | |
188 | (plist-get (semantic-tag-properties tag) property)) | |
189 | ||
190 | (defun semantic-tag-buffer (tag) | |
191 | "Return the buffer TAG resides in. | |
192 | If TAG has an originating file, read that file into a (maybe new) | |
193 | buffer, and return it. | |
194 | Return nil if there is no buffer for this tag." | |
195 | (let ((buff (semantic-tag-in-buffer-p tag))) | |
196 | (if buff | |
197 | buff | |
198 | ;; TAG has an originating file, read that file into a buffer, and | |
199 | ;; return it. | |
200 | (if (semantic--tag-get-property tag :filename) | |
1eac105a CY |
201 | (save-match-data |
202 | (find-file-noselect (semantic--tag-get-property tag :filename))) | |
9d389824 CY |
203 | ;; TAG is not in Emacs right now, no buffer is available. |
204 | )))) | |
205 | ||
206 | (defun semantic-tag-mode (&optional tag) | |
207 | "Return the major mode active for TAG. | |
208 | TAG defaults to the tag at point in current buffer. | |
209 | If TAG has a :mode property return it. | |
210 | If point is inside TAG bounds, return the major mode active at point. | |
211 | Return the major mode active at beginning of TAG otherwise. | |
212 | See also the function `semantic-ctxt-current-mode'." | |
213 | (or tag (setq tag (semantic-current-tag))) | |
214 | (or (semantic--tag-get-property tag :mode) | |
215 | (let ((buffer (semantic-tag-buffer tag)) | |
216 | (start (semantic-tag-start tag)) | |
217 | (end (semantic-tag-end tag))) | |
218 | (save-excursion | |
219 | (and buffer (set-buffer buffer)) | |
220 | ;; Unless point is inside TAG bounds, move it to the | |
221 | ;; beginning of TAG. | |
222 | (or (and (>= (point) start) (< (point) end)) | |
223 | (goto-char start)) | |
9d389824 CY |
224 | (semantic-ctxt-current-mode))))) |
225 | ||
226 | (defsubst semantic--tag-attributes-cdr (tag) | |
227 | "Return the cons cell whose car is the ATTRIBUTES part of TAG. | |
228 | That function is for internal use only." | |
229 | (nthcdr 2 tag)) | |
230 | ||
231 | (defsubst semantic-tag-put-attribute (tag attribute value) | |
232 | "Change value in TAG of ATTRIBUTE to VALUE. | |
233 | If ATTRIBUTE already exists, its value is set to VALUE, otherwise the | |
234 | new ATTRIBUTE VALUE pair is added. | |
235 | Return TAG. | |
236 | Use this function in a parser when not all attributes are known at the | |
237 | same time." | |
238 | (let* ((plist-cdr (semantic--tag-attributes-cdr tag))) | |
239 | (when (consp plist-cdr) | |
240 | (setcar plist-cdr | |
241 | (semantic-tag-make-plist | |
242 | (plist-put (car plist-cdr) attribute value)))) | |
243 | tag)) | |
244 | ||
245 | (defun semantic-tag-put-attribute-no-side-effect (tag attribute value) | |
246 | "Change value in TAG of ATTRIBUTE to VALUE without side effects. | |
247 | All cons cells in the attribute list are replicated so that there | |
248 | are no side effects if TAG is in shared lists. | |
249 | If ATTRIBUTE already exists, its value is set to VALUE, otherwise the | |
250 | new ATTRIBUTE VALUE pair is added. | |
251 | Return TAG." | |
252 | (let* ((plist-cdr (semantic--tag-attributes-cdr tag))) | |
253 | (when (consp plist-cdr) | |
254 | (setcar plist-cdr | |
255 | (semantic-tag-make-plist | |
256 | (plist-put (copy-sequence (car plist-cdr)) | |
257 | attribute value)))) | |
258 | tag)) | |
259 | ||
260 | (defsubst semantic-tag-get-attribute (tag attribute) | |
261 | "From TAG, return the value of ATTRIBUTE. | |
262 | ATTRIBUTE is a symbol whose specification value to get. | |
263 | Return the value found, or nil if ATTRIBUTE is not one of the | |
264 | attributes of TAG." | |
265 | (plist-get (semantic-tag-attributes tag) attribute)) | |
266 | ||
267 | ;; These functions are for internal use only! | |
268 | (defsubst semantic--tag-properties-cdr (tag) | |
269 | "Return the cons cell whose car is the PROPERTIES part of TAG. | |
270 | That function is for internal use only." | |
271 | (nthcdr 3 tag)) | |
272 | ||
273 | (defun semantic--tag-put-property (tag property value) | |
274 | "Change value in TAG of PROPERTY to VALUE. | |
275 | If PROPERTY already exists, its value is set to VALUE, otherwise the | |
276 | new PROPERTY VALUE pair is added. | |
277 | Return TAG. | |
278 | That function is for internal use only." | |
279 | (let* ((plist-cdr (semantic--tag-properties-cdr tag))) | |
280 | (when (consp plist-cdr) | |
281 | (setcar plist-cdr | |
282 | (semantic-tag-make-plist | |
283 | (plist-put (car plist-cdr) property value)))) | |
284 | tag)) | |
285 | ||
286 | (defun semantic--tag-put-property-no-side-effect (tag property value) | |
287 | "Change value in TAG of PROPERTY to VALUE without side effects. | |
288 | All cons cells in the property list are replicated so that there | |
289 | are no side effects if TAG is in shared lists. | |
290 | If PROPERTY already exists, its value is set to VALUE, otherwise the | |
291 | new PROPERTY VALUE pair is added. | |
292 | Return TAG. | |
293 | That function is for internal use only." | |
294 | (let* ((plist-cdr (semantic--tag-properties-cdr tag))) | |
295 | (when (consp plist-cdr) | |
296 | (setcar plist-cdr | |
297 | (semantic-tag-make-plist | |
298 | (plist-put (copy-sequence (car plist-cdr)) | |
299 | property value)))) | |
300 | tag)) | |
301 | ||
302 | (defun semantic-tag-file-name (tag) | |
303 | "Return the name of the file from which TAG originated. | |
304 | Return nil if that information can't be obtained. | |
305 | If TAG is from a loaded buffer, then that buffer's filename is used. | |
306 | If TAG is unlinked, but has a :filename property, then that is used." | |
307 | (let ((buffer (semantic-tag-in-buffer-p tag))) | |
308 | (if buffer | |
309 | (buffer-file-name buffer) | |
310 | (semantic--tag-get-property tag :filename)))) | |
311 | \f | |
312 | ;;; Tag tests and comparisons. | |
9d389824 CY |
313 | (defsubst semantic-tag-p (tag) |
314 | "Return non-nil if TAG is most likely a semantic tag." | |
315 | (condition-case nil | |
316 | (and (consp tag) | |
317 | (stringp (car tag)) ; NAME | |
318 | (symbolp (nth 1 tag)) (nth 1 tag) ; TAG-CLASS | |
319 | (listp (nth 2 tag)) ; ATTRIBUTES | |
320 | (listp (nth 3 tag)) ; PROPERTIES | |
321 | ) | |
322 | ;; If an error occurs, then it most certainly is not a tag. | |
323 | (error nil))) | |
324 | ||
325 | (defsubst semantic-tag-of-class-p (tag class) | |
326 | "Return non-nil if class of TAG is CLASS." | |
327 | (eq (semantic-tag-class tag) class)) | |
328 | ||
329 | (defsubst semantic-tag-type-members (tag) | |
330 | "Return the members of the type that TAG describes. | |
331 | That is the value of the `:members' attribute." | |
332 | (semantic-tag-get-attribute tag :members)) | |
333 | ||
a60f2e7b CY |
334 | (defsubst semantic-tag-type (tag) |
335 | "Return the value of the `:type' attribute of TAG. | |
336 | For a function it would be the data type of the return value. | |
337 | For a variable, it is the storage type of that variable. | |
338 | For a data type, the type is the style of datatype, such as | |
339 | struct or union." | |
340 | (semantic-tag-get-attribute tag :type)) | |
341 | ||
9d389824 CY |
342 | (defun semantic-tag-with-position-p (tag) |
343 | "Return non-nil if TAG has positional information." | |
344 | (and (semantic-tag-p tag) | |
345 | (let ((o (semantic-tag-overlay tag))) | |
346 | (or (and (semantic-overlay-p o) | |
347 | (semantic-overlay-live-p o)) | |
348 | (arrayp o))))) | |
349 | ||
350 | (defun semantic-equivalent-tag-p (tag1 tag2) | |
351 | "Compare TAG1 and TAG2 and return non-nil if they are equivalent. | |
352 | Use `equal' on elements the name, class, and position. | |
353 | Use this function if tags are being copied and regrouped to test | |
354 | for if two tags represent the same thing, but may be constructed | |
355 | of different cons cells." | |
356 | (and (equal (semantic-tag-name tag1) (semantic-tag-name tag2)) | |
357 | (semantic-tag-of-class-p tag1 (semantic-tag-class tag2)) | |
358 | (or (and (not (semantic-tag-overlay tag1)) | |
359 | (not (semantic-tag-overlay tag2))) | |
360 | (and (semantic-tag-overlay tag1) | |
361 | (semantic-tag-overlay tag2) | |
362 | (equal (semantic-tag-bounds tag1) | |
363 | (semantic-tag-bounds tag2)))))) | |
364 | ||
9d389824 CY |
365 | (defun semantic-tag-similar-p (tag1 tag2 &rest ignorable-attributes) |
366 | "Test to see if TAG1 and TAG2 are similar. | |
367 | Two tags are similar if their name, datatype, and various attributes | |
368 | are the same. | |
369 | ||
370 | Similar tags that have sub-tags such as arg lists or type members, | |
371 | are similar w/out checking the sub-list of tags. | |
372 | Optional argument IGNORABLE-ATTRIBUTES are attributes to ignore while comparing similarity." | |
373 | (let* ((A1 (and (equal (semantic-tag-name tag1) (semantic-tag-name tag2)) | |
374 | (semantic-tag-of-class-p tag1 (semantic-tag-class tag2)) | |
375 | (semantic-tag-of-type-p tag1 (semantic-tag-type tag2)))) | |
376 | (attr1 (semantic-tag-attributes tag1)) | |
377 | (A2 (= (length attr1) (length (semantic-tag-attributes tag2)))) | |
378 | (A3 t) | |
379 | ) | |
380 | (when (and (not A2) ignorable-attributes) | |
381 | (setq A2 t)) | |
382 | (while (and A2 attr1 A3) | |
383 | (let ((a (car attr1)) | |
384 | (v (car (cdr attr1)))) | |
385 | ||
386 | (cond ((or (eq a :type) ;; already tested above. | |
387 | (memq a ignorable-attributes)) ;; Ignore them... | |
388 | nil) | |
389 | ||
390 | ;; Don't test sublists of tags | |
391 | ((and (listp v) (semantic-tag-p (car v))) | |
392 | nil) | |
393 | ||
394 | ;; The attributes are not the same? | |
395 | ((not (equal v (semantic-tag-get-attribute tag2 a))) | |
396 | (setq A3 nil)) | |
397 | (t | |
398 | nil)) | |
399 | ) | |
400 | (setq attr1 (cdr (cdr attr1)))) | |
401 | ||
402 | (and A1 A2 A3) | |
403 | )) | |
404 | ||
405 | (defun semantic-tag-similar-with-subtags-p (tag1 tag2 &rest ignorable-attributes) | |
406 | "Test to see if TAG1 and TAG2 are similar. | |
407 | Uses `semantic-tag-similar-p' but also recurses through sub-tags, such | |
408 | as argument lists and type members. | |
409 | Optional argument IGNORABLE-ATTRIBUTES is passed down to | |
410 | `semantic-tag-similar-p'." | |
411 | (let ((C1 (semantic-tag-components tag1)) | |
412 | (C2 (semantic-tag-components tag2)) | |
413 | ) | |
414 | (if (or (/= (length C1) (length C2)) | |
415 | (not (semantic-tag-similar-p tag1 tag2 ignorable-attributes)) | |
416 | ) | |
417 | ;; Basic test fails. | |
418 | nil | |
419 | ;; Else, check component lists. | |
420 | (catch 'component-dissimilar | |
421 | (while C1 | |
422 | ||
423 | (if (not (semantic-tag-similar-with-subtags-p | |
424 | (car C1) (car C2) ignorable-attributes)) | |
425 | (throw 'component-dissimilar nil)) | |
426 | ||
427 | (setq C1 (cdr C1)) | |
428 | (setq C2 (cdr C2)) | |
429 | ) | |
430 | ;; If we made it this far, we are ok. | |
431 | t) ))) | |
432 | ||
433 | ||
434 | (defun semantic-tag-of-type-p (tag type) | |
435 | "Compare TAG's type against TYPE. Non nil if equivalent. | |
436 | TYPE can be a string, or a tag of class 'type. | |
437 | This can be complex since some tags might have a :type that is a tag, | |
438 | while other tags might just have a string. This function will also be | |
439 | return true of TAG's type is compared directly to the declaration of a | |
440 | data type." | |
441 | (let* ((tagtype (semantic-tag-type tag)) | |
442 | (tagtypestring (cond ((stringp tagtype) | |
443 | tagtype) | |
444 | ((and (semantic-tag-p tagtype) | |
445 | (semantic-tag-of-class-p tagtype 'type)) | |
446 | (semantic-tag-name tagtype)) | |
447 | (t ""))) | |
448 | (typestring (cond ((stringp type) | |
449 | type) | |
450 | ((and (semantic-tag-p type) | |
451 | (semantic-tag-of-class-p type 'type)) | |
452 | (semantic-tag-name type)) | |
453 | (t ""))) | |
454 | ) | |
455 | (and | |
456 | tagtypestring | |
457 | (or | |
458 | ;; Matching strings (input type is string) | |
459 | (and (stringp type) | |
460 | (string= tagtypestring type)) | |
461 | ;; Matching strings (tag type is string) | |
462 | (and (stringp tagtype) | |
463 | (string= tagtype typestring)) | |
464 | ;; Matching tokens, and the type of the type is the same. | |
465 | (and (string= tagtypestring typestring) | |
466 | (if (and (semantic-tag-type tagtype) (semantic-tag-type type)) | |
467 | (equal (semantic-tag-type tagtype) (semantic-tag-type type)) | |
468 | t)) | |
469 | )) | |
470 | )) | |
471 | ||
472 | (defun semantic-tag-type-compound-p (tag) | |
473 | "Return non-nil the type of TAG is compound. | |
474 | Compound implies a structure or similar data type. | |
475 | Returns the list of tag members if it is compound." | |
476 | (let* ((tagtype (semantic-tag-type tag)) | |
477 | ) | |
478 | (when (and (semantic-tag-p tagtype) | |
479 | (semantic-tag-of-class-p tagtype 'type)) | |
480 | ;; We have the potential of this being a nifty compound type. | |
481 | (semantic-tag-type-members tagtype) | |
482 | ))) | |
483 | ||
484 | (defun semantic-tag-faux-p (tag) | |
485 | "Return non-nil if TAG is a FAUX tag. | |
486 | FAUX tags are created to represent a construct that is | |
487 | not known to exist in the code. | |
488 | ||
489 | Example: When the class browser sees methods to a class, but | |
490 | cannot find the class, it will create a faux tag to represent the | |
491 | class to store those methods." | |
492 | (semantic--tag-get-property tag :faux-flag)) | |
493 | \f | |
494 | ;;; Tag creation | |
495 | ;; | |
496 | ||
497 | ;; Is this function still necessary? | |
498 | (defun semantic-tag-make-plist (args) | |
499 | "Create a property list with ARGS. | |
500 | Args is a property list of the form (KEY1 VALUE1 ... KEYN VALUEN). | |
501 | Where KEY is a symbol, and VALUE is the value for that symbol. | |
502 | The return value will be a new property list, with these KEY/VALUE | |
503 | pairs eliminated: | |
504 | ||
505 | - KEY associated to nil VALUE. | |
506 | - KEY associated to an empty string VALUE. | |
507 | - KEY associated to a zero VALUE." | |
508 | (let (plist key val) | |
509 | (while args | |
510 | (setq key (car args) | |
511 | val (nth 1 args) | |
512 | args (nthcdr 2 args)) | |
513 | (or (member val '("" nil)) | |
514 | (and (numberp val) (zerop val)) | |
515 | (setq plist (cons key (cons val plist))))) | |
516 | ;; It is not useful to reverse the new plist. | |
517 | plist)) | |
518 | ||
519 | (defsubst semantic-tag (name class &rest attributes) | |
520 | "Create a generic semantic tag. | |
521 | NAME is a string representing the name of this tag. | |
522 | CLASS is the symbol that represents the class of tag this is, | |
523 | such as 'variable, or 'function. | |
524 | ATTRIBUTES is a list of additional attributes belonging to this tag." | |
525 | (list name class (semantic-tag-make-plist attributes) nil nil)) | |
526 | ||
527 | (defsubst semantic-tag-new-variable (name type &optional default-value &rest attributes) | |
528 | "Create a semantic tag of class 'variable. | |
529 | NAME is the name of this variable. | |
530 | TYPE is a string or semantic tag representing the type of this variable. | |
9bf6c65c GM |
531 | Optional DEFAULT-VALUE is a string representing the default value of this |
532 | variable. ATTRIBUTES is a list of additional attributes belonging to this | |
533 | tag." | |
9d389824 CY |
534 | (apply 'semantic-tag name 'variable |
535 | :type type | |
536 | :default-value default-value | |
537 | attributes)) | |
538 | ||
539 | (defsubst semantic-tag-new-function (name type arg-list &rest attributes) | |
540 | "Create a semantic tag of class 'function. | |
541 | NAME is the name of this function. | |
542 | TYPE is a string or semantic tag representing the type of this function. | |
543 | ARG-LIST is a list of strings or semantic tags representing the | |
544 | arguments of this function. | |
545 | ATTRIBUTES is a list of additional attributes belonging to this tag." | |
546 | (apply 'semantic-tag name 'function | |
547 | :type type | |
548 | :arguments arg-list | |
549 | attributes)) | |
550 | ||
551 | (defsubst semantic-tag-new-type (name type members parents &rest attributes) | |
552 | "Create a semantic tag of class 'type. | |
553 | NAME is the name of this type. | |
554 | TYPE is a string or semantic tag representing the type of this type. | |
555 | MEMBERS is a list of strings or semantic tags representing the | |
556 | elements that make up this type if it is a composite type. | |
557 | PARENTS is a cons cell. (EXPLICIT-PARENTS . INTERFACE-PARENTS) | |
558 | EXPLICIT-PARENTS can be a single string (Just one parent) or a | |
559 | list of parents (in a multiple inheritance situation). It can also | |
560 | be nil. | |
561 | INTERFACE-PARENTS is a list of strings representing the names of | |
562 | all INTERFACES, or abstract classes inherited from. It can also be | |
563 | nil. | |
564 | This slot can be interesting because the form: | |
565 | ( nil \"string\") | |
566 | is a valid parent where there is no explicit parent, and only an | |
567 | interface. | |
568 | ATTRIBUTES is a list of additional attributes belonging to this tag." | |
569 | (apply 'semantic-tag name 'type | |
570 | :type type | |
571 | :members members | |
572 | :superclasses (car parents) | |
573 | :interfaces (cdr parents) | |
574 | attributes)) | |
575 | ||
576 | (defsubst semantic-tag-new-include (name system-flag &rest attributes) | |
577 | "Create a semantic tag of class 'include. | |
578 | NAME is the name of this include. | |
579 | SYSTEM-FLAG represents that we were able to identify this include as belonging | |
580 | to the system, as opposed to belonging to the local project. | |
581 | ATTRIBUTES is a list of additional attributes belonging to this tag." | |
582 | (apply 'semantic-tag name 'include | |
583 | :system-flag system-flag | |
584 | attributes)) | |
585 | ||
586 | (defsubst semantic-tag-new-package (name detail &rest attributes) | |
587 | "Create a semantic tag of class 'package. | |
588 | NAME is the name of this package. | |
589 | DETAIL is extra information about this package, such as a location where | |
590 | it can be found. | |
591 | ATTRIBUTES is a list of additional attributes belonging to this tag." | |
592 | (apply 'semantic-tag name 'package | |
593 | :detail detail | |
594 | attributes)) | |
595 | ||
596 | (defsubst semantic-tag-new-code (name detail &rest attributes) | |
597 | "Create a semantic tag of class 'code. | |
598 | NAME is a name for this code. | |
599 | DETAIL is extra information about the code. | |
600 | ATTRIBUTES is a list of additional attributes belonging to this tag." | |
601 | (apply 'semantic-tag name 'code | |
602 | :detail detail | |
603 | attributes)) | |
604 | ||
605 | (defsubst semantic-tag-set-faux (tag) | |
606 | "Set TAG to be a new FAUX tag. | |
607 | FAUX tags represent constructs not found in the source code. | |
608 | You can identify a faux tag with `semantic-tag-faux-p'" | |
609 | (semantic--tag-put-property tag :faux-flag t)) | |
610 | ||
611 | (defsubst semantic-tag-set-name (tag name) | |
612 | "Set TAG name to NAME." | |
613 | (setcar tag name)) | |
614 | ||
615 | ;;; Copying and cloning tags. | |
616 | ;; | |
617 | (defsubst semantic-tag-clone (tag &optional name) | |
618 | "Clone TAG, creating a new TAG. | |
619 | If optional argument NAME is not nil it specifies a new name for the | |
620 | cloned tag." | |
621 | ;; Right now, TAG is a list. | |
622 | (list (or name (semantic-tag-name tag)) | |
623 | (semantic-tag-class tag) | |
624 | (copy-sequence (semantic-tag-attributes tag)) | |
625 | (copy-sequence (semantic-tag-properties tag)) | |
626 | (semantic-tag-overlay tag))) | |
627 | ||
628 | (defun semantic-tag-copy (tag &optional name keep-file) | |
629 | "Return a copy of TAG unlinked from the originating buffer. | |
630 | If optional argument NAME is non-nil it specifies a new name for the | |
631 | copied tag. | |
632 | If optional argument KEEP-FILE is non-nil, and TAG was linked to a | |
633 | buffer, the originating buffer file name is kept in the `:filename' | |
634 | property of the copied tag. | |
9bf6c65c | 635 | If KEEP-FILE is a string, and the originating buffer is NOT available, |
9d389824 CY |
636 | then KEEP-FILE is stored on the `:filename' property. |
637 | This runs the tag hook `unlink-copy-hook`." | |
638 | ;; Right now, TAG is a list. | |
639 | (let ((copy (semantic-tag-clone tag name))) | |
640 | ||
641 | ;; Keep the filename if needed. | |
642 | (when keep-file | |
643 | (semantic--tag-put-property | |
644 | copy :filename (or (semantic-tag-file-name copy) | |
645 | (and (stringp keep-file) | |
646 | keep-file) | |
647 | ))) | |
648 | ||
649 | (when (semantic-tag-with-position-p tag) | |
650 | ;; Convert the overlay to a vector, effectively 'unlinking' the tag. | |
651 | (semantic--tag-set-overlay | |
652 | copy (vector (semantic-tag-start copy) (semantic-tag-end copy))) | |
653 | ||
654 | ;; Force the children to be copied also. | |
655 | ;;(let ((chil (semantic--tag-copy-list | |
656 | ;; (semantic-tag-components-with-overlays tag) | |
657 | ;; keep-file))) | |
658 | ;;;; Put the list into TAG. | |
659 | ;;) | |
660 | ||
661 | ;; Call the unlink-copy hook. This should tell tools that | |
662 | ;; this tag is not part of any buffer. | |
663 | (when (semantic-overlay-p (semantic-tag-overlay tag)) | |
664 | (semantic--tag-run-hooks copy 'unlink-copy-hook)) | |
665 | ) | |
666 | copy)) | |
667 | ||
668 | ;;(defun semantic--tag-copy-list (tags &optional keep-file) | |
669 | ;; "Make copies of TAGS and return the list of TAGS." | |
670 | ;; (let ((out nil)) | |
671 | ;; (dolist (tag tags out) | |
672 | ;; (setq out (cons (semantic-tag-copy tag nil keep-file) | |
673 | ;; out)) | |
674 | ;; ))) | |
675 | ||
676 | (defun semantic--tag-copy-properties (tag1 tag2) | |
677 | "Copy private properties from TAG1 to TAG2. | |
678 | Return TAG2. | |
679 | This function is for internal use only." | |
680 | (let ((plist (semantic-tag-properties tag1))) | |
681 | (while plist | |
682 | (semantic--tag-put-property tag2 (car plist) (nth 1 plist)) | |
683 | (setq plist (nthcdr 2 plist))) | |
684 | tag2)) | |
685 | ||
686 | ;;; DEEP COPIES | |
687 | ;; | |
688 | (defun semantic-tag-deep-copy-one-tag (tag &optional filter) | |
689 | "Make a deep copy of TAG, applying FILTER to each child-tag. | |
690 | Properties and overlay info are not copied. | |
691 | FILTER takes TAG as an argument, and should returns a semantic-tag. | |
692 | It is safe for FILTER to modify the input tag and return it." | |
693 | (when (not filter) (setq filter 'identity)) | |
694 | (when (not (semantic-tag-p tag)) | |
695 | (signal 'wrong-type-argument (list tag 'semantic-tag-p))) | |
696 | (funcall filter (list (semantic-tag-name tag) | |
697 | (semantic-tag-class tag) | |
698 | (semantic--tag-deep-copy-attributes | |
699 | (semantic-tag-attributes tag) filter) | |
700 | nil | |
701 | nil))) | |
702 | ||
703 | (defun semantic--tag-deep-copy-attributes (attrs &optional filter) | |
704 | "Make a deep copy of ATTRS, applying FILTER to each child-tag. | |
705 | ||
9bf6c65c | 706 | It is safe to modify ATTR, and return a permutation of that list. |
9d389824 CY |
707 | |
708 | FILTER takes TAG as an argument, and should returns a semantic-tag. | |
709 | It is safe for FILTER to modify the input tag and return it." | |
710 | (when (car attrs) | |
711 | (when (not (symbolp (car attrs))) (error "Bad Attribute List in tag")) | |
712 | (cons (car attrs) | |
713 | (cons (semantic--tag-deep-copy-value (nth 1 attrs) filter) | |
714 | (semantic--tag-deep-copy-attributes (nthcdr 2 attrs) filter))))) | |
715 | ||
716 | (defun semantic--tag-deep-copy-value (value &optional filter) | |
717 | "Make a deep copy of VALUE, applying FILTER to each child-tag. | |
718 | ||
9bf6c65c | 719 | It is safe to modify VALUE, and return a permutation of that list. |
9d389824 CY |
720 | |
721 | FILTER takes TAG as an argument, and should returns a semantic-tag. | |
722 | It is safe for FILTER to modify the input tag and return it." | |
723 | (cond | |
724 | ;; Another tag. | |
725 | ((semantic-tag-p value) | |
726 | (semantic-tag-deep-copy-one-tag value filter)) | |
727 | ||
728 | ;; A list of more tags | |
729 | ((and (listp value) (semantic-tag-p (car value))) | |
730 | (semantic--tag-deep-copy-tag-list value filter)) | |
731 | ||
732 | ;; Some arbitrary data. | |
733 | (t value))) | |
734 | ||
735 | (defun semantic--tag-deep-copy-tag-list (tags &optional filter) | |
736 | "Make a deep copy of TAGS, applying FILTER to each child-tag. | |
737 | ||
9bf6c65c | 738 | It is safe to modify the TAGS list, and return a permutation of that list. |
9d389824 CY |
739 | |
740 | FILTER takes TAG as an argument, and should returns a semantic-tag. | |
741 | It is safe for FILTER to modify the input tag and return it." | |
742 | (when (car tags) | |
743 | (if (semantic-tag-p (car tags)) | |
744 | (cons (semantic-tag-deep-copy-one-tag (car tags) filter) | |
745 | (semantic--tag-deep-copy-tag-list (cdr tags) filter)) | |
746 | (cons (car tags) (semantic--tag-deep-copy-tag-list (cdr tags) filter))))) | |
747 | ||
748 | \f | |
749 | ;;; Standard Tag Access | |
750 | ;; | |
751 | ||
752 | ;;; Common | |
753 | ;; | |
9d389824 CY |
754 | (defsubst semantic-tag-modifiers (tag) |
755 | "Return the value of the `:typemodifiers' attribute of TAG." | |
756 | (semantic-tag-get-attribute tag :typemodifiers)) | |
757 | ||
758 | (defun semantic-tag-docstring (tag &optional buffer) | |
759 | "Return the documentation of TAG. | |
760 | That is the value defined by the `:documentation' attribute. | |
761 | Optional argument BUFFER indicates where to get the text from. | |
762 | If not provided, then only the POSITION can be provided. | |
763 | ||
764 | If you want to get documentation for languages that do not store | |
765 | the documentation string in the tag itself, use | |
766 | `semantic-documentation-for-tag' instead." | |
767 | (let ((p (semantic-tag-get-attribute tag :documentation))) | |
768 | (cond | |
769 | ((stringp p) p) ;; it is the doc string. | |
770 | ||
771 | ((semantic-lex-token-with-text-p p) | |
772 | (semantic-lex-token-text p)) | |
773 | ||
774 | ((and (semantic-lex-token-without-text-p p) | |
775 | buffer) | |
776 | (with-current-buffer buffer | |
777 | (semantic-lex-token-text (car (semantic-lex p (1+ p)))))) | |
778 | ||
779 | (t nil)))) | |
780 | ||
781 | ;;; Generic attributes for tags of any class. | |
782 | ;; | |
783 | (defsubst semantic-tag-named-parent (tag) | |
784 | "Return the parent of TAG. | |
785 | That is the value of the `:parent' attribute. | |
786 | If a definition can occur outside an actual parent structure, but | |
787 | refers to that parent by name, then the :parent attribute should be used." | |
788 | (semantic-tag-get-attribute tag :parent)) | |
789 | ||
790 | ;;; Tags of class `type' | |
791 | ||
792 | (defun semantic-tag-type-superclasses (tag) | |
793 | "Return the list of superclass names of the type that TAG describes." | |
794 | (let ((supers (semantic-tag-get-attribute tag :superclasses))) | |
795 | (cond ((stringp supers) | |
796 | ;; If we have a string, make it a list. | |
797 | (list supers)) | |
798 | ((semantic-tag-p supers) | |
799 | ;; If we have one tag, return just the name. | |
800 | (list (semantic-tag-name supers))) | |
801 | ((and (consp supers) (semantic-tag-p (car supers))) | |
802 | ;; If we have a tag list, then return the names. | |
803 | (mapcar (lambda (s) (semantic-tag-name s)) | |
804 | supers)) | |
805 | ((consp supers) | |
806 | ;; A list of something, return it. | |
807 | supers)))) | |
808 | ||
809 | (defun semantic--tag-find-parent-by-name (name supers) | |
810 | "Find the superclass NAME in the list of SUPERS. | |
811 | If a simple search doesn't do it, try splitting up the names | |
812 | in SUPERS." | |
813 | (let ((stag nil)) | |
814 | (setq stag (semantic-find-first-tag-by-name name supers)) | |
a60f2e7b | 815 | |
9d389824 | 816 | (when (not stag) |
a175a831 | 817 | (require 'semantic/analyze/fcn) |
9d389824 CY |
818 | (dolist (S supers) |
819 | (let* ((sname (semantic-tag-name S)) | |
820 | (splitparts (semantic-analyze-split-name sname)) | |
821 | (parts (if (stringp splitparts) | |
822 | (list splitparts) | |
823 | (nreverse splitparts)))) | |
824 | (when (string= name (car parts)) | |
825 | (setq stag S)) | |
826 | ))) | |
827 | ||
828 | stag)) | |
829 | ||
830 | (defun semantic-tag-type-superclass-protection (tag parentstring) | |
831 | "Return the inheritance protection in TAG from PARENTSTRING. | |
832 | PARENTSTRING is the name of the parent being inherited. | |
833 | The return protection is a symbol, 'public, 'protection, and 'private." | |
834 | (let ((supers (semantic-tag-get-attribute tag :superclasses))) | |
835 | (cond ((stringp supers) | |
836 | 'public) | |
837 | ((semantic-tag-p supers) | |
838 | (let ((prot (semantic-tag-get-attribute supers :protection))) | |
839 | (or (cdr (assoc prot '(("public" . public) | |
840 | ("protected" . protected) | |
841 | ("private" . private)))) | |
842 | 'public))) | |
843 | ((and (consp supers) (stringp (car supers))) | |
844 | 'public) | |
845 | ((and (consp supers) (semantic-tag-p (car supers))) | |
846 | (let* ((stag (semantic--tag-find-parent-by-name parentstring supers)) | |
847 | (prot (when stag | |
848 | (semantic-tag-get-attribute stag :protection)))) | |
849 | (or (cdr (assoc prot '(("public" . public) | |
850 | ("protected" . protected) | |
851 | ("private" . private)))) | |
852 | (when (equal prot "unspecified") | |
853 | (if (semantic-tag-of-type-p tag "class") | |
854 | 'private | |
855 | 'public)) | |
856 | 'public)))) | |
857 | )) | |
858 | ||
859 | (defsubst semantic-tag-type-interfaces (tag) | |
860 | "Return the list of interfaces of the type that TAG describes." | |
861 | ;; @todo - make this as robust as the above. | |
862 | (semantic-tag-get-attribute tag :interfaces)) | |
863 | ||
864 | ;;; Tags of class `function' | |
865 | ;; | |
866 | (defsubst semantic-tag-function-arguments (tag) | |
867 | "Return the arguments of the function that TAG describes. | |
868 | That is the value of the `:arguments' attribute." | |
869 | (semantic-tag-get-attribute tag :arguments)) | |
870 | ||
871 | (defsubst semantic-tag-function-throws (tag) | |
872 | "Return the exceptions the function that TAG describes can throw. | |
873 | That is the value of the `:throws' attribute." | |
874 | (semantic-tag-get-attribute tag :throws)) | |
875 | ||
876 | (defsubst semantic-tag-function-parent (tag) | |
877 | "Return the parent of the function that TAG describes. | |
878 | That is the value of the `:parent' attribute. | |
879 | A function has a parent if it is a method of a class, and if the | |
880 | function does not appear in body of it's parent class." | |
881 | (semantic-tag-named-parent tag)) | |
882 | ||
883 | (defsubst semantic-tag-function-destructor-p (tag) | |
884 | "Return non-nil if TAG describes a destructor function. | |
885 | That is the value of the `:destructor-flag' attribute." | |
886 | (semantic-tag-get-attribute tag :destructor-flag)) | |
887 | ||
888 | (defsubst semantic-tag-function-constructor-p (tag) | |
889 | "Return non-nil if TAG describes a constructor function. | |
890 | That is the value of the `:constructor-flag' attribute." | |
891 | (semantic-tag-get-attribute tag :constructor-flag)) | |
892 | ||
893 | ;;; Tags of class `variable' | |
894 | ;; | |
895 | (defsubst semantic-tag-variable-default (tag) | |
896 | "Return the default value of the variable that TAG describes. | |
897 | That is the value of the attribute `:default-value'." | |
898 | (semantic-tag-get-attribute tag :default-value)) | |
899 | ||
900 | (defsubst semantic-tag-variable-constant-p (tag) | |
901 | "Return non-nil if the variable that TAG describes is a constant. | |
902 | That is the value of the attribute `:constant-flag'." | |
903 | (semantic-tag-get-attribute tag :constant-flag)) | |
904 | ||
905 | ;;; Tags of class `include' | |
906 | ;; | |
907 | (defsubst semantic-tag-include-system-p (tag) | |
908 | "Return non-nil if the include that TAG describes is a system include. | |
909 | That is the value of the attribute `:system-flag'." | |
910 | (semantic-tag-get-attribute tag :system-flag)) | |
911 | ||
912 | (define-overloadable-function semantic-tag-include-filename (tag) | |
913 | "Return a filename representation of TAG. | |
914 | The default action is to return the `semantic-tag-name'. | |
915 | Some languages do not use full filenames in their include statements. | |
916 | Override this method to translate the code represenation | |
917 | into a filename. (A relative filename if necessary.) | |
918 | ||
919 | See `semantic-dependency-tag-file' to expand an include | |
920 | tag to a full file name.") | |
921 | ||
922 | (defun semantic-tag-include-filename-default (tag) | |
923 | "Return a filename representation of TAG. | |
924 | Returns `semantic-tag-name'." | |
925 | (semantic-tag-name tag)) | |
926 | ||
927 | ;;; Tags of class `code' | |
928 | ;; | |
929 | (defsubst semantic-tag-code-detail (tag) | |
930 | "Return detail information from code that TAG describes. | |
931 | That is the value of the attribute `:detail'." | |
932 | (semantic-tag-get-attribute tag :detail)) | |
933 | ||
934 | ;;; Tags of class `alias' | |
935 | ;; | |
936 | (defsubst semantic-tag-new-alias (name meta-tag-class value &rest attributes) | |
937 | "Create a semantic tag of class alias. | |
938 | NAME is a name for this alias. | |
939 | META-TAG-CLASS is the class of the tag this tag is an alias. | |
940 | VALUE is the aliased definition. | |
941 | ATTRIBUTES is a list of additional attributes belonging to this tag." | |
942 | (apply 'semantic-tag name 'alias | |
943 | :aliasclass meta-tag-class | |
944 | :definition value | |
945 | attributes)) | |
946 | ||
947 | (defsubst semantic-tag-alias-class (tag) | |
948 | "Return the class of tag TAG is an alias." | |
949 | (semantic-tag-get-attribute tag :aliasclass)) | |
950 | ||
9d389824 CY |
951 | (define-overloadable-function semantic-tag-alias-definition (tag) |
952 | "Return the definition TAG is an alias. | |
953 | The returned value is a tag of the class that | |
954 | `semantic-tag-alias-class' returns for TAG. | |
955 | The default is to return the value of the :definition attribute. | |
956 | Return nil if TAG is not of class 'alias." | |
957 | (when (semantic-tag-of-class-p tag 'alias) | |
958 | (:override | |
959 | (semantic-tag-get-attribute tag :definition)))) | |
960 | ||
961 | ;;; Language Specific Tag access via overload | |
962 | ;; | |
55b522b2 | 963 | ;;;###autoload |
9d389824 CY |
964 | (define-overloadable-function semantic-tag-components (tag) |
965 | "Return a list of components for TAG. | |
966 | A Component is a part of TAG which itself may be a TAG. | |
967 | Examples include the elements of a structure in a | |
968 | tag of class `type, or the list of arguments to a | |
969 | tag of class 'function." | |
970 | ) | |
971 | ||
972 | (defun semantic-tag-components-default (tag) | |
973 | "Return a list of components for TAG. | |
974 | Perform the described task in `semantic-tag-components'." | |
975 | (cond ((semantic-tag-of-class-p tag 'type) | |
976 | (semantic-tag-type-members tag)) | |
977 | ((semantic-tag-of-class-p tag 'function) | |
978 | (semantic-tag-function-arguments tag)) | |
979 | (t nil))) | |
980 | ||
9d389824 CY |
981 | (define-overloadable-function semantic-tag-components-with-overlays (tag) |
982 | "Return the list of top level components belonging to TAG. | |
983 | Children are any sub-tags which contain overlays. | |
984 | ||
985 | Default behavior is to get `semantic-tag-components' in addition | |
986 | to the components of an anonymous types (if applicable.) | |
987 | ||
988 | Note for language authors: | |
989 | If a mode defines a language tag that has tags in it with overlays | |
990 | you should still return them with this function. | |
991 | Ignoring this step will prevent several features from working correctly." | |
992 | ) | |
993 | ||
994 | (defun semantic-tag-components-with-overlays-default (tag) | |
995 | "Return the list of top level components belonging to TAG. | |
996 | Children are any sub-tags which contain overlays. | |
997 | The default action collects regular components of TAG, in addition | |
9bf6c65c | 998 | to any components belonging to an anonymous type." |
9d389824 CY |
999 | (let ((explicit-children (semantic-tag-components tag)) |
1000 | (type (semantic-tag-type tag)) | |
1001 | (anon-type-children nil) | |
1002 | (all-children nil)) | |
1003 | ;; Identify if this tag has an anonymous structure as | |
1004 | ;; its type. This implies it may have children with overlays. | |
1005 | (when (and type (semantic-tag-p type)) | |
1006 | (setq anon-type-children (semantic-tag-components type)) | |
1007 | ;; Add anonymous children | |
1008 | (while anon-type-children | |
1009 | (when (semantic-tag-with-position-p (car anon-type-children)) | |
1010 | (setq all-children (cons (car anon-type-children) all-children))) | |
1011 | (setq anon-type-children (cdr anon-type-children)))) | |
1012 | ;; Add explicit children | |
1013 | (while explicit-children | |
1014 | (when (semantic-tag-with-position-p (car explicit-children)) | |
1015 | (setq all-children (cons (car explicit-children) all-children))) | |
1016 | (setq explicit-children (cdr explicit-children))) | |
1017 | ;; Return | |
1018 | (nreverse all-children))) | |
1019 | ||
1020 | (defun semantic-tag-children-compatibility (tag &optional positiononly) | |
1021 | "Return children of TAG. | |
1022 | If POSITIONONLY is nil, use `semantic-tag-components'. | |
1023 | If POSITIONONLY is non-nil, use `semantic-tag-components-with-overlays'. | |
1024 | DO NOT use this fcn in new code. Use one of the above instead." | |
1025 | (if positiononly | |
1026 | (semantic-tag-components-with-overlays tag) | |
1027 | (semantic-tag-components tag))) | |
1028 | \f | |
1029 | ;;; Tag Region | |
1030 | ;; | |
1031 | ;; A Tag represents a region in a buffer. You can narrow to that tag. | |
1032 | ;; | |
1033 | (defun semantic-narrow-to-tag (&optional tag) | |
1034 | "Narrow to the region specified by the bounds of TAG. | |
1035 | See `semantic-tag-bounds'." | |
1036 | (interactive) | |
1037 | (if (not tag) (setq tag (semantic-current-tag))) | |
1038 | (narrow-to-region (semantic-tag-start tag) | |
1039 | (semantic-tag-end tag))) | |
1040 | ||
1041 | (defmacro semantic-with-buffer-narrowed-to-current-tag (&rest body) | |
1042 | "Execute BODY with the buffer narrowed to the current tag." | |
1043 | `(save-restriction | |
1044 | (semantic-narrow-to-tag (semantic-current-tag)) | |
1045 | ,@body)) | |
1046 | (put 'semantic-with-buffer-narrowed-to-current-tag 'lisp-indent-function 0) | |
1047 | (add-hook 'edebug-setup-hook | |
1048 | (lambda () | |
1049 | (def-edebug-spec semantic-with-buffer-narrowed-to-current-tag | |
1050 | (def-body)))) | |
1051 | ||
1052 | (defmacro semantic-with-buffer-narrowed-to-tag (tag &rest body) | |
1053 | "Narrow to TAG, and execute BODY." | |
1054 | `(save-restriction | |
1055 | (semantic-narrow-to-tag ,tag) | |
1056 | ,@body)) | |
1057 | (put 'semantic-with-buffer-narrowed-to-tag 'lisp-indent-function 1) | |
1058 | (add-hook 'edebug-setup-hook | |
1059 | (lambda () | |
1060 | (def-edebug-spec semantic-with-buffer-narrowed-to-tag | |
1061 | (def-body)))) | |
1062 | \f | |
1063 | ;;; Tag Hooks | |
1064 | ;; | |
1065 | ;; Semantic may want to provide special hooks when specific operations | |
1066 | ;; are about to happen on a given tag. These routines allow for hook | |
1067 | ;; maintenance on a tag. | |
1068 | ||
1069 | ;; Internal global variable used to manage tag hooks. For example, | |
1070 | ;; some implementation of `remove-hook' checks that the hook variable | |
1071 | ;; is `default-boundp'. | |
1072 | (defvar semantic--tag-hook-value) | |
1073 | ||
1074 | (defun semantic-tag-add-hook (tag hook function &optional append) | |
1075 | "Onto TAG, add to the value of HOOK the function FUNCTION. | |
1076 | FUNCTION is added (if necessary) at the beginning of the hook list | |
1077 | unless the optional argument APPEND is non-nil, in which case | |
1078 | FUNCTION is added at the end. | |
1079 | HOOK should be a symbol, and FUNCTION may be any valid function. | |
1080 | See also the function `add-hook'." | |
1081 | (let ((semantic--tag-hook-value (semantic--tag-get-property tag hook))) | |
1082 | (add-hook 'semantic--tag-hook-value function append) | |
1083 | (semantic--tag-put-property tag hook semantic--tag-hook-value) | |
1084 | semantic--tag-hook-value)) | |
1085 | ||
1086 | (defun semantic-tag-remove-hook (tag hook function) | |
1087 | "Onto TAG, remove from the value of HOOK the function FUNCTION. | |
1088 | HOOK should be a symbol, and FUNCTION may be any valid function. If | |
1089 | FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in | |
1090 | the list of hooks to run in HOOK, then nothing is done. | |
1091 | See also the function `remove-hook'." | |
1092 | (let ((semantic--tag-hook-value (semantic--tag-get-property tag hook))) | |
1093 | (remove-hook 'semantic--tag-hook-value function) | |
1094 | (semantic--tag-put-property tag hook semantic--tag-hook-value) | |
1095 | semantic--tag-hook-value)) | |
1096 | ||
1097 | (defun semantic--tag-run-hooks (tag hook &rest args) | |
1098 | "Run for TAG all expressions saved on the property HOOK. | |
1099 | Each hook expression must take at least one argument, the TAG. | |
1100 | For any given situation, additional ARGS may be passed." | |
1101 | (let ((semantic--tag-hook-value (semantic--tag-get-property tag hook)) | |
1102 | (arglist (cons tag args))) | |
1103 | (condition-case err | |
1104 | ;; If a hook bombs, ignore it! Usually this is tied into | |
1105 | ;; some sort of critical system. | |
1106 | (apply 'run-hook-with-args 'semantic--tag-hook-value arglist) | |
1107 | (error (message "Error: %S" err))))) | |
1108 | \f | |
1109 | ;;; Tags and Overlays | |
1110 | ;; | |
1111 | ;; Overlays are used so that we can quickly identify tags from | |
1112 | ;; buffer positions and regions using built in Emacs commands. | |
1113 | ;; | |
9d389824 CY |
1114 | (defsubst semantic--tag-unlink-list-from-buffer (tags) |
1115 | "Convert TAGS from using an overlay to using an overlay proxy. | |
1116 | This function is for internal use only." | |
1117 | (mapcar 'semantic--tag-unlink-from-buffer tags)) | |
1118 | ||
1119 | (defun semantic--tag-unlink-from-buffer (tag) | |
1120 | "Convert TAG from using an overlay to using an overlay proxy. | |
1121 | This function is for internal use only." | |
1122 | (when (semantic-tag-p tag) | |
1123 | (let ((o (semantic-tag-overlay tag))) | |
1124 | (when (semantic-overlay-p o) | |
1125 | (semantic--tag-set-overlay | |
1126 | tag (vector (semantic-overlay-start o) | |
1127 | (semantic-overlay-end o))) | |
1128 | (semantic-overlay-delete o)) | |
1129 | ;; Look for a link hook on TAG. | |
1130 | (semantic--tag-run-hooks tag 'unlink-hook) | |
1131 | ;; Fix the sub-tags which contain overlays. | |
1132 | (semantic--tag-unlink-list-from-buffer | |
1133 | (semantic-tag-components-with-overlays tag))))) | |
1134 | ||
1135 | (defsubst semantic--tag-link-list-to-buffer (tags) | |
1136 | "Convert TAGS from using an overlay proxy to using an overlay. | |
1137 | This function is for internal use only." | |
8aedfd3b | 1138 | (mapc 'semantic--tag-link-to-buffer tags)) |
9d389824 CY |
1139 | |
1140 | (defun semantic--tag-link-to-buffer (tag) | |
1141 | "Convert TAG from using an overlay proxy to using an overlay. | |
1142 | This function is for internal use only." | |
1143 | (when (semantic-tag-p tag) | |
1144 | (let ((o (semantic-tag-overlay tag))) | |
1145 | (when (and (vectorp o) (= (length o) 2)) | |
1146 | (setq o (semantic-make-overlay (aref o 0) (aref o 1) | |
1147 | (current-buffer))) | |
1148 | (semantic--tag-set-overlay tag o) | |
1149 | (semantic-overlay-put o 'semantic tag) | |
1150 | ;; Clear the :filename property | |
1151 | (semantic--tag-put-property tag :filename nil)) | |
1152 | ;; Look for a link hook on TAG. | |
1153 | (semantic--tag-run-hooks tag 'link-hook) | |
1154 | ;; Fix the sub-tags which contain overlays. | |
1155 | (semantic--tag-link-list-to-buffer | |
1156 | (semantic-tag-components-with-overlays tag))))) | |
1157 | ||
1158 | (defun semantic--tag-unlink-cache-from-buffer () | |
1159 | "Convert all tags in the current cache to use overlay proxys. | |
1160 | This function is for internal use only." | |
a175a831 | 1161 | (require 'semantic) |
9d389824 CY |
1162 | (semantic--tag-unlink-list-from-buffer |
1163 | ;; @todo- use fetch-tags-fast? | |
1164 | (semantic-fetch-tags))) | |
1165 | ||
1166 | (defvar semantic--buffer-cache) | |
1167 | ||
1168 | (defun semantic--tag-link-cache-to-buffer () | |
1169 | "Convert all tags in the current cache to use overlays. | |
1170 | This function is for internal use only." | |
a175a831 | 1171 | (require 'semantic) |
9d389824 CY |
1172 | (condition-case nil |
1173 | ;; In this unique case, we cannot call the usual toplevel fn. | |
1174 | ;; because we don't want a reparse, we want the old overlays. | |
1175 | (semantic--tag-link-list-to-buffer | |
1176 | semantic--buffer-cache) | |
1177 | ;; Recover when there is an error restoring the cache. | |
1178 | (error (message "Error recovering tag list") | |
1179 | (semantic-clear-toplevel-cache) | |
1180 | nil))) | |
1181 | \f | |
1182 | ;;; Tag Cooking | |
1183 | ;; | |
1184 | ;; Raw tags from a parser follow a different positional format than | |
1185 | ;; those used in the buffer cache. Raw tags need to be cooked into | |
1186 | ;; semantic cache friendly tags for use by the masses. | |
1187 | ;; | |
1188 | (defsubst semantic--tag-expanded-p (tag) | |
1189 | "Return non-nil if TAG is expanded. | |
1190 | This function is for internal use only. | |
1191 | See also the function `semantic--expand-tag'." | |
1192 | ;; In fact a cooked tag is actually a list of cooked tags | |
1193 | ;; because a raw tag can be expanded in several cooked ones! | |
1194 | (when (consp tag) | |
1195 | (while (and (semantic-tag-p (car tag)) | |
1196 | (vectorp (semantic-tag-overlay (car tag)))) | |
1197 | (setq tag (cdr tag))) | |
1198 | (null tag))) | |
1199 | ||
1200 | (defvar semantic-tag-expand-function nil | |
1201 | "Function used to expand a tag. | |
1202 | It is passed each tag production, and must return a list of tags | |
1203 | derived from it, or nil if it does not need to be expanded. | |
1204 | ||
1205 | Languages with compound definitions should use this function to expand | |
1206 | from one compound symbol into several. For example, in C or Java the | |
1207 | following definition is easily parsed into one tag: | |
1208 | ||
1209 | int a, b; | |
1210 | ||
1211 | This function should take this compound tag and turn it into two tags, | |
1212 | one for A, and the other for B.") | |
1213 | (make-variable-buffer-local 'semantic-tag-expand-function) | |
1214 | ||
1215 | (defun semantic--tag-expand (tag) | |
1216 | "Convert TAG from a raw state to a cooked state, and expand it. | |
1217 | Returns a list of cooked tags. | |
1218 | ||
1219 | The parser returns raw tags with positional data START END at the | |
1220 | end of the tag data structure (a list for now). We convert it from | |
1221 | that to a cooked state that uses an overlay proxy, that is, a vector | |
1222 | \[START END]. | |
1223 | ||
1224 | The raw tag is changed with side effects and maybe expanded in | |
1225 | several derived tags when the variable `semantic-tag-expand-function' | |
1226 | is set. | |
1227 | ||
1228 | This function is for internal use only." | |
1229 | (if (semantic--tag-expanded-p tag) | |
1230 | ;; Just return TAG if it is already expanded (by a grammar | |
1231 | ;; semantic action), or if it isn't recognized as a valid | |
1232 | ;; semantic tag. | |
1233 | tag | |
1234 | ||
1235 | ;; Try to cook the tag. This code will be removed when tag will | |
1236 | ;; be directly created with the right format. | |
1237 | (condition-case nil | |
1238 | (let ((ocdr (semantic--tag-overlay-cdr tag))) | |
1239 | ;; OCDR contains the sub-list of TAG whose car is the | |
1240 | ;; OVERLAY part of TAG. That is, a list (OVERLAY START END). | |
1241 | ;; Convert it into an overlay proxy ([START END]). | |
1242 | (semantic--tag-set-overlay | |
1243 | tag (vector (nth 1 ocdr) (nth 2 ocdr))) | |
1244 | ;; Remove START END positions at end of tag. | |
1245 | (setcdr ocdr nil) | |
1246 | ;; At this point (length TAG) must be 5! | |
1247 | ;;(unless (= (length tag) 5) | |
1248 | ;; (error "Tag expansion failed")) | |
1249 | ) | |
1250 | (error | |
1251 | (message "A Rule must return a single tag-line list!") | |
1252 | (debug tag) | |
1253 | nil)) | |
9d389824 CY |
1254 | ;; Expand based on local configuration |
1255 | (if semantic-tag-expand-function | |
1256 | (or (funcall semantic-tag-expand-function tag) | |
1257 | (list tag)) | |
1258 | (list tag)))) | |
1259 | \f | |
1260 | ;; Foreign tags | |
1261 | ;; | |
1262 | (defmacro semantic-foreign-tag-invalid (tag) | |
1263 | "Signal that TAG is an invalid foreign tag." | |
1264 | `(signal 'wrong-type-argument '(semantic-foreign-tag-p ,tag))) | |
1265 | ||
1266 | (defsubst semantic-foreign-tag-p (tag) | |
1267 | "Return non-nil if TAG is a foreign tag. | |
1268 | That is, a tag unlinked from the originating buffer, which carries the | |
1269 | originating buffer file name, and major mode." | |
1270 | (and (semantic-tag-p tag) | |
1271 | (semantic--tag-get-property tag :foreign-flag))) | |
1272 | ||
1273 | (defsubst semantic-foreign-tag-check (tag) | |
1274 | "Check that TAG is a valid foreign tag. | |
1275 | Signal an error if not." | |
1276 | (or (semantic-foreign-tag-p tag) | |
1277 | (semantic-foreign-tag-invalid tag))) | |
1278 | ||
1279 | (defun semantic-foreign-tag (&optional tag) | |
1280 | "Return a copy of TAG as a foreign tag, or nil if it can't be done. | |
1281 | TAG defaults to the tag at point in current buffer. | |
1282 | See also `semantic-foreign-tag-p'." | |
1283 | (or tag (setq tag (semantic-current-tag))) | |
1284 | (when (semantic-tag-p tag) | |
1285 | (let ((ftag (semantic-tag-copy tag nil t)) | |
1286 | ;; Do extra work for the doc strings, since this is a | |
1287 | ;; common use case. | |
1288 | (doc (condition-case nil | |
1289 | (semantic-documentation-for-tag tag) | |
1290 | (error nil)))) | |
1291 | ;; A foreign tag must carry its originating buffer file name! | |
1292 | (when (semantic--tag-get-property ftag :filename) | |
1293 | (semantic--tag-put-property ftag :mode (semantic-tag-mode tag)) | |
1294 | (semantic--tag-put-property ftag :documentation doc) | |
1295 | (semantic--tag-put-property ftag :foreign-flag t) | |
1296 | ftag)))) | |
1297 | ||
1298 | ;; High level obtain/insert foreign tag overloads | |
9d389824 CY |
1299 | (define-overloadable-function semantic-obtain-foreign-tag (&optional tag) |
1300 | "Obtain a foreign tag from TAG. | |
1301 | TAG defaults to the tag at point in current buffer. | |
1302 | Return the obtained foreign tag or nil if failed." | |
1303 | (semantic-foreign-tag tag)) | |
1304 | ||
1305 | (defun semantic-insert-foreign-tag-default (foreign-tag) | |
1306 | "Insert FOREIGN-TAG into the current buffer. | |
1307 | The default behavior assumes the current buffer is a language file, | |
1308 | and attempts to insert a prototype/function call." | |
1309 | ;; Long term goal: Have a mechanism for a tempo-like template insert | |
1310 | ;; for the given tag. | |
1311 | (insert (semantic-format-tag-prototype foreign-tag))) | |
1312 | ||
9d389824 CY |
1313 | (define-overloadable-function semantic-insert-foreign-tag (foreign-tag) |
1314 | "Insert FOREIGN-TAG into the current buffer. | |
1315 | Signal an error if FOREIGN-TAG is not a valid foreign tag. | |
1316 | This function is overridable with the symbol `insert-foreign-tag'." | |
1317 | (semantic-foreign-tag-check foreign-tag) | |
1318 | (:override) | |
1319 | (message (semantic-format-tag-summarize foreign-tag))) | |
1320 | ||
1321 | ;;; Support log modes here | |
1322 | (define-mode-local-override semantic-insert-foreign-tag | |
1323 | log-edit-mode (foreign-tag) | |
1324 | "Insert foreign tags into log-edit mode." | |
1325 | (insert (concat "(" (semantic-format-tag-name foreign-tag) "): "))) | |
1326 | ||
1327 | (define-mode-local-override semantic-insert-foreign-tag | |
1328 | change-log-mode (foreign-tag) | |
1329 | "Insert foreign tags into log-edit mode." | |
1330 | (insert (concat "(" (semantic-format-tag-name foreign-tag) "): "))) | |
9d389824 CY |
1331 | \f |
1332 | ;;; Compatibility | |
1333 | ;; | |
1334 | (defconst semantic-token-version | |
1335 | semantic-tag-version) | |
1336 | (defconst semantic-token-incompatible-version | |
1337 | semantic-tag-incompatible-version) | |
1338 | ||
9d389824 CY |
1339 | (defsubst semantic-token-type-parent (tag) |
1340 | "Return the parent of the type that TAG describes. | |
1341 | The return value is a list. A value of nil means no parents. | |
1342 | The `car' of the list is either the parent class, or a list | |
1343 | of parent classes. The `cdr' of the list is the list of | |
1344 | interfaces, or abstract classes which are parents of TAG." | |
1345 | (cons (semantic-tag-get-attribute tag :superclasses) | |
1346 | (semantic-tag-type-interfaces tag))) | |
1347 | (make-obsolete 'semantic-token-type-parent | |
1348 | "\ | |
1349 | use `semantic-tag-type-superclass' \ | |
86f1602f | 1350 | and `semantic-tag-type-interfaces' instead" "23.2") |
9d389824 | 1351 | |
9d389824 | 1352 | (semantic-alias-obsolete 'semantic-tag-make-assoc-list |
eefa91db | 1353 | 'semantic-tag-make-plist "23.2") |
9d389824 | 1354 | |
9d389824 | 1355 | (semantic-varalias-obsolete 'semantic-expand-nonterminal |
eefa91db | 1356 | 'semantic-tag-expand-function "23.2") |
9d389824 | 1357 | |
9d389824 CY |
1358 | (provide 'semantic/tag) |
1359 | ||
55b522b2 CY |
1360 | ;; Local variables: |
1361 | ;; generated-autoload-file: "loaddefs.el" | |
996bc9bf | 1362 | ;; generated-autoload-load-name: "semantic/tag" |
55b522b2 CY |
1363 | ;; End: |
1364 | ||
3999968a | 1365 | ;; arch-tag: f7813634-c4f0-4817-a487-cbaa84333353 |
996bc9bf | 1366 | ;;; semantic/tag.el ends here |