lisp/cedet/srecode.el:

lisp/cedet/srecode/*.el:
test/cedet/srecode-tests.el: New files

lisp/files.el (auto-mode-alist): Use srecode-template-mode for .srt files.
lisp/cedet/semantic/bovine/scm.el: Add local vars section for autoloading.

1 files changed, 366 insertions, 0 deletions

diff --git a/lisp/cedet/srecode/getset.el b/lisp/cedet/srecode/getset.el
new file mode 100644
index 00000000000..b9ff6af2003
--- /dev/null
+++ b/lisp/cedet/srecode/getset.el
@@ -0,0 +1,366 @@
+;;; srecode/getset.el --- Package for inserting new get/set methods.
+
+;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <eric@siege-engine.com>
+
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; SRecoder application for inserting new get/set methods into a class.
+
+(require 'semantic)
+(require 'semantic/analyze)
+(require 'semantic/find)
+(require 'srecode/insert)
+(require 'srecode/dictionary)
+
+;;; Code:
+(defvar srecode-insert-getset-fully-automatic-flag nil
+  "Non-nil means accept choices srecode comes up with without asking.")
+
+;;;###autoload
+(defun srecode-insert-getset (&optional class-in field-in)
+  "Insert get/set methods for the current class.
+CLASS-IN is the semantic tag of the class to update.
+FIELD-IN is the semantic tag, or string name, of the field to add.
+If you do not specify CLASS-IN or FIELD-IN then a class and field
+will be derived."
+  (interactive)
+
+  (srecode-load-tables-for-mode major-mode)
+  (srecode-load-tables-for-mode major-mode 'getset)
+
+  (if (not (srecode-table))
+      (error "No template table found for mode %s" major-mode))
+
+  (if (not (srecode-template-get-table (srecode-table)
+				       "getset-in-class"
+				       "declaration"
+				       'getset))
+      (error "No templates for inserting get/set"))
+
+  ;; Step 1: Try to derive the tag for the class we will use
+  (let* ((class (or class-in (srecode-auto-choose-class (point))))
+	 (tagstart (semantic-tag-start class))
+	 (inclass (eq (semantic-current-tag-of-class 'type) class))
+	 (field nil)
+	 )
+
+    (when (not class)
+      (error "Move point to a class and try again"))
+
+    ;; Step 2: Select a name for the field we will use.
+    (when field-in
+      (setq field field-in))
+
+    (when (and inclass (not field))
+      (setq field (srecode-auto-choose-field (point))))
+
+    (when (not field)
+      (setq field (srecode-query-for-field class)))
+
+    ;; Step 3: Insert a new field if needed
+    (when (stringp field)
+
+      (goto-char (point))
+      (srecode-position-new-field class inclass)
+
+      (let* ((dict (srecode-create-dictionary))
+	     (temp (srecode-template-get-table (srecode-table)
+					       "getset-field"
+					       "declaration"
+					       'getset))
+	     )
+	(when (not temp)
+	  (error "Getset templates for %s not loaded!" major-mode))
+	(srecode-resolve-arguments temp dict)
+	(srecode-dictionary-set-value dict "NAME" field)
+	(when srecode-insert-getset-fully-automatic-flag
+	  (srecode-dictionary-set-value dict "TYPE" "int"))
+	(srecode-insert-fcn temp dict)
+
+	(semantic-fetch-tags)
+	(save-excursion
+	  (goto-char tagstart)
+	  ;; Refresh our class tag.
+	  (setq class (srecode-auto-choose-class (point)))
+	  )
+
+	(let ((tmptag (semantic-deep-find-tags-by-name-regexp
+		       field (current-buffer))))
+	  (setq tmptag (semantic-find-tags-by-class 'variable tmptag))
+
+	  (if tmptag
+	      (setq field (car tmptag))
+	    (error "Could not find new field %s" field)))
+	)
+
+      ;; Step 3.5: Insert an initializer if needed.
+      ;; ...
+
+
+      ;; Set up for the rest.
+      )
+
+    (if (not (semantic-tag-p field))
+	(error "Must specify field for get/set.  (parts may not be impl'd yet.)"))
+
+    ;; Set 4: Position for insertion of methods
+    (srecode-position-new-methods class field)
+
+    ;; Step 5: Insert the get/set methods
+    (if (not (eq (semantic-current-tag) class))
+	;; We are positioned on top of something else.
+	;; insert a /n
+	(insert "\n"))
+
+    (let* ((dict (srecode-create-dictionary))
+	   (srecode-semantic-selected-tag field)
+	   (temp (srecode-template-get-table (srecode-table)
+					     "getset-in-class"
+					     "declaration"
+					     'getset))
+	   )
+      (if (not temp)
+	  (error "Getset templates for %s not loaded!" major-mode))
+      (srecode-resolve-arguments temp dict)
+      (srecode-dictionary-set-value dict "GROUPNAME"
+				    (concat (semantic-tag-name field)
+					    " Accessors"))
+      (srecode-dictionary-set-value dict "NICENAME"
+				    (srecode-strip-fieldname
+				     (semantic-tag-name field)))
+      (srecode-insert-fcn temp dict)
+      )))
+
+(defun srecode-strip-fieldname (name)
+  "Strip the fieldname NAME of polish notation things."
+  (cond ((string-match "[a-z]\\([A-Z]\\w+\\)" name)
+	 (substring name (match-beginning 1)))
+	;; Add more rules here.
+	(t
+	 name)))
+
+(defun srecode-position-new-methods (class field)
+  "Position the cursor in CLASS where new getset methods should go.
+FIELD is the field for the get sets.
+INCLASS specifies if the cursor is already in CLASS or not."
+  (semantic-go-to-tag field)
+
+  (let ((prev (semantic-find-tag-by-overlay-prev))
+	(next (semantic-find-tag-by-overlay-next))
+	(setname nil)
+	(aftertag nil)
+	)
+    (cond
+     ((and prev (semantic-tag-of-class-p prev 'variable))
+      (setq setname
+	    (concat "set"
+		    (srecode-strip-fieldname (semantic-tag-name prev))))
+      )
+     ((and next (semantic-tag-of-class-p next 'variable))
+      (setq setname
+	    (concat "set"
+		    (srecode-strip-fieldname (semantic-tag-name prev)))))
+     (t nil))
+
+    (setq aftertag (semantic-find-first-tag-by-name
+		    setname (semantic-tag-type-members class)))
+
+    (when (not aftertag)
+      (setq aftertag (car-safe
+		      (semantic--find-tags-by-macro
+		       (semantic-tag-get-attribute (car tags) :destructor-flag)
+		       (semantic-tag-type-members class))))
+      ;; Make sure the tag is public
+      (when (not (eq (semantic-tag-protection aftertag class) 'public))
+	(setq aftertag nil))
+      )
+
+    (if (not aftertag)
+	(setq aftertag (car-safe
+			(semantic--find-tags-by-macro
+			 (semantic-tag-get-attribute (car tags) :constructor-flag)
+			 (semantic-tag-type-members class))))
+      ;; Make sure the tag is public
+      (when (not (eq (semantic-tag-protection aftertag class) 'public))
+	(setq aftertag nil))
+      )
+
+    (when (not aftertag)
+      (setq aftertag (semantic-find-first-tag-by-name
+		      "public" (semantic-tag-type-members class))))
+
+    (when (not aftertag)
+      (setq aftertag (car (semantic-tag-type-members class))))
+
+    (if aftertag
+	(let ((te (semantic-tag-end aftertag)))
+	  (when (not te)
+	    (message "Unknown location for tag-end in %s:" (semantic-tag-name aftertag)))
+	  (goto-char te)
+	  ;; If there is a comment immediatly after aftertag, skip over it.
+	  (when (looking-at (concat "\\s-*\n?\\s-*" semantic-lex-comment-regex))
+	    (let ((pos (point))
+		  (rnext (semantic-find-tag-by-overlay-next (point))))
+	      (forward-comment 1)
+	      ;; Make sure the comment we skipped didn't say anything about
+	      ;; the rnext tag.
+	      (when (and rnext
+			 (re-search-backward
+			  (regexp-quote (semantic-tag-name rnext)) pos t))
+		;; It did mention rnext, so go back to our starting position.
+		(goto-char pos)
+		)
+	      ))
+	  )
+
+      ;; At the very beginning of the class.
+      (goto-char (semantic-tag-end class))
+      (forward-sexp -1)
+      (forward-char 1)
+
+      )
+
+    (end-of-line)
+    (forward-char 1)
+    ))
+
+(defun srecode-position-new-field (class inclass)
+  "Select a position for a new field for CLASS.
+If INCLASS is non-nil, then the cursor is already in the class
+and should not be moved during point selection."
+
+  ;; If we aren't in the class, get the cursor there, pronto!
+  (when (not inclass)
+
+    (error "You must position the cursor where to insert the new field")
+
+    (let ((kids (semantic-find-tags-by-class
+		 'variable (semantic-tag-type-members class))))
+      (cond (kids
+	     (semantic-go-to-tag (car kids) class))
+	    (t
+	     (semantic-go-to-tag class)))
+      )
+
+    (switch-to-buffer (current-buffer))
+
+    ;; Once the cursor is in our class, ask the user to position
+    ;; the cursor to keep going.
+    )
+
+  (if (or srecode-insert-getset-fully-automatic-flag
+	  (y-or-n-p "Insert new field here? "))
+      nil
+    (error "You must position the cursor where to insert the new field first"))
+  )
+
+
+
+(defun srecode-auto-choose-field (point)
+  "Choose a field for the get/set methods.
+Base selection on the field related to POINT."
+  (save-excursion
+    (when point
+      (goto-char point))
+
+    (let ((field (semantic-current-tag-of-class 'variable)))
+
+      ;; If we get a field, make sure the user gets a chance to choose.
+      (when field
+	(if srecode-insert-getset-fully-automatic-flag
+	    nil
+	  (when (not (y-or-n-p
+		      (format "Use field %s? " (semantic-tag-name field))))
+	    (setq field nil))
+	  ))
+      field)))
+
+(defun srecode-query-for-field (class)
+  "Query for a field in CLASS."
+  (let* ((kids (semantic-find-tags-by-class
+		'variable (semantic-tag-type-members class)))
+	 (sel (completing-read "Use Field: " kids))
+	 )
+
+    (or (semantic-find-tags-by-name sel kids)
+	sel)
+    ))
+
+(defun srecode-auto-choose-class (point)
+  "Choose a class based on locatin of POINT."
+  (save-excursion
+    (when point
+      (goto-char point))
+
+    (let ((tag (semantic-current-tag-of-class 'type)))
+
+      (when (or (not tag)
+		(not (string= (semantic-tag-type tag) "class")))
+	;; The current tag is not a class.  Are we in a fcn
+	;; that is a method?
+	(setq tag (semantic-current-tag-of-class 'function))
+
+	(when (and tag
+		   (semantic-tag-function-parent tag))
+	  (let ((p (semantic-tag-function-parent tag)))
+	    ;; @TODO : Copied below out of semantic-analyze
+	    ;;         Turn into a routine.
+
+	    (let* ((searchname (cond ((stringp p) p)
+				     ((semantic-tag-p p)
+				      (semantic-tag-name p))
+				     ((and (listp p) (stringp (car p)))
+				      (car p))))
+		   (ptag (semantic-analyze-find-tag searchname
+						    'type nil)))
+	      (when ptag (setq tag ptag ))
+	      ))))
+
+      (when (or (not tag)
+		(not (semantic-tag-of-class-p tag 'type))
+		(not (string= (semantic-tag-type tag) "class")))
+	;; We are not in a class that needs a get/set method.
+	;; Analyze the current context, and derive a class name.
+	(let* ((ctxt (semantic-analyze-current-context))
+	       (pfix nil)
+	       (ans nil))
+	  (when ctxt
+	    (setq pfix (reverse (oref ctxt prefix)))
+	    (while (and (not ans) pfix)
+	      ;; Start at the end and back up to the first class.
+	      (when (and (semantic-tag-p (car pfix))
+			 (semantic-tag-of-class-p (car pfix) 'type)
+			 (string= (semantic-tag-type (car pfix))
+				  "class"))
+		(setq ans (car pfix)))
+	      (setq pfix (cdr pfix))))
+	  (setq tag ans)))
+
+      tag)))
+
+(provide 'srecode/getset)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: srecode/loaddefs
+;; generated-autoload-load-name: "srecode/getset"
+;; End:
+
+;;; srecode/getset.el ends here