Commit | Line | Data |
---|---|---|
996bc9bf | 1 | ;;; semantic/tag.el --- tag creation and access |
9d389824 | 2 | |
73b0cd50 | 3 | ;; Copyright (C) 1999-2005, 2007-2011 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") | |
9d389824 | 54 | |
ac73b1fa | 55 | (defconst semantic-tag-version "2.0" |
9d389824 CY |
56 | "Version string of semantic tags made with this code.") |
57 | ||
58 | (defconst semantic-tag-incompatible-version "1.0" | |
59 | "Version string of semantic tags which are not currently compatible. | |
60 | These old style tags may be loaded from a file with semantic db. | |
61 | In this case, we must flush the old tags and start over.") | |
62 | \f | |
63 | ;;; Primitive Tag access system: | |
64 | ;; | |
65 | ;; Raw tags in semantic are lists of 5 elements: | |
66 | ;; | |
67 | ;; (NAME CLASS ATTRIBUTES PROPERTIES OVERLAY) | |
68 | ;; | |
69 | ;; Where: | |
70 | ;; | |
71 | ;; - NAME is a string that represents the tag name. | |
72 | ;; | |
73 | ;; - CLASS is a symbol that represent the class of the tag (for | |
74 | ;; example, usual classes are `type', `function', `variable', | |
75 | ;; `include', `package', `code'). | |
76 | ;; | |
77 | ;; - ATTRIBUTES is a public list of attributes that describes | |
78 | ;; language data represented by the tag (for example, a variable | |
79 | ;; can have a `:constant-flag' attribute, a function an `:arguments' | |
80 | ;; attribute, etc.). | |
81 | ;; | |
82 | ;; - PROPERTIES is a private list of properties used internally. | |
83 | ;; | |
84 | ;; - OVERLAY represent the location of data described by the tag. | |
85 | ;; | |
86 | ||
87 | (defsubst semantic-tag-name (tag) | |
88 | "Return the name of TAG. | |
89 | For functions, variables, classes, typedefs, etc., this is the identifier | |
90 | that is being defined. For tags without an obvious associated name, this | |
91 | may be the statement type, e.g., this may return @code{print} for python's | |
92 | print statement." | |
93 | (car tag)) | |
94 | ||
95 | (defsubst semantic-tag-class (tag) | |
96 | "Return the class of TAG. | |
97 | That is, the symbol 'variable, 'function, 'type, or other. | |
98 | There is no limit to the symbols that may represent the class of a tag. | |
99 | Each parser generates tags with classes defined by it. | |
100 | ||
101 | For functional languages, typical tag classes are: | |
102 | ||
103 | @table @code | |
104 | @item type | |
105 | Data types, named map for a memory block. | |
106 | @item function | |
107 | A function or method, or named execution location. | |
108 | @item variable | |
109 | A variable, or named storage for data. | |
110 | @item include | |
111 | Statement that represents a file from which more tags can be found. | |
112 | @item package | |
9bf6c65c | 113 | Statement that declares this file's package name. |
9d389824 CY |
114 | @item code |
115 | Code that has not name or binding to any other symbol, such as in a script. | |
116 | @end table | |
117 | " | |
118 | (nth 1 tag)) | |
119 | ||
120 | (defsubst semantic-tag-attributes (tag) | |
121 | "Return the list of public attributes of TAG. | |
122 | That is a property list: (ATTRIBUTE-1 VALUE-1 ATTRIBUTE-2 VALUE-2...)." | |
123 | (nth 2 tag)) | |
124 | ||
125 | (defsubst semantic-tag-properties (tag) | |
126 | "Return the list of private properties of TAG. | |
127 | That is a property list: (PROPERTY-1 VALUE-1 PROPERTY-2 VALUE-2...)." | |
128 | (nth 3 tag)) | |
129 | ||
130 | (defsubst semantic-tag-overlay (tag) | |
131 | "Return the OVERLAY part of TAG. | |
132 | That is, an overlay or an unloaded buffer representation. | |
133 | This function can also return an array of the form [ START END ]. | |
134 | This occurs for tags that are not currently linked into a buffer." | |
135 | (nth 4 tag)) | |
136 | ||
137 | (defsubst semantic--tag-overlay-cdr (tag) | |
138 | "Return the cons cell whose car is the OVERLAY part of TAG. | |
139 | That function is for internal use only." | |
140 | (nthcdr 4 tag)) | |
141 | ||
142 | (defsubst semantic--tag-set-overlay (tag overlay) | |
143 | "Set the overlay part of TAG with OVERLAY. | |
144 | That function is for internal use only." | |
145 | (setcar (semantic--tag-overlay-cdr tag) overlay)) | |
146 | ||
147 | (defsubst semantic-tag-start (tag) | |
148 | "Return the start location of TAG." | |
149 | (let ((o (semantic-tag-overlay tag))) | |
150 | (if (semantic-overlay-p o) | |
151 | (semantic-overlay-start o) | |
152 | (aref o 0)))) | |
153 | ||
154 | (defsubst semantic-tag-end (tag) | |
155 | "Return the end location of TAG." | |
156 | (let ((o (semantic-tag-overlay tag))) | |
157 | (if (semantic-overlay-p o) | |
158 | (semantic-overlay-end o) | |
159 | (aref o 1)))) | |
160 | ||
161 | (defsubst semantic-tag-bounds (tag) | |
162 | "Return the location (START END) of data TAG describes." | |
163 | (list (semantic-tag-start tag) | |
164 | (semantic-tag-end tag))) | |
165 | ||
166 | (defun semantic-tag-set-bounds (tag start end) | |
167 | "In TAG, set the START and END location of data it describes." | |
168 | (let ((o (semantic-tag-overlay tag))) | |
169 | (if (semantic-overlay-p o) | |
170 | (semantic-overlay-move o start end) | |
171 | (semantic--tag-set-overlay tag (vector start end))))) | |
172 | ||
173 | (defun semantic-tag-in-buffer-p (tag) | |
174 | "Return the buffer TAG resides in IFF tag is already in a buffer. | |
175 | If a tag is not in a buffer, return nil." | |
176 | (let ((o (semantic-tag-overlay tag))) | |
177 | ;; TAG is currently linked to a buffer, return it. | |
178 | (when (and (semantic-overlay-p o) | |
179 | (semantic-overlay-live-p o)) | |
180 | (semantic-overlay-buffer o)))) | |
181 | ||
182 | (defsubst semantic--tag-get-property (tag property) | |
183 | "From TAG, extract the value of PROPERTY. | |
184 | Return the value found, or nil if PROPERTY is not one of the | |
185 | properties of TAG. | |
186 | That function is for internal use only." | |
187 | (plist-get (semantic-tag-properties tag) property)) | |
188 | ||
189 | (defun semantic-tag-buffer (tag) | |
190 | "Return the buffer TAG resides in. | |
191 | If TAG has an originating file, read that file into a (maybe new) | |
192 | buffer, and return it. | |
193 | Return nil if there is no buffer for this tag." | |
194 | (let ((buff (semantic-tag-in-buffer-p tag))) | |
195 | (if buff | |
196 | buff | |
197 | ;; TAG has an originating file, read that file into a buffer, and | |
198 | ;; return it. | |
199 | (if (semantic--tag-get-property tag :filename) | |
1eac105a CY |
200 | (save-match-data |
201 | (find-file-noselect (semantic--tag-get-property tag :filename))) | |
9d389824 CY |
202 | ;; TAG is not in Emacs right now, no buffer is available. |
203 | )))) | |
204 | ||
205 | (defun semantic-tag-mode (&optional tag) | |
206 | "Return the major mode active for TAG. | |
207 | TAG defaults to the tag at point in current buffer. | |
208 | If TAG has a :mode property return it. | |
209 | If point is inside TAG bounds, return the major mode active at point. | |
210 | Return the major mode active at beginning of TAG otherwise. | |
211 | See also the function `semantic-ctxt-current-mode'." | |
212 | (or tag (setq tag (semantic-current-tag))) | |
213 | (or (semantic--tag-get-property tag :mode) | |
214 | (let ((buffer (semantic-tag-buffer tag)) | |
215 | (start (semantic-tag-start tag)) | |
216 | (end (semantic-tag-end tag))) | |
217 | (save-excursion | |
218 | (and buffer (set-buffer buffer)) | |
219 | ;; Unless point is inside TAG bounds, move it to the | |
220 | ;; beginning of TAG. | |
221 | (or (and (>= (point) start) (< (point) end)) | |
222 | (goto-char start)) | |
ac73b1fa | 223 | (require 'semantic/ctxt) |
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. | |
dd9af436 CY |
690 | No properties are copied except for :filename. |
691 | Overlay will be a vector. | |
692 | FILTER takes TAG as an argument, and should return a `semantic-tag'. | |
9d389824 CY |
693 | It is safe for FILTER to modify the input tag and return it." |
694 | (when (not filter) (setq filter 'identity)) | |
695 | (when (not (semantic-tag-p tag)) | |
696 | (signal 'wrong-type-argument (list tag 'semantic-tag-p))) | |
dd9af436 CY |
697 | (let ((ol (semantic-tag-overlay tag)) |
698 | (fn (semantic-tag-file-name tag))) | |
699 | (funcall filter (list (semantic-tag-name tag) | |
700 | (semantic-tag-class tag) | |
701 | (semantic--tag-deep-copy-attributes | |
702 | (semantic-tag-attributes tag) filter) | |
703 | ;; Only copy the filename property | |
704 | (when fn (list :filename fn)) | |
705 | ;; Only setup a vector if we had an overlay. | |
706 | (when ol (vector (semantic-tag-start tag) | |
707 | (semantic-tag-end tag))))))) | |
9d389824 CY |
708 | |
709 | (defun semantic--tag-deep-copy-attributes (attrs &optional filter) | |
710 | "Make a deep copy of ATTRS, applying FILTER to each child-tag. | |
711 | ||
9bf6c65c | 712 | It is safe to modify ATTR, 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 | (when (car attrs) | |
717 | (when (not (symbolp (car attrs))) (error "Bad Attribute List in tag")) | |
718 | (cons (car attrs) | |
719 | (cons (semantic--tag-deep-copy-value (nth 1 attrs) filter) | |
720 | (semantic--tag-deep-copy-attributes (nthcdr 2 attrs) filter))))) | |
721 | ||
722 | (defun semantic--tag-deep-copy-value (value &optional filter) | |
723 | "Make a deep copy of VALUE, applying FILTER to each child-tag. | |
724 | ||
9bf6c65c | 725 | It is safe to modify VALUE, and return a permutation of that list. |
9d389824 CY |
726 | |
727 | FILTER takes TAG as an argument, and should returns a semantic-tag. | |
728 | It is safe for FILTER to modify the input tag and return it." | |
729 | (cond | |
730 | ;; Another tag. | |
731 | ((semantic-tag-p value) | |
732 | (semantic-tag-deep-copy-one-tag value filter)) | |
733 | ||
734 | ;; A list of more tags | |
735 | ((and (listp value) (semantic-tag-p (car value))) | |
736 | (semantic--tag-deep-copy-tag-list value filter)) | |
737 | ||
738 | ;; Some arbitrary data. | |
739 | (t value))) | |
740 | ||
741 | (defun semantic--tag-deep-copy-tag-list (tags &optional filter) | |
742 | "Make a deep copy of TAGS, applying FILTER to each child-tag. | |
743 | ||
9bf6c65c | 744 | It is safe to modify the TAGS list, and return a permutation of that list. |
9d389824 CY |
745 | |
746 | FILTER takes TAG as an argument, and should returns a semantic-tag. | |
747 | It is safe for FILTER to modify the input tag and return it." | |
748 | (when (car tags) | |
749 | (if (semantic-tag-p (car tags)) | |
750 | (cons (semantic-tag-deep-copy-one-tag (car tags) filter) | |
751 | (semantic--tag-deep-copy-tag-list (cdr tags) filter)) | |
752 | (cons (car tags) (semantic--tag-deep-copy-tag-list (cdr tags) filter))))) | |
753 | ||
754 | \f | |
755 | ;;; Standard Tag Access | |
756 | ;; | |
757 | ||
758 | ;;; Common | |
759 | ;; | |
9d389824 CY |
760 | (defsubst semantic-tag-modifiers (tag) |
761 | "Return the value of the `:typemodifiers' attribute of TAG." | |
762 | (semantic-tag-get-attribute tag :typemodifiers)) | |
763 | ||
764 | (defun semantic-tag-docstring (tag &optional buffer) | |
765 | "Return the documentation of TAG. | |
766 | That is the value defined by the `:documentation' attribute. | |
767 | Optional argument BUFFER indicates where to get the text from. | |
768 | If not provided, then only the POSITION can be provided. | |
769 | ||
770 | If you want to get documentation for languages that do not store | |
771 | the documentation string in the tag itself, use | |
772 | `semantic-documentation-for-tag' instead." | |
773 | (let ((p (semantic-tag-get-attribute tag :documentation))) | |
774 | (cond | |
775 | ((stringp p) p) ;; it is the doc string. | |
776 | ||
777 | ((semantic-lex-token-with-text-p p) | |
778 | (semantic-lex-token-text p)) | |
779 | ||
780 | ((and (semantic-lex-token-without-text-p p) | |
781 | buffer) | |
782 | (with-current-buffer buffer | |
783 | (semantic-lex-token-text (car (semantic-lex p (1+ p)))))) | |
784 | ||
785 | (t nil)))) | |
786 | ||
787 | ;;; Generic attributes for tags of any class. | |
788 | ;; | |
789 | (defsubst semantic-tag-named-parent (tag) | |
790 | "Return the parent of TAG. | |
791 | That is the value of the `:parent' attribute. | |
792 | If a definition can occur outside an actual parent structure, but | |
793 | refers to that parent by name, then the :parent attribute should be used." | |
794 | (semantic-tag-get-attribute tag :parent)) | |
795 | ||
796 | ;;; Tags of class `type' | |
797 | ||
798 | (defun semantic-tag-type-superclasses (tag) | |
799 | "Return the list of superclass names of the type that TAG describes." | |
800 | (let ((supers (semantic-tag-get-attribute tag :superclasses))) | |
801 | (cond ((stringp supers) | |
802 | ;; If we have a string, make it a list. | |
803 | (list supers)) | |
804 | ((semantic-tag-p supers) | |
805 | ;; If we have one tag, return just the name. | |
806 | (list (semantic-tag-name supers))) | |
807 | ((and (consp supers) (semantic-tag-p (car supers))) | |
808 | ;; If we have a tag list, then return the names. | |
809 | (mapcar (lambda (s) (semantic-tag-name s)) | |
810 | supers)) | |
811 | ((consp supers) | |
812 | ;; A list of something, return it. | |
813 | supers)))) | |
814 | ||
815 | (defun semantic--tag-find-parent-by-name (name supers) | |
816 | "Find the superclass NAME in the list of SUPERS. | |
817 | If a simple search doesn't do it, try splitting up the names | |
818 | in SUPERS." | |
819 | (let ((stag nil)) | |
820 | (setq stag (semantic-find-first-tag-by-name name supers)) | |
a60f2e7b | 821 | |
9d389824 | 822 | (when (not stag) |
a175a831 | 823 | (require 'semantic/analyze/fcn) |
9d389824 CY |
824 | (dolist (S supers) |
825 | (let* ((sname (semantic-tag-name S)) | |
826 | (splitparts (semantic-analyze-split-name sname)) | |
827 | (parts (if (stringp splitparts) | |
828 | (list splitparts) | |
829 | (nreverse splitparts)))) | |
830 | (when (string= name (car parts)) | |
831 | (setq stag S)) | |
832 | ))) | |
833 | ||
834 | stag)) | |
835 | ||
836 | (defun semantic-tag-type-superclass-protection (tag parentstring) | |
837 | "Return the inheritance protection in TAG from PARENTSTRING. | |
838 | PARENTSTRING is the name of the parent being inherited. | |
839 | The return protection is a symbol, 'public, 'protection, and 'private." | |
840 | (let ((supers (semantic-tag-get-attribute tag :superclasses))) | |
841 | (cond ((stringp supers) | |
842 | 'public) | |
843 | ((semantic-tag-p supers) | |
844 | (let ((prot (semantic-tag-get-attribute supers :protection))) | |
845 | (or (cdr (assoc prot '(("public" . public) | |
846 | ("protected" . protected) | |
847 | ("private" . private)))) | |
848 | 'public))) | |
849 | ((and (consp supers) (stringp (car supers))) | |
850 | 'public) | |
851 | ((and (consp supers) (semantic-tag-p (car supers))) | |
852 | (let* ((stag (semantic--tag-find-parent-by-name parentstring supers)) | |
853 | (prot (when stag | |
854 | (semantic-tag-get-attribute stag :protection)))) | |
855 | (or (cdr (assoc prot '(("public" . public) | |
856 | ("protected" . protected) | |
857 | ("private" . private)))) | |
858 | (when (equal prot "unspecified") | |
859 | (if (semantic-tag-of-type-p tag "class") | |
860 | 'private | |
861 | 'public)) | |
862 | 'public)))) | |
863 | )) | |
864 | ||
865 | (defsubst semantic-tag-type-interfaces (tag) | |
866 | "Return the list of interfaces of the type that TAG describes." | |
867 | ;; @todo - make this as robust as the above. | |
868 | (semantic-tag-get-attribute tag :interfaces)) | |
869 | ||
870 | ;;; Tags of class `function' | |
871 | ;; | |
872 | (defsubst semantic-tag-function-arguments (tag) | |
873 | "Return the arguments of the function that TAG describes. | |
874 | That is the value of the `:arguments' attribute." | |
875 | (semantic-tag-get-attribute tag :arguments)) | |
876 | ||
877 | (defsubst semantic-tag-function-throws (tag) | |
878 | "Return the exceptions the function that TAG describes can throw. | |
879 | That is the value of the `:throws' attribute." | |
880 | (semantic-tag-get-attribute tag :throws)) | |
881 | ||
882 | (defsubst semantic-tag-function-parent (tag) | |
883 | "Return the parent of the function that TAG describes. | |
884 | That is the value of the `:parent' attribute. | |
885 | A function has a parent if it is a method of a class, and if the | |
dd9af436 | 886 | function does not appear in body of its parent class." |
9d389824 CY |
887 | (semantic-tag-named-parent tag)) |
888 | ||
889 | (defsubst semantic-tag-function-destructor-p (tag) | |
890 | "Return non-nil if TAG describes a destructor function. | |
891 | That is the value of the `:destructor-flag' attribute." | |
892 | (semantic-tag-get-attribute tag :destructor-flag)) | |
893 | ||
894 | (defsubst semantic-tag-function-constructor-p (tag) | |
895 | "Return non-nil if TAG describes a constructor function. | |
896 | That is the value of the `:constructor-flag' attribute." | |
897 | (semantic-tag-get-attribute tag :constructor-flag)) | |
898 | ||
899 | ;;; Tags of class `variable' | |
900 | ;; | |
901 | (defsubst semantic-tag-variable-default (tag) | |
902 | "Return the default value of the variable that TAG describes. | |
903 | That is the value of the attribute `:default-value'." | |
904 | (semantic-tag-get-attribute tag :default-value)) | |
905 | ||
906 | (defsubst semantic-tag-variable-constant-p (tag) | |
907 | "Return non-nil if the variable that TAG describes is a constant. | |
908 | That is the value of the attribute `:constant-flag'." | |
909 | (semantic-tag-get-attribute tag :constant-flag)) | |
910 | ||
911 | ;;; Tags of class `include' | |
912 | ;; | |
913 | (defsubst semantic-tag-include-system-p (tag) | |
914 | "Return non-nil if the include that TAG describes is a system include. | |
915 | That is the value of the attribute `:system-flag'." | |
916 | (semantic-tag-get-attribute tag :system-flag)) | |
917 | ||
918 | (define-overloadable-function semantic-tag-include-filename (tag) | |
919 | "Return a filename representation of TAG. | |
920 | The default action is to return the `semantic-tag-name'. | |
921 | Some languages do not use full filenames in their include statements. | |
40ba43b4 | 922 | Override this method to translate the code representation |
9d389824 CY |
923 | into a filename. (A relative filename if necessary.) |
924 | ||
925 | See `semantic-dependency-tag-file' to expand an include | |
926 | tag to a full file name.") | |
927 | ||
928 | (defun semantic-tag-include-filename-default (tag) | |
929 | "Return a filename representation of TAG. | |
930 | Returns `semantic-tag-name'." | |
931 | (semantic-tag-name tag)) | |
932 | ||
933 | ;;; Tags of class `code' | |
934 | ;; | |
935 | (defsubst semantic-tag-code-detail (tag) | |
936 | "Return detail information from code that TAG describes. | |
937 | That is the value of the attribute `:detail'." | |
938 | (semantic-tag-get-attribute tag :detail)) | |
939 | ||
940 | ;;; Tags of class `alias' | |
941 | ;; | |
942 | (defsubst semantic-tag-new-alias (name meta-tag-class value &rest attributes) | |
943 | "Create a semantic tag of class alias. | |
944 | NAME is a name for this alias. | |
945 | META-TAG-CLASS is the class of the tag this tag is an alias. | |
946 | VALUE is the aliased definition. | |
947 | ATTRIBUTES is a list of additional attributes belonging to this tag." | |
948 | (apply 'semantic-tag name 'alias | |
949 | :aliasclass meta-tag-class | |
950 | :definition value | |
951 | attributes)) | |
952 | ||
953 | (defsubst semantic-tag-alias-class (tag) | |
954 | "Return the class of tag TAG is an alias." | |
955 | (semantic-tag-get-attribute tag :aliasclass)) | |
956 | ||
9d389824 CY |
957 | (define-overloadable-function semantic-tag-alias-definition (tag) |
958 | "Return the definition TAG is an alias. | |
959 | The returned value is a tag of the class that | |
960 | `semantic-tag-alias-class' returns for TAG. | |
961 | The default is to return the value of the :definition attribute. | |
962 | Return nil if TAG is not of class 'alias." | |
963 | (when (semantic-tag-of-class-p tag 'alias) | |
964 | (:override | |
965 | (semantic-tag-get-attribute tag :definition)))) | |
966 | ||
967 | ;;; Language Specific Tag access via overload | |
968 | ;; | |
55b522b2 | 969 | ;;;###autoload |
9d389824 CY |
970 | (define-overloadable-function semantic-tag-components (tag) |
971 | "Return a list of components for TAG. | |
972 | A Component is a part of TAG which itself may be a TAG. | |
973 | Examples include the elements of a structure in a | |
974 | tag of class `type, or the list of arguments to a | |
975 | tag of class 'function." | |
976 | ) | |
977 | ||
978 | (defun semantic-tag-components-default (tag) | |
979 | "Return a list of components for TAG. | |
980 | Perform the described task in `semantic-tag-components'." | |
981 | (cond ((semantic-tag-of-class-p tag 'type) | |
982 | (semantic-tag-type-members tag)) | |
983 | ((semantic-tag-of-class-p tag 'function) | |
984 | (semantic-tag-function-arguments tag)) | |
985 | (t nil))) | |
986 | ||
9d389824 CY |
987 | (define-overloadable-function semantic-tag-components-with-overlays (tag) |
988 | "Return the list of top level components belonging to TAG. | |
989 | Children are any sub-tags which contain overlays. | |
990 | ||
991 | Default behavior is to get `semantic-tag-components' in addition | |
992 | to the components of an anonymous types (if applicable.) | |
993 | ||
994 | Note for language authors: | |
995 | If a mode defines a language tag that has tags in it with overlays | |
996 | you should still return them with this function. | |
997 | Ignoring this step will prevent several features from working correctly." | |
998 | ) | |
999 | ||
1000 | (defun semantic-tag-components-with-overlays-default (tag) | |
1001 | "Return the list of top level components belonging to TAG. | |
1002 | Children are any sub-tags which contain overlays. | |
1003 | The default action collects regular components of TAG, in addition | |
9bf6c65c | 1004 | to any components belonging to an anonymous type." |
9d389824 CY |
1005 | (let ((explicit-children (semantic-tag-components tag)) |
1006 | (type (semantic-tag-type tag)) | |
1007 | (anon-type-children nil) | |
1008 | (all-children nil)) | |
1009 | ;; Identify if this tag has an anonymous structure as | |
1010 | ;; its type. This implies it may have children with overlays. | |
1011 | (when (and type (semantic-tag-p type)) | |
1012 | (setq anon-type-children (semantic-tag-components type)) | |
1013 | ;; Add anonymous children | |
1014 | (while anon-type-children | |
1015 | (when (semantic-tag-with-position-p (car anon-type-children)) | |
1016 | (setq all-children (cons (car anon-type-children) all-children))) | |
1017 | (setq anon-type-children (cdr anon-type-children)))) | |
1018 | ;; Add explicit children | |
1019 | (while explicit-children | |
1020 | (when (semantic-tag-with-position-p (car explicit-children)) | |
1021 | (setq all-children (cons (car explicit-children) all-children))) | |
1022 | (setq explicit-children (cdr explicit-children))) | |
1023 | ;; Return | |
1024 | (nreverse all-children))) | |
1025 | ||
1026 | (defun semantic-tag-children-compatibility (tag &optional positiononly) | |
1027 | "Return children of TAG. | |
1028 | If POSITIONONLY is nil, use `semantic-tag-components'. | |
1029 | If POSITIONONLY is non-nil, use `semantic-tag-components-with-overlays'. | |
1030 | DO NOT use this fcn in new code. Use one of the above instead." | |
1031 | (if positiononly | |
1032 | (semantic-tag-components-with-overlays tag) | |
1033 | (semantic-tag-components tag))) | |
1034 | \f | |
1035 | ;;; Tag Region | |
1036 | ;; | |
1037 | ;; A Tag represents a region in a buffer. You can narrow to that tag. | |
1038 | ;; | |
1039 | (defun semantic-narrow-to-tag (&optional tag) | |
1040 | "Narrow to the region specified by the bounds of TAG. | |
1041 | See `semantic-tag-bounds'." | |
1042 | (interactive) | |
1043 | (if (not tag) (setq tag (semantic-current-tag))) | |
1044 | (narrow-to-region (semantic-tag-start tag) | |
1045 | (semantic-tag-end tag))) | |
1046 | ||
1047 | (defmacro semantic-with-buffer-narrowed-to-current-tag (&rest body) | |
1048 | "Execute BODY with the buffer narrowed to the current tag." | |
1049 | `(save-restriction | |
1050 | (semantic-narrow-to-tag (semantic-current-tag)) | |
1051 | ,@body)) | |
1052 | (put 'semantic-with-buffer-narrowed-to-current-tag 'lisp-indent-function 0) | |
1053 | (add-hook 'edebug-setup-hook | |
1054 | (lambda () | |
1055 | (def-edebug-spec semantic-with-buffer-narrowed-to-current-tag | |
1056 | (def-body)))) | |
1057 | ||
1058 | (defmacro semantic-with-buffer-narrowed-to-tag (tag &rest body) | |
1059 | "Narrow to TAG, and execute BODY." | |
1060 | `(save-restriction | |
1061 | (semantic-narrow-to-tag ,tag) | |
1062 | ,@body)) | |
1063 | (put 'semantic-with-buffer-narrowed-to-tag 'lisp-indent-function 1) | |
1064 | (add-hook 'edebug-setup-hook | |
1065 | (lambda () | |
1066 | (def-edebug-spec semantic-with-buffer-narrowed-to-tag | |
1067 | (def-body)))) | |
1068 | \f | |
1069 | ;;; Tag Hooks | |
1070 | ;; | |
1071 | ;; Semantic may want to provide special hooks when specific operations | |
1072 | ;; are about to happen on a given tag. These routines allow for hook | |
1073 | ;; maintenance on a tag. | |
1074 | ||
1075 | ;; Internal global variable used to manage tag hooks. For example, | |
1076 | ;; some implementation of `remove-hook' checks that the hook variable | |
1077 | ;; is `default-boundp'. | |
1078 | (defvar semantic--tag-hook-value) | |
1079 | ||
1080 | (defun semantic-tag-add-hook (tag hook function &optional append) | |
1081 | "Onto TAG, add to the value of HOOK the function FUNCTION. | |
1082 | FUNCTION is added (if necessary) at the beginning of the hook list | |
1083 | unless the optional argument APPEND is non-nil, in which case | |
1084 | FUNCTION is added at the end. | |
1085 | HOOK should be a symbol, and FUNCTION may be any valid function. | |
1086 | See also the function `add-hook'." | |
1087 | (let ((semantic--tag-hook-value (semantic--tag-get-property tag hook))) | |
1088 | (add-hook 'semantic--tag-hook-value function append) | |
1089 | (semantic--tag-put-property tag hook semantic--tag-hook-value) | |
1090 | semantic--tag-hook-value)) | |
1091 | ||
1092 | (defun semantic-tag-remove-hook (tag hook function) | |
1093 | "Onto TAG, remove from the value of HOOK the function FUNCTION. | |
1094 | HOOK should be a symbol, and FUNCTION may be any valid function. If | |
1095 | FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in | |
1096 | the list of hooks to run in HOOK, then nothing is done. | |
1097 | See also the function `remove-hook'." | |
1098 | (let ((semantic--tag-hook-value (semantic--tag-get-property tag hook))) | |
1099 | (remove-hook 'semantic--tag-hook-value function) | |
1100 | (semantic--tag-put-property tag hook semantic--tag-hook-value) | |
1101 | semantic--tag-hook-value)) | |
1102 | ||
1103 | (defun semantic--tag-run-hooks (tag hook &rest args) | |
1104 | "Run for TAG all expressions saved on the property HOOK. | |
1105 | Each hook expression must take at least one argument, the TAG. | |
1106 | For any given situation, additional ARGS may be passed." | |
1107 | (let ((semantic--tag-hook-value (semantic--tag-get-property tag hook)) | |
1108 | (arglist (cons tag args))) | |
1109 | (condition-case err | |
1110 | ;; If a hook bombs, ignore it! Usually this is tied into | |
1111 | ;; some sort of critical system. | |
1112 | (apply 'run-hook-with-args 'semantic--tag-hook-value arglist) | |
1113 | (error (message "Error: %S" err))))) | |
1114 | \f | |
1115 | ;;; Tags and Overlays | |
1116 | ;; | |
1117 | ;; Overlays are used so that we can quickly identify tags from | |
1118 | ;; buffer positions and regions using built in Emacs commands. | |
1119 | ;; | |
9d389824 CY |
1120 | (defsubst semantic--tag-unlink-list-from-buffer (tags) |
1121 | "Convert TAGS from using an overlay to using an overlay proxy. | |
1122 | This function is for internal use only." | |
1123 | (mapcar 'semantic--tag-unlink-from-buffer tags)) | |
1124 | ||
1125 | (defun semantic--tag-unlink-from-buffer (tag) | |
1126 | "Convert TAG from using an overlay to using an overlay proxy. | |
1127 | This function is for internal use only." | |
1128 | (when (semantic-tag-p tag) | |
1129 | (let ((o (semantic-tag-overlay tag))) | |
1130 | (when (semantic-overlay-p o) | |
1131 | (semantic--tag-set-overlay | |
1132 | tag (vector (semantic-overlay-start o) | |
1133 | (semantic-overlay-end o))) | |
1134 | (semantic-overlay-delete o)) | |
1135 | ;; Look for a link hook on TAG. | |
1136 | (semantic--tag-run-hooks tag 'unlink-hook) | |
1137 | ;; Fix the sub-tags which contain overlays. | |
1138 | (semantic--tag-unlink-list-from-buffer | |
1139 | (semantic-tag-components-with-overlays tag))))) | |
1140 | ||
1141 | (defsubst semantic--tag-link-list-to-buffer (tags) | |
1142 | "Convert TAGS from using an overlay proxy to using an overlay. | |
1143 | This function is for internal use only." | |
8aedfd3b | 1144 | (mapc 'semantic--tag-link-to-buffer tags)) |
9d389824 CY |
1145 | |
1146 | (defun semantic--tag-link-to-buffer (tag) | |
1147 | "Convert TAG from using an overlay proxy to using an overlay. | |
1148 | This function is for internal use only." | |
1149 | (when (semantic-tag-p tag) | |
1150 | (let ((o (semantic-tag-overlay tag))) | |
1151 | (when (and (vectorp o) (= (length o) 2)) | |
1152 | (setq o (semantic-make-overlay (aref o 0) (aref o 1) | |
1153 | (current-buffer))) | |
1154 | (semantic--tag-set-overlay tag o) | |
1155 | (semantic-overlay-put o 'semantic tag) | |
1156 | ;; Clear the :filename property | |
1157 | (semantic--tag-put-property tag :filename nil)) | |
1158 | ;; Look for a link hook on TAG. | |
1159 | (semantic--tag-run-hooks tag 'link-hook) | |
1160 | ;; Fix the sub-tags which contain overlays. | |
1161 | (semantic--tag-link-list-to-buffer | |
1162 | (semantic-tag-components-with-overlays tag))))) | |
1163 | ||
1164 | (defun semantic--tag-unlink-cache-from-buffer () | |
e1dbe924 | 1165 | "Convert all tags in the current cache to use overlay proxies. |
9d389824 | 1166 | This function is for internal use only." |
a175a831 | 1167 | (require 'semantic) |
9d389824 CY |
1168 | (semantic--tag-unlink-list-from-buffer |
1169 | ;; @todo- use fetch-tags-fast? | |
1170 | (semantic-fetch-tags))) | |
1171 | ||
1172 | (defvar semantic--buffer-cache) | |
1173 | ||
1174 | (defun semantic--tag-link-cache-to-buffer () | |
1175 | "Convert all tags in the current cache to use overlays. | |
1176 | This function is for internal use only." | |
a175a831 | 1177 | (require 'semantic) |
9d389824 CY |
1178 | (condition-case nil |
1179 | ;; In this unique case, we cannot call the usual toplevel fn. | |
1180 | ;; because we don't want a reparse, we want the old overlays. | |
1181 | (semantic--tag-link-list-to-buffer | |
1182 | semantic--buffer-cache) | |
1183 | ;; Recover when there is an error restoring the cache. | |
1184 | (error (message "Error recovering tag list") | |
1185 | (semantic-clear-toplevel-cache) | |
1186 | nil))) | |
1187 | \f | |
1188 | ;;; Tag Cooking | |
1189 | ;; | |
1190 | ;; Raw tags from a parser follow a different positional format than | |
1191 | ;; those used in the buffer cache. Raw tags need to be cooked into | |
1192 | ;; semantic cache friendly tags for use by the masses. | |
1193 | ;; | |
1194 | (defsubst semantic--tag-expanded-p (tag) | |
1195 | "Return non-nil if TAG is expanded. | |
1196 | This function is for internal use only. | |
1197 | See also the function `semantic--expand-tag'." | |
1198 | ;; In fact a cooked tag is actually a list of cooked tags | |
1199 | ;; because a raw tag can be expanded in several cooked ones! | |
1200 | (when (consp tag) | |
1201 | (while (and (semantic-tag-p (car tag)) | |
1202 | (vectorp (semantic-tag-overlay (car tag)))) | |
1203 | (setq tag (cdr tag))) | |
1204 | (null tag))) | |
1205 | ||
1206 | (defvar semantic-tag-expand-function nil | |
1207 | "Function used to expand a tag. | |
1208 | It is passed each tag production, and must return a list of tags | |
1209 | derived from it, or nil if it does not need to be expanded. | |
1210 | ||
1211 | Languages with compound definitions should use this function to expand | |
1212 | from one compound symbol into several. For example, in C or Java the | |
1213 | following definition is easily parsed into one tag: | |
1214 | ||
1215 | int a, b; | |
1216 | ||
1217 | This function should take this compound tag and turn it into two tags, | |
1218 | one for A, and the other for B.") | |
1219 | (make-variable-buffer-local 'semantic-tag-expand-function) | |
1220 | ||
1221 | (defun semantic--tag-expand (tag) | |
1222 | "Convert TAG from a raw state to a cooked state, and expand it. | |
1223 | Returns a list of cooked tags. | |
1224 | ||
1225 | The parser returns raw tags with positional data START END at the | |
1226 | end of the tag data structure (a list for now). We convert it from | |
1227 | that to a cooked state that uses an overlay proxy, that is, a vector | |
1228 | \[START END]. | |
1229 | ||
1230 | The raw tag is changed with side effects and maybe expanded in | |
1231 | several derived tags when the variable `semantic-tag-expand-function' | |
1232 | is set. | |
1233 | ||
1234 | This function is for internal use only." | |
1235 | (if (semantic--tag-expanded-p tag) | |
1236 | ;; Just return TAG if it is already expanded (by a grammar | |
1237 | ;; semantic action), or if it isn't recognized as a valid | |
1238 | ;; semantic tag. | |
1239 | tag | |
1240 | ||
1241 | ;; Try to cook the tag. This code will be removed when tag will | |
1242 | ;; be directly created with the right format. | |
1243 | (condition-case nil | |
1244 | (let ((ocdr (semantic--tag-overlay-cdr tag))) | |
1245 | ;; OCDR contains the sub-list of TAG whose car is the | |
1246 | ;; OVERLAY part of TAG. That is, a list (OVERLAY START END). | |
1247 | ;; Convert it into an overlay proxy ([START END]). | |
1248 | (semantic--tag-set-overlay | |
1249 | tag (vector (nth 1 ocdr) (nth 2 ocdr))) | |
1250 | ;; Remove START END positions at end of tag. | |
1251 | (setcdr ocdr nil) | |
1252 | ;; At this point (length TAG) must be 5! | |
1253 | ;;(unless (= (length tag) 5) | |
1254 | ;; (error "Tag expansion failed")) | |
1255 | ) | |
1256 | (error | |
1257 | (message "A Rule must return a single tag-line list!") | |
1258 | (debug tag) | |
1259 | nil)) | |
9d389824 CY |
1260 | ;; Expand based on local configuration |
1261 | (if semantic-tag-expand-function | |
1262 | (or (funcall semantic-tag-expand-function tag) | |
1263 | (list tag)) | |
1264 | (list tag)))) | |
1265 | \f | |
1266 | ;; Foreign tags | |
1267 | ;; | |
1268 | (defmacro semantic-foreign-tag-invalid (tag) | |
1269 | "Signal that TAG is an invalid foreign tag." | |
1270 | `(signal 'wrong-type-argument '(semantic-foreign-tag-p ,tag))) | |
1271 | ||
1272 | (defsubst semantic-foreign-tag-p (tag) | |
1273 | "Return non-nil if TAG is a foreign tag. | |
1274 | That is, a tag unlinked from the originating buffer, which carries the | |
1275 | originating buffer file name, and major mode." | |
1276 | (and (semantic-tag-p tag) | |
1277 | (semantic--tag-get-property tag :foreign-flag))) | |
1278 | ||
1279 | (defsubst semantic-foreign-tag-check (tag) | |
1280 | "Check that TAG is a valid foreign tag. | |
1281 | Signal an error if not." | |
1282 | (or (semantic-foreign-tag-p tag) | |
1283 | (semantic-foreign-tag-invalid tag))) | |
1284 | ||
1285 | (defun semantic-foreign-tag (&optional tag) | |
1286 | "Return a copy of TAG as a foreign tag, or nil if it can't be done. | |
1287 | TAG defaults to the tag at point in current buffer. | |
1288 | See also `semantic-foreign-tag-p'." | |
1289 | (or tag (setq tag (semantic-current-tag))) | |
1290 | (when (semantic-tag-p tag) | |
1291 | (let ((ftag (semantic-tag-copy tag nil t)) | |
1292 | ;; Do extra work for the doc strings, since this is a | |
1293 | ;; common use case. | |
1294 | (doc (condition-case nil | |
1295 | (semantic-documentation-for-tag tag) | |
1296 | (error nil)))) | |
1297 | ;; A foreign tag must carry its originating buffer file name! | |
1298 | (when (semantic--tag-get-property ftag :filename) | |
1299 | (semantic--tag-put-property ftag :mode (semantic-tag-mode tag)) | |
1300 | (semantic--tag-put-property ftag :documentation doc) | |
1301 | (semantic--tag-put-property ftag :foreign-flag t) | |
1302 | ftag)))) | |
1303 | ||
1304 | ;; High level obtain/insert foreign tag overloads | |
9d389824 CY |
1305 | (define-overloadable-function semantic-obtain-foreign-tag (&optional tag) |
1306 | "Obtain a foreign tag from TAG. | |
1307 | TAG defaults to the tag at point in current buffer. | |
1308 | Return the obtained foreign tag or nil if failed." | |
1309 | (semantic-foreign-tag tag)) | |
1310 | ||
1311 | (defun semantic-insert-foreign-tag-default (foreign-tag) | |
1312 | "Insert FOREIGN-TAG into the current buffer. | |
1313 | The default behavior assumes the current buffer is a language file, | |
1314 | and attempts to insert a prototype/function call." | |
1315 | ;; Long term goal: Have a mechanism for a tempo-like template insert | |
1316 | ;; for the given tag. | |
1317 | (insert (semantic-format-tag-prototype foreign-tag))) | |
1318 | ||
9d389824 CY |
1319 | (define-overloadable-function semantic-insert-foreign-tag (foreign-tag) |
1320 | "Insert FOREIGN-TAG into the current buffer. | |
1321 | Signal an error if FOREIGN-TAG is not a valid foreign tag. | |
1322 | This function is overridable with the symbol `insert-foreign-tag'." | |
1323 | (semantic-foreign-tag-check foreign-tag) | |
1324 | (:override) | |
1325 | (message (semantic-format-tag-summarize foreign-tag))) | |
1326 | ||
1327 | ;;; Support log modes here | |
1328 | (define-mode-local-override semantic-insert-foreign-tag | |
1329 | log-edit-mode (foreign-tag) | |
1330 | "Insert foreign tags into log-edit mode." | |
1331 | (insert (concat "(" (semantic-format-tag-name foreign-tag) "): "))) | |
1332 | ||
1333 | (define-mode-local-override semantic-insert-foreign-tag | |
1334 | change-log-mode (foreign-tag) | |
1335 | "Insert foreign tags into log-edit mode." | |
1336 | (insert (concat "(" (semantic-format-tag-name foreign-tag) "): "))) | |
9d389824 CY |
1337 | \f |
1338 | ;;; Compatibility | |
1339 | ;; | |
1340 | (defconst semantic-token-version | |
1341 | semantic-tag-version) | |
1342 | (defconst semantic-token-incompatible-version | |
1343 | semantic-tag-incompatible-version) | |
1344 | ||
9d389824 CY |
1345 | (defsubst semantic-token-type-parent (tag) |
1346 | "Return the parent of the type that TAG describes. | |
1347 | The return value is a list. A value of nil means no parents. | |
1348 | The `car' of the list is either the parent class, or a list | |
1349 | of parent classes. The `cdr' of the list is the list of | |
1350 | interfaces, or abstract classes which are parents of TAG." | |
1351 | (cons (semantic-tag-get-attribute tag :superclasses) | |
1352 | (semantic-tag-type-interfaces tag))) | |
1353 | (make-obsolete 'semantic-token-type-parent | |
1354 | "\ | |
1355 | use `semantic-tag-type-superclass' \ | |
86f1602f | 1356 | and `semantic-tag-type-interfaces' instead" "23.2") |
9d389824 | 1357 | |
9d389824 | 1358 | (semantic-alias-obsolete 'semantic-tag-make-assoc-list |
eefa91db | 1359 | 'semantic-tag-make-plist "23.2") |
9d389824 | 1360 | |
9d389824 | 1361 | (semantic-varalias-obsolete 'semantic-expand-nonterminal |
eefa91db | 1362 | 'semantic-tag-expand-function "23.2") |
9d389824 | 1363 | |
9d389824 CY |
1364 | (provide 'semantic/tag) |
1365 | ||
55b522b2 CY |
1366 | ;; Local variables: |
1367 | ;; generated-autoload-file: "loaddefs.el" | |
996bc9bf | 1368 | ;; generated-autoload-load-name: "semantic/tag" |
55b522b2 CY |
1369 | ;; End: |
1370 | ||
996bc9bf | 1371 | ;;; semantic/tag.el ends here |