summaryrefslogtreecommitdiff
path: root/lisp/cedet/srecode/semantic.el
blob: 5b2dd0347439500dd98379b30ca31466b2099e4d (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
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
;;; srecode/semantic.el --- Semantic specific extensions to SRecode.

;; Copyright (C) 2007-2020 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:
;;
;; Semantic specific extensions to the Semantic Recoder.
;;
;; I realize it is the "Semantic Recoder", but most of srecode
;; is a template library and set of user interfaces unrelated to
;; semantic in the specific.
;;
;; This file defines the following:
;;   - :tag argument handling.
;;   - <more goes here>

;;; Code:

(require 'srecode/insert)
(require 'srecode/dictionary)
(require 'semantic/find)
(require 'semantic/format)
(require 'semantic/senator)
(require 'ring)


;;; The SEMANTIC TAG inserter
;;
;; Put a tag into the dictionary that can be used w/ arbitrary
;; lisp expressions.

(defclass srecode-semantic-tag (srecode-dictionary-compound-value)
  ((prime :initarg :prime
	  :type semantic-tag
	  :documentation
	  "This is the primary insertion tag.")
   )
  "Wrap up a collection of semantic tag information.
This class will be used to derive dictionary values.")

(cl-defmethod srecode-compound-toString((cp srecode-semantic-tag)
				     function
				     dictionary)
  "Convert the compound dictionary value CP to a string.
If FUNCTION is non-nil, then FUNCTION is somehow applied to an
aspect of the compound value."
  (if (not function)
      ;; Just format it in some handy dandy way.
      (semantic-format-tag-prototype (oref cp prime))
    ;; Otherwise, apply the function to the tag itself.
    (funcall function (oref cp prime))))


;;; Managing the `current' tag
;;

(defvar srecode-semantic-selected-tag nil
  "The tag selected by a :tag template argument.
If this is nil, then `senator-tag-ring' is used.")

(defun srecode-semantic-tag-from-kill-ring ()
  "Create an `srecode-semantic-tag' from the senator kill ring."
  (if (ring-empty-p senator-tag-ring)
      (error "You must use `senator-copy-tag' to provide a tag to this template"))
  (ring-ref senator-tag-ring 0))


;;; TAG in a DICTIONARY
;;
(defvar srecode-semantic-apply-tag-augment-hook nil
  "A function called for each tag added to a dictionary.
The hook is called with two arguments, the TAG and DICT
to be augmented.")

(define-overloadable-function srecode-semantic-apply-tag-to-dict (tagobj dict)
  "Insert features of TAGOBJ into the dictionary DICT.
TAGOBJ is an object of class `srecode-semantic-tag'.  This class
is a compound inserter value.
DICT is a dictionary object.
At a minimum, this function will create dictionary macro for NAME.
It is also likely to create macros for TYPE (data type), function arguments,
variable default values, and other things."
  )

(defun srecode-semantic-apply-tag-to-dict-default (tagobj dict)
  "Insert features of TAGOBJ into dictionary DICT."
  ;; Store the sst into the dictionary.
  (srecode-dictionary-set-value dict "TAG" tagobj)

  ;; Pull out the tag for the individual pieces.
  (let ((tag (oref tagobj prime)))

    (srecode-dictionary-set-value dict "NAME" (semantic-tag-name tag))
    (srecode-dictionary-set-value dict "TYPE" (semantic-format-tag-type tag nil))

    (run-hook-with-args 'srecode-semantic-apply-tag-augment-hook tag dict)

    (cond
     ;;
     ;; FUNCTION
     ;;
     ((eq (semantic-tag-class tag) 'function)
      ;; FCN ARGS
      (let ((args (semantic-tag-function-arguments tag)))
	(while args
	  (let ((larg (car args))
		(subdict (srecode-dictionary-add-section-dictionary
			  dict "ARGS")))
	    ;; Clean up elements in the arg list.
	    (if (stringp larg)
		(setq larg (semantic-tag-new-variable
			    larg nil nil)))
	    ;; Apply the sub-argument to the subdictionary.
	    (srecode-semantic-apply-tag-to-dict
	     (srecode-semantic-tag (semantic-tag-name larg)
				   :prime larg)
	     subdict)
	    )
	  ;; Next!
	  (setq args (cdr args))))
      ;; PARENTS
      (let ((p (semantic-tag-function-parent tag)))
	(when p
	  (srecode-dictionary-set-value dict "PARENT" p)
	  ))
      ;; EXCEPTIONS (java/c++)
      (let ((exceptions (semantic-tag-get-attribute tag :throws)))
	(while exceptions
	  (let ((subdict (srecode-dictionary-add-section-dictionary
			  dict "THROWS")))
	    (srecode-dictionary-set-value subdict "NAME" (car exceptions))
	    )
	  (setq exceptions (cdr exceptions)))
	)
      )
     ;;
     ;; VARIABLE
     ;;
     ((eq (semantic-tag-class tag) 'variable)
      (when (semantic-tag-variable-default tag)
	(let ((subdict (srecode-dictionary-add-section-dictionary
			dict "HAVEDEFAULT")))
	  (srecode-dictionary-set-value
	   subdict "VALUE" (semantic-tag-variable-default tag))))
      )
     ;;
     ;; TYPE
     ;;
     ((eq (semantic-tag-class tag) 'type)
      (dolist (p (semantic-tag-type-superclasses tag))
	(let ((sd (srecode-dictionary-add-section-dictionary
		   dict "PARENTS")))
	  (srecode-dictionary-set-value sd "NAME" p)
	  ))
      (dolist (i (semantic-tag-type-interfaces tag))
	(let ((sd (srecode-dictionary-add-section-dictionary
		   dict "INTERFACES")))
	  (srecode-dictionary-set-value sd "NAME" i)
	  ))
; NOTE : The members are too complicated to do via a template.
;        do it via the insert-tag solution instead.
;
;      (dolist (mem (semantic-tag-type-members tag))
;	(let ((subdict (srecode-dictionary-add-section-dictionary
;			dict "MEMBERS")))
;	  (when (stringp mem)
;	    (setq mem (semantic-tag-new-variable mem nil nil)))
;	  (srecode-semantic-apply-tag-to-dict
;	   (srecode-semantic-tag (semantic-tag-name mem)
;				 :prime mem)
;	   subdict)))
      ))))


;;; ARGUMENT HANDLERS

;;; :tag ARGUMENT HANDLING
;;
;; When a :tag argument is required, identify the current :tag,
;; and apply its parts into the dictionary.
(defun srecode-semantic-handle-:tag (dict)
  "Add macros into the dictionary DICT based on the current :tag."
  ;; We have a tag, start adding "stuff" into the dictionary.
  (let ((tag (or srecode-semantic-selected-tag
		 (srecode-semantic-tag-from-kill-ring))))
    (when (not tag)
      (error "No tag for current template.  Use the semantic kill-ring."))
    (srecode-semantic-apply-tag-to-dict
     (srecode-semantic-tag (semantic-tag-name tag)
			   :prime tag)
     dict)))

;;; :tagtype ARGUMENT HANDLING
;;
;; When a :tagtype argument is required, identify the current tag, of
;; class 'type'.  Apply those parameters to the dictionary.

(defun srecode-semantic-handle-:tagtype (dict)
  "Add macros into the dictionary DICT based on a tag of class type at point.
Assumes the cursor is in a tag of class type.  If not, throw an error."
  (let ((typetag (or srecode-semantic-selected-tag
		     (semantic-current-tag-of-class 'type))))
    (when (not typetag)
      (error "Cursor is not in a TAG of class `type'"))
    (srecode-semantic-apply-tag-to-dict
     typetag
     dict)))


;;; INSERT A TAG API
;;
;; Routines that take a tag, and insert into a buffer.
(define-overloadable-function srecode-semantic-find-template (class prototype ctxt)
  "Find a template for a tag of class CLASS based on context.
PROTOTYPE is non-nil if we want a prototype template instead."
  )

(defun srecode-semantic-find-template-default (class prototype ctxt)
  "Find a template for tag CLASS based on context.
PROTOTYPE is non-nil if we need a prototype.
CTXT is the pre-calculated context."
  (let* ((top (car ctxt))
	 (tname (if (stringp class)
		    class
		  (symbol-name class)))
	 (temp nil)
	 )
    ;; Try to find a template.
    (setq temp (or
		(when prototype
		  (srecode-template-get-table (srecode-table)
					      (concat tname "-tag-prototype")
					      top))
		(when prototype
		  (srecode-template-get-table (srecode-table)
					      (concat tname "-prototype")
					      top))
		(srecode-template-get-table (srecode-table)
					    (concat tname "-tag")
					    top)
		(srecode-template-get-table (srecode-table)
					    tname
					    top)
		(when (and (not (string= top "declaration"))
			   prototype)
		  (srecode-template-get-table (srecode-table)
					      (concat tname "-prototype")
					      "declaration"))
		(when (and (not (string= top "declaration"))
			   prototype)
		  (srecode-template-get-table (srecode-table)
					      (concat tname "-tag-prototype")
					      "declaration"))
		(when (not (string= top "declaration"))
		  (srecode-template-get-table (srecode-table)
					      (concat tname "-tag")
					      "declaration"))
		(when (not (string= top "declaration"))
		  (srecode-template-get-table (srecode-table)
					      tname
					      "declaration"))
		))
    temp))

(defun srecode-semantic-insert-tag (tag &optional style-option
					point-insert-fcn
					&rest dict-entries)
  "Insert TAG into a buffer using srecode templates at point.

Optional STYLE-OPTION is a list of minor configuration of styles,
such as the symbol `prototype' for prototype functions, or
`system' for system includes, and `doxygen', for a doxygen style
comment.

Optional third argument POINT-INSERT-FCN is a hook that is run after
TAG is inserted that allows an opportunity to fill in the body of
some thing.  This hook function is called with one argument, the TAG
being inserted.

The rest of the arguments are DICT-ENTRIES.  DICT-ENTRIES
is of the form ( NAME1 VALUE1 NAME2 VALUE2 ... NAMEn VALUEn).

The exact template used is based on the current context.
The template used is found within the toplevel context as calculated
by `srecode-calculate-context', such as `declaration', `classdecl',
or `code'.

For various conditions, this function looks for a template with
the name CLASS-tag, where CLASS is the tag class.  If it cannot
find that, it will look for that template in the `declaration'
context (if the current context was not `declaration').

If PROTOTYPE is specified, it will first look for templates with
the name CLASS-tag-prototype, or CLASS-prototype as above.

See `srecode-semantic-apply-tag-to-dict' for details on what is in
the dictionary when the templates are called.

This function returns to location in the buffer where the
inserted tag ENDS, and will leave point inside the inserted
text based on any occurrence of a point-inserter.  Templates such
as `function' will leave point where code might be inserted."
  (srecode-load-tables-for-mode major-mode)
  (let* ((ctxt (srecode-calculate-context))
	 (top (car ctxt))
	 (tname (symbol-name (semantic-tag-class tag)))
	 (dict (srecode-create-dictionary))
	 (temp nil)
	 (errtype tname)
	 (prototype (memq 'prototype style-option))
	 )
    ;; Try some special cases.
    (cond ((and (semantic-tag-of-class-p tag 'function)
		(semantic-tag-get-attribute tag :constructor-flag))
	   (setq temp (srecode-semantic-find-template
		       "constructor" prototype ctxt))
	   )

	  ((and (semantic-tag-of-class-p tag 'function)
		(semantic-tag-get-attribute tag :destructor-flag))
	   (setq temp (srecode-semantic-find-template
		       "destructor" prototype ctxt))
	   )

	  ((and (semantic-tag-of-class-p tag 'function)
		(semantic-tag-function-parent tag))
	   (setq temp (srecode-semantic-find-template
		       "method" prototype ctxt))
	   )

	  ((and (semantic-tag-of-class-p tag 'variable)
		(semantic-tag-get-attribute tag :constant-flag))
	   (setq temp (srecode-semantic-find-template
		       "variable-const" prototype ctxt))
	   )

	  ((and (semantic-tag-of-class-p tag 'include)
		(semantic-tag-get-attribute tag :system-flag))
	   (setq temp (srecode-semantic-find-template
		       "system-include" prototype ctxt))
	   )
	  )

    (when (not temp)
      ;; Try the basics
      (setq temp (srecode-semantic-find-template
		  tname prototype ctxt)))

    ;; Try some backup template names.
    (when (not temp)
      (cond
       ;; Types might split things up based on the type's type.
       ((and (eq (semantic-tag-class tag) 'type)
	     (semantic-tag-type tag))
	(setq temp (srecode-semantic-find-template
		    (semantic-tag-type tag) prototype ctxt))
	(setq errtype (concat errtype " or " (semantic-tag-type tag)))
	)
       ;; A function might be an externally declared method.
       ((and (eq (semantic-tag-class tag) 'function)
	     (semantic-tag-function-parent tag))
	(setq temp (srecode-semantic-find-template
		    "method" prototype ctxt)))
       (t
	nil)
       ))

    ;; Can't find one?  Drat!
    (when (not temp)
      (error "Cannot find template %s in %s for inserting tag %S"
	     errtype top (semantic-format-tag-summarize tag)))

    ;; Resolve arguments
    (let ((srecode-semantic-selected-tag tag))
      (srecode-resolve-arguments temp dict))

    ;; Resolve TAG into the dictionary.  We may have a :tag arg
    ;; from the macro such that we don't need to do this.
    (when (not (srecode-dictionary-lookup-name dict "TAG"))
      (let ((tagobj (srecode-semantic-tag (semantic-tag-name tag) :prime tag))
	    )
	(srecode-semantic-apply-tag-to-dict tagobj dict)))

    ;; Insert dict-entries into the dictionary LAST so that previous
    ;; items can be overridden.
    (let ((entries dict-entries))
      (while entries
	(srecode-dictionary-set-value dict
				      (car entries)
				      (car (cdr entries)))
	(setq entries (cdr (cdr entries)))))

    ;; Insert the template.
    (let ((endpt (srecode-insert-fcn temp dict nil t)))

      (run-hook-with-args 'point-insert-fcn tag)
      ;;(sit-for 1)

      (cond
       ((semantic-tag-of-class-p tag 'type)
	;; Insert all the members at the current insertion point.
	(dolist (m (semantic-tag-type-members tag))

	  (when (stringp m)
	    (setq m (semantic-tag-new-variable m nil nil)))

	  ;; We do prototypes w/in the class decl?
	  (let ((me (srecode-semantic-insert-tag m '(prototype))))
	    (goto-char me))

	  ))
       )

      endpt)
    ))

(provide 'srecode/semantic)

;;; srecode/semantic.el ends here