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