summaryrefslogtreecommitdiff
path: root/lisp/cedet/semantic/analyze/fcn.el
blob: 10d11c33ebb2c064f83187971c743e74a6761015 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
;;; semantic/analyze/fcn.el --- Analyzer support functions.

;; Copyright (C) 2007-2021 Free Software Foundation, Inc.

;; Author: Eric M. Ludlam <zappo@gnu.org>

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; Analyzer support functions.

;;; Code:

(require 'semantic)
(eval-when-compile (require 'semantic/find))

(declare-function semanticdb-typecache-merge-streams "semantic/db-typecache")
(declare-function semantic-scope-find "semantic/scope")
(declare-function semantic-scope-set-typecache "semantic/scope")
(declare-function semantic-scope-tag-get-scope "semantic/scope")

;;; Small Mode Specific Options
;;
;; These queries allow a major mode to help the analyzer make decisions.
;;

(define-overloadable-function semantic-analyze-split-name (name)
  "Split a tag NAME into a sequence.
Sometimes NAMES are gathered from the parser that are compounded,
such as in C++ where foo::bar means:
  \"The class BAR in the namespace FOO.\"
Return the string NAME for no change, or a list if it needs to be split.")

(defun semantic-analyze-split-name-default (name)
  "Don't split up NAME by default."
  name)

(define-overloadable-function semantic-analyze-unsplit-name (namelist)
  "Assemble a NAMELIST into a string representing a compound name.
Return the string representing the compound name.")

(defun semantic-analyze-unsplit-name-default (namelist)
  "Concatenate the names in NAMELIST with a . between."
  (mapconcat 'identity namelist "."))

;;; SELECTING
;;
;; If you narrow things down to a list of tags that all mean
;; the same thing, how to you pick one?  Select or merge.
;;

(defun semantic-analyze-select-best-tag (sequence &optional tagclass)
  "For a SEQUENCE of tags, all with good names, pick the best one.
If SEQUENCE is made up of namespaces, merge the namespaces together.
If SEQUENCE has several prototypes, find the non-prototype.
If SEQUENCE has some items w/ no type information, find the one with a type.
If SEQUENCE is all prototypes, or has no prototypes, get the first one.
Optional TAGCLASS indicates to restrict the return to only
tags of TAGCLASS."

  ;; If there is a srew up and we get just one tag.. massage over it.
  (when (semantic-tag-p sequence)
    (setq sequence (list sequence)))

  ;; Filter out anything not of TAGCLASS
  (when tagclass
    (setq sequence (semantic-find-tags-by-class tagclass sequence)))

  (if (< (length sequence) 2)
      ;; If the remaining sequence is 1 tag or less, just return it
      ;; and skip the rest of this mumbo-jumbo.
      (car sequence)

    ;; 1)
    ;; This step will eliminate a vast majority of the types,
    ;; in addition to merging namespaces together.
    ;;
    ;; 2)
    ;; It will also remove prototypes.
    (require 'semantic/db-typecache)
    (setq sequence (semanticdb-typecache-merge-streams sequence nil))

    (if (< (length sequence) 2)
	;; If the remaining sequence after the merge is 1 tag or less,
	;; just return it and skip the rest of this mumbo-jumbo.
	(car sequence)

      (let ((best nil)
	    (notypeinfo nil)
	    )
	(while (and (not best) sequence)

	  ;; 3) select a non-prototype.
	  (if (not (semantic-tag-type (car sequence)))
	      (setq notypeinfo (car sequence))

	    (setq best (car sequence))
	    )

	  (setq sequence (cdr sequence)))

	;; Select the best, or at least the prototype.
	(or best notypeinfo)))))

;;; Tag Finding
;;
;; Mechanism for lookup up tags by name.
;;
(defun semantic-analyze-find-tags-by-prefix (prefix)
  ;; @todo - only used in semantic-complete.  Find something better?
  "Attempt to find a tag with PREFIX.
This is a wrapper on top of semanticdb, and semantic search functions.
Almost all searches use the same arguments."
  (if (and (fboundp 'semanticdb-minor-mode-p)
           (semanticdb-minor-mode-p))
      ;; Search the database & concatenate all matches together.
      (semanticdb-strip-find-results
       (semanticdb-find-tags-for-completion prefix)
       'name)
    ;; Search just this file because there is no DB available.
    (semantic-find-tags-for-completion
     prefix (current-buffer))))

;;; Finding Datatypes
;;

(define-overloadable-function semantic-analyze-dereference-metatype (type scope &optional type-declaration)
  ;; todo - move into typecache!!
  "Return a concrete type tag based on input TYPE tag.
A concrete type is an actual declaration of a memory description,
such as a structure, or class.  A meta type is an alias,
or a typedef in C or C++.  If TYPE is concrete, it
is returned.  If it is a meta type, it will return the concrete
type defined by TYPE.
The default behavior always returns TYPE.
Override functions need not return a real semantic tag.
Just a name, or short tag will be ok.  It will be expanded here.
SCOPE is the scope object with additional items in which to search for names."
  (catch 'default-behavior
    (let* ((ans-tuple (:override
                       ;; Nothing fancy, just return type by default.
                       (throw 'default-behavior (list type type-declaration))))
           (ans-type (car ans-tuple))
           (ans-type-declaration (cadr ans-tuple)))
       (list (semantic-analyze-dereference-metatype-1 ans-type scope) ans-type-declaration))))

;; Finding a data type by name within a project.
;;
(defun semantic-analyze-type-to-name (type)
  "Get the name of TAG's type.
The TYPE field in a tag can be nil (return nil)
or a string, or a non-positional tag."
  (cond ((semantic-tag-p type)
	 (if (semantic-tag-named-parent type)
	     (semantic-analyze-unsplit-name `(,(semantic-tag-named-parent type)
					      ,(semantic-tag-name type)))
	   (semantic-tag-name type)))
	((stringp type)
	 type)
	((listp type)
	 (car type))
	(t nil)))

(defun semantic-analyze-tag-type (tag &optional scope nometaderef)
  "Return the semantic tag for a type within the type of TAG.
TAG can be a variable, function or other type of tag.
The behavior of TAG's type is defined by `semantic-analyze-type'.
Optional SCOPE represents a calculated scope in which the
types might be found.  This can be nil.
If NOMETADEREF, then do not dereference metatypes.  This is
used by the analyzer debugger."
  (semantic-analyze-type (semantic-tag-type tag) scope nometaderef))

(defun semantic-analyze-type (type-declaration &optional scope nometaderef)
  "Return the semantic tag for TYPE-DECLARATION.
TAG can be a variable, function or other type of tag.
The type of tag (such as a class or struct) is a name.
Lookup this name in database, and return all slots/fields
within that types field.  Also handles anonymous types.
Optional SCOPE represents a calculated scope in which the
types might be found.  This can be nil.
If NOMETADEREF, then do not dereference metatypes.  This is
used by the analyzer debugger."
  (require 'semantic/scope)
  (let ((name nil)
	(typetag nil)
	)

    ;; Is it an anonymous type?
    (if (and type-declaration
	     (semantic-tag-p type-declaration)
	     (semantic-tag-of-class-p type-declaration 'type)
	     (not (semantic-tag-prototype-p type-declaration))
	     )
	;; We have an anonymous type for TAG with children.
	;; Use this type directly.
	(if nometaderef
	    type-declaration
	  (semantic-analyze-dereference-metatype-stack
	   type-declaration scope type-declaration))

      ;; Not an anonymous type.  Look up the name of this type
      ;; elsewhere, and report back.
      (setq name (semantic-analyze-type-to-name type-declaration))

      (if (and name (not (string= name "")))
	  (progn
	    ;; Find a type of that name in scope.
	    (setq typetag (and scope (semantic-scope-find name 'type scope)))
	    ;; If no typetag, try the typecache
	    (when (not typetag)
	      (setq typetag (semanticdb-typecache-find name))))

	;; No name to look stuff up with.
	(error "Semantic tag %S has no type information"
	       (semantic-tag-name type-declaration)))

      ;; Handle lists of tags.
      (when (and (consp typetag) (semantic-tag-p (car typetag)))
	(setq typetag (semantic-analyze-select-best-tag typetag 'type))
	)

      ;; We now have a tag associated with the type.  We need to deref it.
      ;;
      ;; If we were asked not to (ie - debugger) push the typecache anyway.
      (if nometaderef
	  typetag
	(unwind-protect
	    (progn
	      (semantic-scope-set-typecache
	       scope (semantic-scope-tag-get-scope typetag))
	      (semantic-analyze-dereference-metatype-stack typetag scope type-declaration)
	      )
	  (semantic-scope-set-typecache scope nil)
	  )))))

(autoload 'semantic-tag-similar-p "semantic/tag-ls")

(defun semantic-analyze-dereference-metatype-stack (type scope &optional type-declaration)
  "Dereference metatypes repeatedly until we hit a real TYPE.
Uses `semantic-analyze-dereference-metatype'.
Argument SCOPE is the scope object with additional items in which to search.
Optional argument TYPE-DECLARATION is how TYPE was found referenced."
  (let ((lasttype type)
        (lasttypedeclaration type-declaration)
	(nexttype (semantic-analyze-dereference-metatype type scope type-declaration))
	(idx 0))
    (catch 'metatype-recursion
      (while (and nexttype (not (semantic-tag-similar-p (car nexttype) lasttype)))
	(setq lasttype (car nexttype)
	      lasttypedeclaration (cadr nexttype))
	(setq nexttype (semantic-analyze-dereference-metatype lasttype scope lasttypedeclaration))
	(setq idx (1+ idx))
	(when (> idx 20) (message "Possible metatype recursion for %S"
				  (semantic-tag-name lasttype))
	      (throw 'metatype-recursion nil))
	))
    lasttype))

;; @ TODO - the typecache can also return a stack of scope names.

(defun semantic-analyze-dereference-metatype-1 (ans scope)
  "Do extra work after dereferencing a metatype.
ANS is the answer from the language specific query.
SCOPE is the current scope."
  (require 'semantic/scope)
  ;; If ANS is a string, or if ANS is a short tag, we
  ;; need to do some more work to look it up.
  (if (stringp ans)
      ;; The metatype is just a string... look it up.
      (or (and scope (car-safe
		      ;; @todo - should this be `find the best one'?
		      (semantic-scope-find ans 'type scope)))
	  (let ((tcsans nil))
	    (prog1
		(setq tcsans
		      (semanticdb-typecache-find ans))
	      ;; While going through the metatype, if we have
	      ;; a scope, push our new cache in.
	      (when scope
		(semantic-scope-set-typecache
		 scope (semantic-scope-tag-get-scope tcsans))
		))
	    ))
    (when (and (semantic-tag-p ans)
	       (eq (semantic-tag-class ans) 'type))
      ;; We have a tag.
      (if (semantic-tag-prototype-p ans)
	  ;; It is a prototype.. find the real one.
	  (or (and scope
		   (car-safe
		    (semantic-scope-find (semantic-tag-name ans)
					 'type scope)))
	      (let ((tcsans nil))
		(prog1
		    (setq tcsans
			  (semanticdb-typecache-find (semantic-tag-name ans)))
		  ;; While going through the metatype, if we have
		  ;; a scope, push our new cache in.
		  (when scope
		    (semantic-scope-set-typecache
		     scope (semantic-scope-tag-get-scope tcsans))
		    ))))
	;; We have a tag, and it is not a prototype.
	ans))
    ))

(provide 'semantic/analyze/fcn)

;;; semantic/analyze/fcn.el ends here