procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

lisp/cedet/srecode.el:

Browse source 
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.
This commit is contained in:
Chong Yidong 2009-09-20 21:06:41 +00:00
parent 70702e9b0e
commit 4d902e6f13
29 changed files with 8633 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
lisp/ChangeLog
View file

@ -9,6 +9,7 @@
* progmodes/autoconf.el: Provide autoconf as well.
* files.el (auto-mode-alist): Use emacs-lisp-mode for Project.ede.
(auto-mode-alist): Use srecode-template-mode for .srt files.
* cedet/semantic/bovine/gcc.el (semantic-gcc-test-output-parser)
(semantic-gcc-test-output-parser-this-machine):

6
lisp/cedet/semantic/bovine/scm.el
View file

@ -115,4 +115,10 @@ syntax as specified by the syntax table."
(provide 'semantic/bovine/scm)
;; Local variables:
;; generated-autoload-file: "../loaddefs.el"
;; generated-autoload-feature: semantic/loaddefs
;; generated-autoload-load-name: "semantic/bovine/scm"
;; End:
;;; semantic/bovine/scm.el ends here

53
lisp/cedet/srecode.el Normal file
View file

@ -0,0 +1,53 @@
;;; srecode.el --- Semantic buffer evaluator.
;;; Copyright (C) 2005, 2007, 2008, 2009 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: codegeneration
;; 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:
;;
;; Semantic does the job of converting source code into useful tag
;; information. The set of `semantic-format-tag' functions has one
;; function that will create a prototype of a tag, which has severe
;; issues of complexity (in the format tag file itself) and inaccuracy
;; (for the purpose of C++ code.)
;;
;; Contemplation of the simplistic problem within the scope of
;; semantic showed that the solution was more complex than could
;; possibly be handled in semantic-format.el. Semantic Recode, or
;; srecode is a rich API for generating code out of semantic tags, or
;; recoding the tags.
;;
;; See the srecode manual for specific details.
(require 'eieio)
(require 'mode-local)
(require 'srecode/loaddefs)
(defvar srecode-version "1.0pre7"
"Current version of the Semantic Recoder.")
;;; Code:
(defgroup srecode nil
"Semantic Recoder."
:group 'tools)
(provide 'srecode)
;;; srecode.el ends here

188
lisp/cedet/srecode/args.el Normal file
View file

@ -0,0 +1,188 @@
;;; srecode/args.el --- Provide some simple template arguments
;;; 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:
;;
;; Srecode templates can accept arguments. These arguments represent
;; sets of dictionary words that need to be derived. This file contains
;; a set of simple arguments for srecode templates.
(require 'srecode/insert)
;;; Code:
;;; :blank
;;
;; Using :blank means that the template should force blank lines
;; before and after the template, reguardless of where the insertion
;; is occuring.
(defun srecode-semantic-handle-:blank (dict)
"Add macros into the dictionary DICT specifying blank line spacing.
The wrapgap means make sure the first and last lines of the macro
do not contain any text from preceeding or following text."
;; This won't actually get used, but it might be nice
;; to know about it.
(srecode-dictionary-set-value dict "BLANK" t)
)
;;; :indent ARGUMENT HANDLING
;;
;; When a :indent argument is required, the default is to indent
;; for the current major mode.
(defun srecode-semantic-handle-:indent (dict)
"Add macros into the dictionary DICT for indentation."
(srecode-dictionary-set-value dict "INDENT" t)
)
;;; :region ARGUMENT HANDLING
;;
;; When a :region argument is required, provide macros that
;; deal with that active region.
;;
;; Regions allow a macro to wrap the region text within the
;; template bounds.
;;
(defvar srecode-handle-region-when-non-active-flag nil
"Non-nil means do region handling w/out the region being active.")
(defun srecode-semantic-handle-:region (dict)
"Add macros into the dictionary DICT based on the current :region."
;; Only enable the region section if we can clearly show that
;; the user is intending to do something with the region.
(when (or srecode-handle-region-when-non-active-flag
(eq last-command 'mouse-drag-region)
(and transient-mark-mode mark-active))
;; Show the region section
(srecode-dictionary-show-section dict "REGION")
(srecode-dictionary-set-value
dict "REGIONTEXT" (buffer-substring-no-properties (point) (mark)))
;; Only whack the region if our template output
;; is also destined for the current buffer.
(when (eq standard-output (current-buffer))
(kill-region (point) (mark))))
)
;;; :user ARGUMENT HANDLING
;;
;; When a :user argument is required, fill the dictionary with
;; information about the current Emacs user.
(defun srecode-semantic-handle-:user (dict)
"Add macros into the dictionary DICT based on the current :user."
(srecode-dictionary-set-value dict "AUTHOR" (user-full-name))
(srecode-dictionary-set-value dict "LOGIN" (user-login-name))
(srecode-dictionary-set-value dict "EMAIL" user-mail-address)
(srecode-dictionary-set-value dict "EMACSINITFILE" user-init-file)
(srecode-dictionary-set-value dict "UID" (user-uid))
)
;;; :time ARGUMENT HANDLING
;;
;; When a :time argument is required, fill the dictionary with
;; information about the current Emacs time.
(defun srecode-semantic-handle-:time (dict)
"Add macros into the dictionary DICT based on the current :time."
;; DATE Values
(srecode-dictionary-set-value
dict "YEAR" (format-time-string "%Y" (current-time)))
(srecode-dictionary-set-value
dict "MONTHNAME" (format-time-string "%B" (current-time)))
(srecode-dictionary-set-value
dict "MONTH" (format-time-string "%m" (current-time)))
(srecode-dictionary-set-value
dict "DAY" (format-time-string "%d" (current-time)))
(srecode-dictionary-set-value
dict "WEEKDAY" (format-time-string "%a" (current-time)))
;; Time Values
(srecode-dictionary-set-value
dict "HOUR" (format-time-string "%H" (current-time)))
(srecode-dictionary-set-value
dict "HOUR12" (format-time-string "%l" (current-time)))
(srecode-dictionary-set-value
dict "AMPM" (format-time-string "%p" (current-time)))
(srecode-dictionary-set-value
dict "MINUTE" (format-time-string "%M" (current-time)))
(srecode-dictionary-set-value
dict "SECOND" (format-time-string "%S" (current-time)))
(srecode-dictionary-set-value
dict "TIMEZONE" (format-time-string "%Z" (current-time)))
;; Convenience pre-packed date/time
(srecode-dictionary-set-value
dict "DATE" (format-time-string "%D" (current-time)))
(srecode-dictionary-set-value
dict "TIME" (format-time-string "%X" (current-time)))
)
;;; :file ARGUMENT HANDLING
;;
;; When a :file argument is required, fill the dictionary with
;; information about the file Emacs is editing at the time of
;; insertion.
(defun srecode-semantic-handle-:file (dict)
"Add macros into the dictionary DICT based on the current :file."
(let* ((bfn (buffer-file-name))
(file (file-name-nondirectory bfn))
(dir (file-name-directory bfn)))
(srecode-dictionary-set-value dict "FILENAME" file)
(srecode-dictionary-set-value dict "FILE" (file-name-sans-extension file))
(srecode-dictionary-set-value dict "EXTENSION" (file-name-extension file))
(srecode-dictionary-set-value dict "DIRECTORY" dir)
(srecode-dictionary-set-value dict "MODE" (symbol-name major-mode))
(srecode-dictionary-set-value
dict "SHORTMODE"
(let* ((mode-name (symbol-name major-mode))
(match (string-match "-mode" mode-name)))
(if match
(substring mode-name 0 match)
mode-name)))
(if (or (file-exists-p "CVS")
(file-exists-p "RCS"))
(srecode-dictionary-show-section dict "RCS")
)))
;;; :system ARGUMENT HANDLING
;;
;; When a :system argument is required, fill the dictionary with
;; information about the computer Emacs is running on.
(defun srecode-semantic-handle-:system (dict)
"Add macros into the dictionary DICT based on the current :system."
(srecode-dictionary-set-value dict "SYSTEMCONF" system-configuration)
(srecode-dictionary-set-value dict "SYSTEMTYPE" system-type)
(srecode-dictionary-set-value dict "SYSTEMNAME" (system-name))
(srecode-dictionary-set-value dict "MAILHOST" (or mail-host-address
(system-name)))
)
;;; :kill ARGUMENT HANDLING
;;
;; When a :kill argument is required, fill the dictionary with
;; information about the current kill ring.
(defun srecode-semantic-handle-:kill (dict)
"Add macros into the dictionary DICT based on the kill ring."
(srecode-dictionary-set-value dict "KILL" (car kill-ring))
(srecode-dictionary-set-value dict "KILL2" (nth 1 kill-ring))
(srecode-dictionary-set-value dict "KILL3" (nth 2 kill-ring))
(srecode-dictionary-set-value dict "KILL4" (nth 3 kill-ring))
)
(provide 'srecode/args)
;;; srecode/args.el ends here

640
lisp/cedet/srecode/compile.el Normal file
View file

@ -0,0 +1,640 @@
;;; srecode/compile --- Compilation of srecode template files.
;;; Copyright (C) 2005, 2007, 2008, 2009 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: codegeneration
;; 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:
;;
;; Compile a Semantic Recoder template file.
;;
;; Template files are parsed using a Semantic/Wisent parser into
;; a tag table. The code therin is then further parsed down using
;; a regular expression parser.
;;
;; The output are a series of EIEIO objects which represent the
;; templates in a way that could be inserted later.
(require 'semantic)
(require 'eieio)
(require 'eieio-base)
(require 'srecode)
(require 'srecode/table)
(declare-function srecode-template-inserter-newline-child-p "srecode/insert")
(declare-function srecode-create-section-dictionary "srecode/dictionary")
(declare-function srecode-dictionary-compound-variable "srecode/dictionary")
;;; Code:
;;; Template Class
;;
;; Templatets describe a patter of text that can be inserted into a
;; buffer.
;;
(defclass srecode-template (eieio-named)
((context :initarg :context
:initform nil
:documentation
"Context this template belongs to.")
(args :initarg :args
:documentation
"List of arguments that this template requires.")
(code :initarg :code
:documentation
"Compiled text from the template.")
(dictionary :initarg :dictionary
:type (or null srecode-dictionary)
:documentation
"List of section dictinaries.
The compiled template can contain lists of section dictionaries,
or values that are expected to be passed down into different
section macros. The template section dictionaries are merged in with
any incomming dictionaries values.")
(binding :initarg :binding
:documentation
"Preferred keybinding for this template in `srecode-minor-mode-map'.")
(active :allocation :class
:initform nil
:documentation
"During template insertion, this is the stack of active templates.
The top-most template is the 'active' template. Use the accessor methods
for push, pop, and peek for the active template.")
(table :initarg :table
:documentation
"The table this template lives in.")
)
"Class defines storage for semantic recoder templates.")
(defun srecode-flush-active-templates ()
"Flush the active template storage.
Useful if something goes wrong in SRecode, and the active tempalte
stack is broken."
(interactive)
(if (oref srecode-template active)
(when (y-or-n-p (format "%d active templates. Flush? "
(length (oref srecode-template active))))
(oset-default srecode-template active nil))
(message "No active templates to flush."))
)
;;; Inserters
;;
;; Each inserter object manages a different thing that
;; might be inserted into a template output stream.
;;
;; The 'srecode-insert-method' on each inserter does the actual
;; work, and the smaller, simple inserter object is saved in
;; the compiled templates.
;;
;; See srecode-insert.el for the specialized classes.
;;
(defclass srecode-template-inserter (eieio-named)
((secondname :initarg :secondname
:type (or null string)
:documentation
"If there is a colon in the inserter's name, it represents
additional static argument data."))
"This represents an item to be inserted via a template macro.
Plain text strings are not handled via this baseclass."
:abstract t)
(defmethod srecode-parse-input ((ins srecode-template-inserter)
tag input STATE)
"For the template inserter INS, parse INPUT.
Shorten input only by the amount needed.
Return the remains of INPUT.
STATE is the current compilation state."
input)
(defmethod srecode-match-end ((ins srecode-template-inserter) name)
"For the template inserter INS, do I end a section called NAME?"
nil)
(defmethod srecode-inserter-apply-state ((ins srecode-template-inserter) STATE)
"For the template inserter INS, apply information from STATE."
nil)
(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter)
escape-start escape-end)
"Insert an example using inserter INS.
Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
(princ " ")
(princ escape-start)
(when (and (slot-exists-p ins 'key) (oref ins key))
(princ (format "%c" (oref ins key))))
(princ "VARNAME")
(princ escape-end)
(terpri)
)
;;; Compile State
(defclass srecode-compile-state ()
((context :initform "declaration"
:documentation "The active context.")
(prompts :initform nil
:documentation "The active prompts.")
(escape_start :initform "{{"
:documentation "The starting escape sequence.")
(escape_end :initform "}}"
:documentation "The ending escape sequence.")
)
"Current state of the compile.")
(defmethod srecode-compile-add-prompt ((state srecode-compile-state)
prompttag)
"Add PROMPTTAG to the current list of prompts."
(with-slots (prompts) state
(let ((match (assoc (semantic-tag-name prompttag) prompts))
(newprompts prompts))
(when match
(let ((tmp prompts))
(setq newprompts nil)
(while tmp
(when (not (string= (car (car tmp))
(car prompttag)))
(setq newprompts (cons (car tmp)
newprompts)))
(setq tmp (cdr tmp)))))
(setq prompts (cons prompttag newprompts)))
))
;;; TEMPLATE COMPILER
;;
(defun srecode-compile-file (fname)
"Compile the templates from the file FNAME."
(let ((peb (get-file-buffer fname)))
(save-excursion
;; Make whatever it is local.
(if (not peb)
(set-buffer (semantic-find-file-noselect fname))
(set-buffer peb))
;; Do the compile.
(srecode-compile-templates)
;; Trash the buffer if we had to read it in.
(if (not peb)
(kill-buffer (current-buffer)))
)))
;;;###autoload
(defun srecode-compile-templates ()
"Compile a semantic recode template file into a mode-local variable."
(interactive)
(require 'srecode-insert)
(message "Compiling template %s..."
(file-name-nondirectory (buffer-file-name)))
(let ((tags (semantic-fetch-tags))
(tag nil)
(class nil)
(table nil)
(STATE (srecode-compile-state (file-name-nondirectory
(buffer-file-name))))
(mode nil)
(application nil)
(priority nil)
(vars nil)
)
;;
;; COMPILE
;;
(while tags
(setq tag (car tags)
class (semantic-tag-class tag))
;; What type of item is it?
(cond
;; CONTEXT tags specify the context all future tags
;; belong to.
((eq class 'context)
(oset STATE context (semantic-tag-name tag))
)
;; PROMPT tags specify prompts for dictionary ? inserters
;; which appear in the following templates
((eq class 'prompt)
(srecode-compile-add-prompt STATE tag)
)
;; VARIABLE tags can specify operational control
((eq class 'variable)
(let* ((name (semantic-tag-name tag))
(value (semantic-tag-variable-default tag))
(firstvalue (car value)))
;; If it is a single string, and one value, then
;; look to see if it is one of our special variables.
(if (and (= (length value) 1) (stringp firstvalue))
(cond ((string= name "mode")
(setq mode (intern firstvalue)))
((string= name "escape_start")
(oset STATE escape_start firstvalue)
)
((string= name "escape_end")
(oset STATE escape_end firstvalue)
)
((string= name "application")
(setq application (read firstvalue)))
((string= name "priority")
(setq priority (read firstvalue)))
(t
;; Assign this into some table of variables.
(setq vars (cons (cons name firstvalue) vars))
))
;; If it isn't a single string, then the value of the
;; variable belongs to a compound dictionary value.
;;
;; Create a compound dictionary value from "value".
(require 'srecode/dictionary)
(let ((cv (srecode-dictionary-compound-variable
name :value value)))
(setq vars (cons (cons name cv) vars)))
))
)
;; FUNCTION tags are really templates.
((eq class 'function)
(setq table (cons (srecode-compile-one-template-tag tag STATE)
table))
)
;; Ooops
(t (error "Unknown TAG class %s" class))
)
;; Continue
(setq tags (cdr tags)))
;; MSG - Before install since nreverse whacks our list.
(message "%d templates compiled for %s"
(length table) mode)
;;
;; APPLY TO MODE
;;
(if (not mode)
(error "You must specify a MODE for your templates"))
;;
;; Calculate priority
;;
(if (not priority)
(let ((d (file-name-directory (buffer-file-name)))
(sd (file-name-directory (locate-library "srecode")))
(defaultdelta (if (eq mode 'default) 20 0)))
(if (string= d sd)
(setq priority (+ 80 defaultdelta))
(setq priority (+ 30 defaultdelta)))
(message "Templates %s has estimated priority of %d"
(file-name-nondirectory (buffer-file-name))
priority))
(message "Compiling templates %s priority %d... done!"
(file-name-nondirectory (buffer-file-name))
priority))
;; Save it up!
(srecode-compile-template-table table mode priority application vars)
)
)
(defun srecode-compile-one-template-tag (tag STATE)
"Compile a template tag TAG into an srecode template class.
STATE is the current compile state as an object `srecode-compile-state'."
(require 'srecode/dictionary)
(let* ((context (oref STATE context))
(codeout (srecode-compile-split-code
tag (semantic-tag-get-attribute tag :code)
STATE))
(code (cdr codeout))
(args (semantic-tag-function-arguments tag))
(binding (semantic-tag-get-attribute tag :binding))
(rawdicts (semantic-tag-get-attribute tag :dictionaries))
(sdicts (srecode-create-section-dictionary rawdicts STATE))
(addargs nil)
)
; (message "Compiled %s to %d codes with %d args and %d prompts."
; (semantic-tag-name tag)
; (length code)
; (length args)
; (length prompts))
(while args
(setq addargs (cons (intern (car args)) addargs))
(when (eq (car addargs) :blank)
;; If we have a wrap, then put wrap inserters on both
;; ends of the code.
(setq code (append
(list (srecode-compile-inserter "BLANK"
"\r"
STATE
:secondname nil
:where 'begin))
code
(list (srecode-compile-inserter "BLANK"
"\r"
STATE
:secondname nil
:where 'end))
)))
(setq args (cdr args)))
(srecode-template (semantic-tag-name tag)
:context context
:args (nreverse addargs)
:dictionary sdicts
:binding binding
:code code)
))
(defun srecode-compile-do-hard-newline-p (comp)
"Examine COMP to decide if the upcoming newline should be hard.
It is hard if the previous inserter is a newline object."
(while (and comp (stringp (car comp)))
(setq comp (cdr comp)))
(or (not comp)
(require 'srecode/insert)
(srecode-template-inserter-newline-child-p (car comp))))
(defun srecode-compile-split-code (tag str STATE
&optional end-name)
"Split the code for TAG into something templatable.
STR is the string of code from TAG to split.
STATE is the current compile state.
ESCAPE_START and ESCAPE_END are regexps that indicate the beginning
escape character, and end escape character pattern for expandable
macro names.
Optional argument END-NAME specifies the name of a token upon which
parsing should stop.
If END-NAME is specified, and the input string"
(let* ((what str)
(end-token nil)
(comp nil)
(regex (concat "\n\\|" (regexp-quote (oref STATE escape_start))))
(regexend (regexp-quote (oref STATE escape_end)))
)
(while (and what (not end-token))
(cond
((string-match regex what)
(let* ((prefix (substring what 0 (match-beginning 0)))
(match (substring what
(match-beginning 0)
(match-end 0)))
(namestart (match-end 0))
(junk (string-match regexend what namestart))
end tail name)
;; Add string to compiled output
(when (> (length prefix) 0)
(setq comp (cons prefix comp)))
(if (string= match "\n")
;; Do newline thingy.
(let ((new-inserter
(srecode-compile-inserter
"INDENT"
"\n"
STATE
:secondname nil
;; This newline is "hard" meaning ALWAYS do it
;; if the previous entry is also a newline.
;; Without it, user entered blank lines will be
;; ignored.
:hard (srecode-compile-do-hard-newline-p comp)
)))
;; Trim WHAT back.
(setq what (substring what namestart))
(when (> (length what) 0)
;; make the new inserter, but only if we aren't last.
(setq comp (cons new-inserter comp))
))
;; Regular inserter thingy.
(setq end (if junk
(match-beginning 0)
(error "Could not find end escape for %s"
(semantic-tag-name tag)))
tail (match-end 0))
(cond ((not end)
(error "No matching escape end for %s"
(semantic-tag-name tag)))
((<= end namestart)
(error "Stray end escape for %s"
(semantic-tag-name tag)))
)
;; Add string to compiled output
(setq name (substring what namestart end)
key nil)
;; Trim WHAT back.
(setq what (substring what tail))
;; Get the inserter
(let ((new-inserter
(srecode-compile-parse-inserter name STATE))
)
;; If this is an end inserter, then assign into
;; the end-token.
(if (srecode-match-end new-inserter end-name)
(setq end-token new-inserter))
;; Add the inserter to our compilation stream.
(setq comp (cons new-inserter comp))
;; Allow the inserter an opportunity to modify
;; the input stream.
(setq what (srecode-parse-input new-inserter tag what
STATE))
)
)))
(t
(if end-name
(error "Unmatched section end %s" end-name))
(setq comp (cons what comp)
what nil))))
(cons what (nreverse comp))))
(defun srecode-compile-parse-inserter (txt STATE)
"Parse the inserter TXT with the current STATE.
Return an inserter object."
(let ((key (aref txt 0))
)
(if (and (or (< key ?A) (> key ?Z))
(or (< key ?a) (> key ?z)) )
(setq name (substring txt 1))
(setq name txt
key nil))
(let* ((junk (string-match ":" name))
(namepart (if junk
(substring name 0 (match-beginning 0))
name))
(secondname (if junk
(substring name (match-end 0))
nil))
(new-inserter (srecode-compile-inserter
namepart key STATE
:secondname secondname
)))
;; Return the new inserter
new-inserter)))
(defun srecode-compile-inserter (name key STATE &rest props)
"Create an srecode inserter object for some macro NAME.
KEY indicates a single character key representing a type
of inserter to create.
STATE is the current compile state.
PROPS are additional properties that might need to be passed
to the inserter constructor."
;;(message "Compile: %s %S" name props)
(if (not key)
(apply 'srecode-template-inserter-variable name props)
(let ((classes (class-children srecode-template-inserter))
(new nil))
;; Loop over the various subclasses and
;; create the correct inserter.
(while (and (not new) classes)
(setq classes (append classes (class-children (car classes))))
;; Do we have a match?
(when (and (not (class-abstract-p (car classes)))
(equal (oref (car classes) key) key))
;; Create the new class, and apply state.
(setq new (apply (car classes) name props))
(srecode-inserter-apply-state new STATE)
)
(setq classes (cdr classes)))
(if (not new) (error "SRECODE: Unknown macro code %S" key))
new)))
(defun srecode-compile-template-table (templates mode priority application vars)
"Compile a list of TEMPLATES into an semantic recode table.
The table being compiled is for MODE, or the string \"default\".
PRIORITY is a numerical value that indicates this tables location
in an ordered search.
APPLICATION is the name of the application these templates belong to.
A list of defined variables VARS provides a variable table."
(let ((namehash (make-hash-table :test 'equal
:size (length templates)))
(contexthash (make-hash-table :test 'equal :size 10))
(lp templates)
)
(while lp
(let* ((objname (oref (car lp) :object-name))
(context (oref (car lp) :context))
(globalname (concat context ":" objname))
)
;; Place this template object into the global name hash.
(puthash globalname (car lp) namehash)
;; Place this template into the specific context name hash.
(let ((hs (gethash context contexthash)))
;; Make a new context if none was available.
(when (not hs)
(setq hs (make-hash-table :test 'equal :size 20))
(puthash context hs contexthash))
;; Put into that contenxt's hash.
(puthash objname (car lp) hs)
)
(setq lp (cdr lp))))
(let* ((table (srecode-mode-table-new mode (buffer-file-name)
:templates (nreverse templates)
:namehash namehash
:contexthash contexthash
:variables vars
:major-mode mode
:priority priority
:application application))
(tmpl (oref table templates)))
;; Loop over all the templates, and xref.
(while tmpl
(oset (car tmpl) :table table)
(setq tmpl (cdr tmpl))))
))
;;; DEBUG
;;
;; Dump out information about the current srecoder compiled templates.
;;
(defmethod srecode-dump ((tmp srecode-template))
"Dump the contents of the SRecode template tmp."
(princ "== Template \"")
(princ (object-name-string tmp))
(princ "\" in context ")
(princ (oref tmp context))
(princ "\n")
(when (oref tmp args)
(princ " Arguments: ")
(prin1 (oref tmp args))
(princ "\n"))
(when (oref tmp dictionary)
(princ " Section Dictionaries:\n")
(srecode-dump (oref tmp dictionary) 4)
;(princ "\n")
)
(when (and (slot-boundp tmp 'binding) (oref tmp binding))
(princ " Binding: ")
(prin1 (oref tmp binding))
(princ "\n"))
(princ " Compiled Codes:\n")
(srecode-dump-code-list (oref tmp code) " ")
(princ "\n\n")
)
(defun srecode-dump-code-list (code indent)
"Dump the CODE from a template code list to standard output.
Argument INDENT specifies the indentation level for the list."
(let ((i 1))
(while code
(princ indent)
(prin1 i)
(princ ") ")
(cond ((stringp (car code))
(prin1 (car code)))
((srecode-template-inserter-child-p (car code))
(srecode-dump (car code) indent))
(t
(princ "Unknown Code: ")
(prin1 (car code))))
(setq code (cdr code)
i (1+ i))
(when code
(princ "\n"))))
)
(defmethod srecode-dump ((ins srecode-template-inserter) indent)
"Dump the state of the SRecode template inserter INS."
(princ "INS: \"")
(princ (object-name-string ins))
(when (oref ins :secondname)
(princ "\" : \"")
(princ (oref ins :secondname)))
(princ "\" type \"")
(let* ((oc (symbol-name (object-class ins)))
(junk (string-match "srecode-template-inserter-" oc))
(on (if junk
(substring oc (match-end 0))
oc)))
(princ on))
(princ "\"")
)
(provide 'srecode/compile)
;; Local variables:
;; generated-autoload-file: "loaddefs.el"
;; generated-autoload-feature: srecode/loaddefs
;; generated-autoload-load-name: "srecode/compile"
;; End:
;;; srecode/compile.el ends here

149
lisp/cedet/srecode/cpp.el Normal file
View file

@ -0,0 +1,149 @@
;;; srecode/cpp.el --- C++ specific handlers for Semantic Recoder
;; Copyright (C) 2007, 2009 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
;; Jan Moringen <scymtym@users.sourceforge.net>
;; 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:
;;
;; Supply some C++ specific dictionary fillers and helpers
;;; Code:
;;; :cpp ARGUMENT HANDLING
;;
;; When a :cpp argument is required, fill the dictionary with
;; information about the current C++ file.
;;
;; Error if not in a C++ mode.
(require 'srecode)
(require 'srecode/dictionary)
(require 'srecode/semantic)
;;;###autoload
(defun srecode-semantic-handle-:cpp (dict)
"Add macros into the dictionary DICT based on the current c++ file.
Adds the following:
FILENAME_SYMBOL - filename converted into a C compat symbol.
HEADER - Shown section if in a header file."
;; A symbol representing
(let ((fsym (file-name-nondirectory (buffer-file-name)))
(case-fold-search t))
;; Are we in a header file?
(if (string-match "\\.\\(h\\|hh\\|hpp\\|h\\+\\+\\)$" fsym)
(srecode-dictionary-show-section dict "HEADER")
(srecode-dictionary-show-section dict "NOTHEADER"))
;; Strip out bad characters
(while (string-match "\\.\\| " fsym)
(setq fsym (replace-match "_" t t fsym)))
(srecode-dictionary-set-value dict "FILENAME_SYMBOL" fsym)
)
)
(define-mode-local-override srecode-semantic-apply-tag-to-dict
c++-mode (tag-wrapper dict)
"Apply C++ specific features from TAG-WRAPPER into DICT.
Calls `srecode-semantic-apply-tag-to-dict-default' first. Adds
special behavior for tag of classes include, using and function."
;; Use default implementation to fill in the basic properties.
(srecode-semantic-apply-tag-to-dict-default tag-wrapper dict)
;; Pull out the tag for the individual pieces.
(let* ((tag (oref tag-wrapper :prime))
(class (semantic-tag-class tag)))
;; Add additional information based on the class of the tag.
(cond
;;
;; INCLUDE
;;
((eq class 'include)
;; For include tags, we have to discriminate between system-wide
;; and local includes.
(if (semantic-tag-include-system-p tag)
(srecode-dictionary-show-section dict "SYSTEM")
(srecode-dictionary-show-section dict "LOCAL")))
;;
;; USING
;;
((eq class 'using)
;; Insert the subject (a tag) of the include statement as VALUE
;; entry into the dictionary.
(let ((value-tag (semantic-tag-get-attribute tag :value))
(value-dict (srecode-dictionary-add-section-dictionary
dict "VALUE")))
(srecode-semantic-apply-tag-to-dict
(srecode-semantic-tag (semantic-tag-name value-tag)
:prime value-tag)
value-dict))
;; Discriminate using statements referring to namespaces and
;; types.
(when (eq (semantic-tag-get-attribute tag :kind) 'namespace)
(srecode-dictionary-show-section dict "NAMESPACE")))
;;
;; FUNCTION
;;
((eq class 'function)
;; @todo It would be nice to distinguish member functions from
;; free functions and only apply the const and pure modifiers,
;; when they make sense. My best bet would be
;; (semantic-tag-function-parent tag), but it is not there, when
;; the function is defined in the scope of a class.
(let ((member 't)
(modifiers (semantic-tag-modifiers tag)))
;; Add modifiers into the dictionary
(dolist (modifier modifiers)
(let ((modifier-dict (srecode-dictionary-add-section-dictionary
dict "MODIFIERS")))
(srecode-dictionary-set-value modifier-dict "NAME" modifier)))
;; When the function is a member function, it can have
;; additional modifiers.
(when member
;; For member functions, constness is called
;; 'methodconst-flag'.
(when (semantic-tag-get-attribute tag :methodconst-flag)
(srecode-dictionary-show-section dict "CONST"))
;; If the member function is pure virtual, add a dictionary
;; entry.
(when (semantic-tag-get-attribute tag :pure-virtual-flag)
(srecode-dictionary-show-section dict "PURE"))
)
))
))
)
(provide 'srecode/cpp)
;; Local variables:
;; generated-autoload-file: "loaddefs.el"
;; generated-autoload-feature: srecode/loaddefs
;; generated-autoload-load-name: "srecode/cpp"
;; End:
;;; srecode/cpp.el ends here

247
lisp/cedet/srecode/ctxt.el Normal file
View file

@ -0,0 +1,247 @@
;;; srecode/ctxt.el --- Derive a context from the source buffer.
;; 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:
;;
;; Manage context calculations for Semantic Recoder.
;;
;; SRecode templates are always bound to a context. By calculating
;; the current context, we can narrow down the selection of possible
;; templates to something reasonable.
;;
;; Alternately, code here will find a context for templates that
;; require different pieces of code placed in multiple areas.
(require 'semantic)
(require 'semantic/tag-ls)
(declare-function srecode-dictionary-show-section "srecode/dictionary")
(declare-function srecode-dictionary-set-value "srecode/dictionary")
;;; Code:
(define-overload srecode-calculate-context ()
"Calculate the context at the current point.
The returned context is a list, with the top-most context first.
Each returned context is a string that that would show up in a `context'
statement in an `.srt' file.
Some useful context values used by the provided srecode templates are:
\"file\" - Templates that for a file (such as an empty file.)
\"empty\" - The file is empty
\"declaration\" - Top-level declarations in a file.
\"include\" - In or near include statements
\"package\" - In or near provide statements
\"function\" - In or near function statements
\"NAME\" - Near functions within NAME namespace or class
\"variable\" - In or near variable statements.
\"type\" - In or near type declarations.
\"comment\" - In a comment
\"classdecl\" - Declarations within a class/struct/etc.
\"variable\" - In or near class fields
\"function\" - In or near methods/functions
\"virtual\" - Nearby items are virtual
\"pure\" - and those virtual items are pure virtual
\"type\" - In or near type declarations.
\"comment\" - In a comment in a block of code
-- these items show up at the end of the context list. --
\"public\", \"protected\", \"private\" -
In or near a section of public/pritected/private entries.
\"code\" - In a block of code.
\"string\" - In a string in a block of code
\"comment\" - In a comment in a block of code
... More later."
)
(defun srecode-calculate-nearby-things ()
;; NOTE: May need to add bounes to this FCN
"Calculate the CONTEXT type items nearby the current point.
Assume that what we want to insert next is based on what is just
before point. If there is nothing, then assume it is whatever is
after point."
;; @todo - ADD BOUNDS TO THE PREV/NEXT TAG SEARCH
;; thus classdecl "near" stuff cannot be
;; outside the bounds of the type in question.
(let ((near (semantic-find-tag-by-overlay-prev))
(prot nil)
(ans nil))
(if (not near)
(setq near (semantic-find-tag-by-overlay-next)))
(when near
;; Calculate the type of thing we are near.
(if (not (semantic-tag-of-class-p near 'function))
(setq ans (cons (symbol-name (semantic-tag-class near)) ans))
;; if the symbol NEAR has a parent,
(let ((p (semantic-tag-function-parent near)))
(setq ans (cons (symbol-name (semantic-tag-class near)) ans))
(cond ((semantic-tag-p p)
(setq ans (cons (semantic-tag-name p) ans)))
((stringp p)
(setq ans (cons p ans)))
(t nil)))
;; Was it virtual?
(when (semantic-tag-get-attribute near :virtual)
(setq ans (cons "virtual" ans)))
;; Was it pure?
(when (semantic-tag-get-attribute near :pure-virtual-flag)
(setq ans (cons "pure" ans)))
)
;; Calculate the protection
(setq prot (semantic-tag-protection near))
(when (and prot (not (eq prot 'unknown)))
(setq ans (cons (symbol-name prot) ans)))
)
(nreverse ans)))
(defun srecode-calculate-context-font-lock ()
"Calculate an srecode context by using font-lock."
(let ((face (get-text-property (point) 'face))
)
(cond ((member face '(font-lock-string-face
font-lock-doc-face))
(list "string"))
((member face '(font-lock-comment-face
font-lock-comment-delimiter-face))
(list "comment"))
)
))
(defun srecode-calculate-context-default ()
"Generic method for calculating a context for srecode."
(if (= (point-min) (point-max))
(list "file" "empty")
(semantic-fetch-tags)
(let ((ct (semantic-find-tag-by-overlay))
)
(cond ((or (not ct)
;; Ok, below is a bit C specific.
(and (eq (semantic-tag-class (car ct)) 'type)
(string= (semantic-tag-type (car ct)) "namespace")))
(cons "declaration"
(or (srecode-calculate-context-font-lock)
(srecode-calculate-nearby-things)
))
)
((eq (semantic-tag-class (car ct)) 'function)
(cons "code" (srecode-calculate-context-font-lock))
)
((eq (semantic-tag-class (car ct)) 'type) ; We know not namespace
(cons "classdecl"
(or (srecode-calculate-context-font-lock)
(srecode-calculate-nearby-things)))
)
((and (car (cdr ct))
(eq (semantic-tag-class (car (cdr ct))) 'type))
(list "classdecl"
(symbol-name (semantic-tag-class (car ct))))
)
)
)))
;;; HANDLERS
;;
;; The calculated context is one thing, but more info is often available.
;; The context handlers can add info into the active dictionary that is
;; based on the context, such as a method parent name, protection scheme,
;; or other feature.
(defun srecode-semantic-handle-:ctxt (dict &optional template)
"Add macros into the dictionary DICT based on the current Emacs Lisp file.
Argument TEMPLATE is the template object adding context dictionary
entries.
This might add the following:
VIRTUAL - show a section if a function is virtual
PURE - show a section if a function is pure virtual.
PARENT - The name of a parent type for functions.
PROTECTION - Show a protection section, and what the protection is."
(require 'srecode/dictionary)
(when template
(let ((name (oref template object-name))
(cc (if (boundp 'srecode-insertion-start-context)
srecode-insertion-start-context))
;(context (oref template context))
)
; (when (and cc
; (null (string= (car cc) context))
; )
; ;; No current context, or the base is different, then
; ;; this is the section where we need to recalculate
; ;; the context based on user choice, if possible.
; ;;
; ;; The recalculation is complex, as there are many possibilities
; ;; that need to be divined. Set "cc" to the new context
; ;; at the end.
; ;;
; ;; @todo -
;
; )
;; The various context all have different features.
(let ((ct (nth 0 cc))
(it (nth 1 cc))
(last (last cc))
(parent nil)
)
(cond ((string= it "function")
(setq parent (nth 2 cc))
(when parent
(cond ((string= parent "virtual")
(srecode-dictionary-show-section dict "VIRTUAL")
(when (nth 3 cc)
(srecode-dictionary-show-section dict "PURE"))
)
(t
(srecode-dictionary-set-value dict "PARENT" parent))))
)
((and (string= it "type")
(or (string= name "function") (string= name "method")))
;; If we have a type, but we insert a fcn, then use that type
;; as the function parent.
(let ((near (semantic-find-tag-by-overlay-prev)))
(when (and near (semantic-tag-of-class-p near 'type))
(srecode-dictionary-set-value
dict "PARENT" (semantic-tag-name near))))
)
((string= ct "code")
;;(let ((analyzer (semantic-analyze-current-context)))
;; @todo - Use the analyze to setup things like local
;; variables we might use or something.
nil
;;)
)
(t
nil))
(when (member last '("public" "private" "protected"))
;; Hey, fancy that, we can do both.
(srecode-dictionary-set-value dict "PROTECTION" parent)
(srecode-dictionary-show-section dict "PROTECTION"))
))
))
(provide 'srecode/ctxt)
;;; srecode/ctxt.el ends here

565
lisp/cedet/srecode/dictionary.el Normal file
View file

@ -0,0 +1,565 @@
;;; srecode-dictionary.el --- Dictionary code for the semantic recoder.
;; 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:
;;
;; Dictionaries contain lists of names and their assocaited values.
;; These dictionaries are used to fill in macros from recoder templates.
;;; Code:
;;; CLASSES
(require 'eieio)
(require 'srecode)
(require 'srecode/table)
(eval-when-compile (require 'semantic))
(declare-function srecode-compile-parse-inserter "srecode/compile")
(declare-function srecode-dump-code-list "srecode/compile")
(declare-function srecode-load-tables-for-mode "srecode/find")
(declare-function srecode-insert-code-stream "srecode/insert")
(declare-function data-debug-new-buffer "data-debug")
(declare-function data-debug-insert-object-slots "eieio-datadebug")
(declare-function srecode-field "srecode/fields")
(defclass srecode-dictionary ()
((namehash :initarg :namehash
:documentation
"Hash table containing the names of all the templates.")
(buffer :initarg :buffer
:documentation
"The buffer this dictionary was initialized with.")
(parent :initarg :parent
:type (or null srecode-dictionary)
:documentation
"The parent dictionary.
Symbols not appearing in this dictionary will be checked against the
parent dictionary.")
(origin :initarg :origin
:type string
:documentation
"A string representing the origin of this dictionary.
Useful only while debugging.")
)
"Dictionary of symbols and what they mean.
Dictionaries are used to look up named symbols from
templates to decide what to do with those symbols.")
(defclass srecode-dictionary-compound-value ()
()
"A compound dictionary value.
Values stored in a dictionary must be a STRING,
a dictionary for showing sections, or an instance of a subclass
of this class.
Compound dictionary values derive from this class, and must
provide a sequence of method implementations to convert into
a string."
:abstract t)
(defclass srecode-dictionary-compound-variable
(srecode-dictionary-compound-value)
((value :initarg :value
:documentation
"The value of this template variable.
Variables in template files are usually a single string
which can be inserted into a dictionary directly.
Some variables may be more complex and involve dictionary
lookups, strings, concatenation, or the like.
The format of VALUE is determined by current template
formatting rules.")
(compiled :initarg :compiled
:type list
:documentation
"The compiled version of VALUE.")
)
"A compound dictionary value for template file variables.
You can declare a variable in a template like this:
set NAME \"str\" macro \"OTHERNAME\"
with appending various parts together in a list.")
(defmethod initialize-instance ((this srecode-dictionary-compound-variable)
&optional fields)
"Initialize the compound variable THIS.
Makes sure that :value is compiled."
(let ((newfields nil)
(state nil))
(while fields
;; Strip out :state
(if (eq (car fields) :state)
(setq state (car (cdr fields)))
(setq newfields (cons (car (cdr fields))
(cons (car fields) newfields))))
(setq fields (cdr (cdr fields))))
(when (not state)
(error "Cannot create compound variable without :state"))
(call-next-method this (nreverse newfields))
(when (not (slot-boundp this 'compiled))
(let ((val (oref this :value))
(comp nil))
(while val
(let ((nval (car val))
)
(cond ((stringp nval)
(setq comp (cons nval comp)))
((and (listp nval)
(equal (car nval) 'macro))
(require 'srecode/compile)
(setq comp (cons
(srecode-compile-parse-inserter
(cdr nval)
state)
comp)))
(t
(error "Don't know how to handle variable value %S" nval)))
)
(setq val (cdr val)))
(oset this :compiled (nreverse comp))))))
;;; DICTIONARY METHODS
;;
(defun srecode-create-dictionary (&optional buffer-or-parent)
"Create a dictionary for BUFFER.
If BUFFER-OR-PARENT is not specified, assume a buffer, and
use the current buffer.
If BUFFER-OR-PARENT is another dictionary, then remember the
parent within the new dictionary, and assume that BUFFER
is the same as belongs to the parent dictionary.
The dictionary is initialized with variables setup for that
buffer's table.
If BUFFER-OR-PARENT is t, then this dictionary should not be
assocated with a buffer or parent."
(save-excursion
(let ((parent nil)
(buffer nil)
(origin nil)
(initfrombuff nil))
(cond ((bufferp buffer-or-parent)
(set-buffer buffer-or-parent)
(setq buffer buffer-or-parent
origin (buffer-name buffer-or-parent)
initfrombuff t))
((srecode-dictionary-child-p buffer-or-parent)
(setq parent buffer-or-parent
buffer (oref buffer-or-parent buffer)
origin (concat (object-name buffer-or-parent) " in "
(if buffer (buffer-name buffer)
"no buffer")))
(when buffer
(set-buffer buffer)))
((eq buffer-or-parent t)
(setq buffer nil
origin "Unspecified Origin"))
(t
(setq buffer (current-buffer)
origin (concat "Unspecified. Assume "
(buffer-name buffer))
initfrombuff t)
)
)
(let ((dict (srecode-dictionary
major-mode
:buffer buffer
:parent parent
:namehash (make-hash-table :test 'equal
:size 20)
:origin origin)))
;; Only set up the default variables if we are being built
;; directroy for a particular buffer.
(when initfrombuff
;; Variables from the table we are inserting from.
;; @todo - get a better tree of tables.
(let ((mt (srecode-get-mode-table major-mode))
(def (srecode-get-mode-table 'default)))
;; Each table has multiple template tables.
;; Do DEF first so that MT can override any values.
(srecode-dictionary-add-template-table dict def)
(srecode-dictionary-add-template-table dict mt)
))
dict))))
(defmethod srecode-dictionary-add-template-table ((dict srecode-dictionary)
tpl)
"Insert into DICT the variables found in table TPL.
TPL is an object representing a compiled template file."
(when tpl
(let ((tabs (oref tpl :tables)))
(while tabs
(let ((vars (oref (car tabs) variables)))
(while vars
(srecode-dictionary-set-value
dict (car (car vars)) (cdr (car vars)))
(setq vars (cdr vars))))
(setq tabs (cdr tabs))))))
(defmethod srecode-dictionary-set-value ((dict srecode-dictionary)
name value)
"In dictionary DICT, set NAME to have VALUE."
;; Validate inputs
(if (not (stringp name))
(signal 'wrong-type-argument (list name 'stringp)))
;; Add the value.
(with-slots (namehash) dict
(puthash name value namehash))
)
(defmethod srecode-dictionary-add-section-dictionary ((dict srecode-dictionary)
name &optional show-only)
"In dictionary DICT, add a section dictionary for section macro NAME.
Return the new dictionary.
You can add several dictionaries to the same section macro.
For each dictionary added to a macro, the block of codes in the
template will be repeated.
If optional argument SHOW-ONLY is non-nil, then don't add a new dictionarly
if there is already one in place. Also, don't add FIRST/LAST entries.
These entries are not needed when we are just showing a section.
Each dictionary added will automatically get values for positional macros
which will enable SECTIONS to be enabled.
* FIRST - The first entry in the table.
* NOTFIRST - Not the first entry in the table.
* LAST - The last entry in the table
* NOTLAST - Not the last entry in the table.
Adding a new dictionary will alter these values in previously
inserted dictionaries."
;; Validate inputs
(if (not (stringp name))
(signal 'wrong-type-argument (list name 'stringp)))
(let ((new (srecode-create-dictionary dict))
(ov (srecode-dictionary-lookup-name dict name)))
(when (not show-only)
;; Setup the FIRST/NOTFIRST and LAST/NOTLAST entries.
(if (null ov)
(progn
(srecode-dictionary-show-section new "FIRST")
(srecode-dictionary-show-section new "LAST"))
;; Not the very first one. Lets clean up CAR.
(let ((tail (car (last ov))))
(srecode-dictionary-hide-section tail "LAST")
(srecode-dictionary-show-section tail "NOTLAST")
)
(srecode-dictionary-show-section new "NOTFIRST")
(srecode-dictionary-show-section new "LAST"))
)
(when (or (not show-only) (null ov))
(srecode-dictionary-set-value dict name (append ov (list new))))
;; Return the new sub-dictionary.
new))
(defmethod srecode-dictionary-show-section ((dict srecode-dictionary) name)
"In dictionary DICT, indicate that the section NAME should be exposed."
;; Validate inputs
(if (not (stringp name))
(signal 'wrong-type-argument (list name 'stringp)))
;; Showing a section is just like making a section dictionary, but
;; with no dictionary values to add.
(srecode-dictionary-add-section-dictionary dict name t)
nil)
(defmethod srecode-dictionary-hide-section ((dict srecode-dictionary) name)
"In dictionary DICT, indicate that the section NAME should be hidden."
;; We need to find the has value, and then delete it.
;; Validate inputs
(if (not (stringp name))
(signal 'wrong-type-argument (list name 'stringp)))
;; Add the value.
(with-slots (namehash) dict
(remhash name namehash))
nil)
(defmethod srecode-dictionary-merge ((dict srecode-dictionary) otherdict)
"Merge into DICT the dictionary entries from OTHERDICT."
(when otherdict
(maphash
(lambda (key entry)
;; Only merge in the new values if there was no old value.
;; This protects applications from being whacked, and basically
;; makes these new section dictionary entries act like
;; "defaults" instead of overrides.
(when (not (srecode-dictionary-lookup-name dict key))
(cond ((and (listp entry) (srecode-dictionary-p (car entry)))
;; A list of section dictionaries.
;; We need to merge them in.
(while entry
(let ((new-sub-dict
(srecode-dictionary-add-section-dictionary
dict key)))
(srecode-dictionary-merge new-sub-dict (car entry)))
(setq entry (cdr entry)))
)
(t
(srecode-dictionary-set-value dict key entry)))
))
(oref otherdict namehash))))
(defmethod srecode-dictionary-lookup-name ((dict srecode-dictionary)
name)
"Return information about the current DICT's value for NAME."
(if (not (slot-boundp dict 'namehash))
nil
;; Get the value of this name from the dictionary
(or (with-slots (namehash) dict
(gethash name namehash))
(and (not (member name '("FIRST" "LAST" "NOTFIRST" "NOTLAST")))
(oref dict parent)
(srecode-dictionary-lookup-name (oref dict parent) name))
)))
(defmethod srecode-root-dictionary ((dict srecode-dictionary))
"For dictionary DICT, return the root dictionary.
The root dictionary is usually for a current or active insertion."
(let ((ans dict))
(while (oref ans parent)
(setq ans (oref ans parent)))
ans))
;;; COMPOUND VALUE METHODS
;;
;; Compound values must provide at least the toStriong method
;; for use in converting the compound value into sometehing insertable.
(defmethod srecode-compound-toString ((cp srecode-dictionary-compound-value)
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. The FUNCTION could be a fraction
of some function symbol with a logical prefix excluded.
If you subclass `srecode-dictionary-compound-value' then this
method could return nil, but if it does that, it must insert
the value itself using `princ', or by detecting if the current
standard out is a buffer, and using `insert'."
(object-name cp))
(defmethod srecode-dump ((cp srecode-dictionary-compound-value)
&optional indent)
"Display information about this compound value."
(princ (object-name cp))
)
(defmethod srecode-compound-toString ((cp srecode-dictionary-compound-variable)
function
dictionary)
"Convert the compound dictionary variable value CP into a string.
FUNCTION and DICTIONARY are as for the baseclass."
(require 'srecode/insert)
(srecode-insert-code-stream (oref cp compiled) dictionary))
(defmethod srecode-dump ((cp srecode-dictionary-compound-variable)
&optional indent)
"Display information about this compound value."
(require 'srecode/compile)
(princ "# Compound Variable #\n")
(let ((indent (+ 4 (or indent 0)))
(cmp (oref cp compiled))
)
(srecode-dump-code-list cmp (make-string indent ? ))
))
;;; FIELD EDITING COMPOUND VALUE
;;
;; This is an interface to using field-editing objects
;; instead of asking questions. This provides the basics
;; behind this compound value.
(defclass srecode-field-value (srecode-dictionary-compound-value)
((firstinserter :initarg :firstinserter
:documentation
"The inserter object for the first occurance of this field.")
(defaultvalue :initarg :defaultvalue
:documentation
"The default value for this inserter.")
)
"When inserting values with editable field mode, a dictionary value.
Compound values allow a field to be stored in the dictionary for when
it is referenced a second time. This compound value can then be
inserted with a new editable field.")
(defmethod srecode-compound-toString((cp srecode-field-value)
function
dictionary)
"Convert this field into an insertable string."
(require 'srecode/fields)
;; If we are not in a buffer, then this is not supported.
(when (not (bufferp standard-output))
(error "FIELDS invoked while inserting template to non-buffer."))
(if function
(error "@todo: Cannot mix field insertion with functions.")
;; No function. Perform a plain field insertion.
;; We know we are in a buffer, so we can perform the insertion.
(let* ((dv (oref cp defaultvalue))
(sti (oref cp firstinserter))
(start (point))
(name (oref sti :object-name)))
(if (or (not dv) (string= dv ""))
(insert name)
(insert dv))
(srecode-field name :name name
:start start
:end (point)
:prompt (oref sti prompt)
:read-fcn (oref sti read-fcn)
)
))
;; Returning nil is a signal that we have done the insertion ourselves.
nil)
;;; Higher level dictionary functions
;;
(defun srecode-create-section-dictionary (sectiondicts STATE)
"Create a dictionary with section entries for a template.
The format for SECTIONDICTS is what is emitted from the template parsers.
STATE is the current compiler state."
(when sectiondicts
(let ((new (srecode-create-dictionary t)))
;; Loop over each section. The section is a macro w/in the
;; template.
(while sectiondicts
(let* ((sect (car (car sectiondicts)))
(entries (cdr (car sectiondicts)))
(subdict (srecode-dictionary-add-section-dictionary new sect))
)
;; Loop over each entry. This is one variable in the
;; section dictionary.
(while entries
(let ((tname (semantic-tag-name (car entries)))
(val (semantic-tag-variable-default (car entries))))
(if (eq val t)
(srecode-dictionary-show-section subdict tname)
(cond
((and (stringp (car val))
(= (length val) 1))
(setq val (car val)))
(t
(setq val (srecode-dictionary-compound-variable
tname :value val :state STATE))))
(srecode-dictionary-set-value
subdict tname val))
(setq entries (cdr entries))))
)
(setq sectiondicts (cdr sectiondicts)))
new)))
;;; DUMP DICTIONARY
;;
;; Make a dictionary, and dump it's contents.
(defun srecode-adebug-dictionary ()
"Run data-debug on this mode's dictionary."
(interactive)
(require 'eieio-datadebug)
(require 'semantic)
(require 'srecode/find)
(let* ((modesym major-mode)
(start (current-time))
(junk (or (progn (srecode-load-tables-for-mode modesym)
(srecode-get-mode-table modesym))
(error "No table found for mode %S" modesym)))
(dict (srecode-create-dictionary (current-buffer)))
(end (current-time))
)
(message "Creating a dictionary took %.2f seconds."
(semantic-elapsed-time start end))
(data-debug-new-buffer "*SRECODE ADEBUG*")
(data-debug-insert-object-slots dict "*")))
(defun srecode-dictionary-dump ()
"Dump a typical fabricated dictionary."
(interactive)
(require 'srecode/find)
(let ((modesym major-mode))
;; This load allows the dictionary access to inherited
;; and stacked dictionary entries.
(srecode-load-tables-for-mode modesym)
(let ((tmp (srecode-get-mode-table modesym))
)
(if (not tmp)
(error "No table found for mode %S" modesym))
;; Now make the dictionary.
(let ((dict (srecode-create-dictionary (current-buffer))))
(with-output-to-temp-buffer "*SRECODE DUMP*"
(princ "DICTIONARY FOR ")
(princ major-mode)
(princ "\n--------------------------------------------\n")
(srecode-dump dict))
))))
(defmethod srecode-dump ((dict srecode-dictionary) &optional indent)
"Dump a dictionary."
(if (not indent) (setq indent 0))
(maphash (lambda (key entry)
(princ (make-string indent ? ))
(princ " ")
(princ key)
(princ " ")
(cond ((and (listp entry)
(srecode-dictionary-p (car entry)))
(let ((newindent (if indent
(+ indent 4)
4)))
(while entry
(princ " --> SUBDICTIONARY ")
(princ (object-name dict))
(princ "\n")
(srecode-dump (car entry) newindent)
(setq entry (cdr entry))
))
(princ "\n")
)
((srecode-dictionary-compound-value-child-p entry)
(srecode-dump entry indent)
(princ "\n")
)
(t
(prin1 entry)
;(princ "\n")
))
(terpri)
)
(oref dict namehash))
)
(provide 'srecode/dictionary)
;;; srecode/dictionary.el ends here

841
lisp/cedet/srecode/document.el Normal file
View file

@ -0,0 +1,841 @@
;;; srecode/document.el --- Documentation (comment) generation
;; Copyright (C) 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:
;;
;; Routines for fabricating human readable text from function and
;; variable names as base-text for function comments. Document is not
;; meant to generate end-text for any function. It is merely meant to
;; provide some useful base words and text, and as a framework for
;; managing comments.
;;
;;; Origins:
;;
;; Document was first written w/ cparse, a custom regexp based c parser.
;;
;; Document was then ported to cedet/semantic using sformat (super
;; format) as the templating engine.
;;
;; Document has now been ported to srecode, using the semantic recoder
;; as the templating engine.
;; This file combines srecode-document.el and srecode-document-vars.el
;; from the CEDET repository.
(require 'srecode/args)
(require 'srecode/dictionary)
(require 'srecode/extract)
(require 'srecode/insert)
(require 'srecode/semantic)
(require 'semantic)
(require 'semantic/tag)
(require 'semantic/doc)
(require 'pulse)
;;; Code:
(defgroup document nil
"File and tag browser frame."
:group 'texinfo
:group 'srecode)
(defcustom srecode-document-autocomment-common-nouns-abbrevs
'(
("sock\\(et\\)?" . "socket")
("addr\\(ess\\)?" . "address")
("buf\\(f\\(er\\)?\\)?" . "buffer")
("cur\\(r\\(ent\\)?\\)?" . "current")
("dev\\(ice\\)?" . "device")
("doc" . "document")
("i18n" . "internationalization")
("file" . "file")
("line" . "line")
("l10n" . "localization")
("msg\\|message" . "message")
("name" . "name")
("next\\|nxt" . "next")
("num\\(ber\\)?" . "number")
("port" . "port")
("host" . "host")
("obj\\|object" . "object")
("previous\\|prev" . "previous")
("str\\(ing\\)?" . "string")
("use?r" . "user")
("\\(^\\|\\s-\\)id\\($\\|\\s-\\)" . "Identifier") ;complex cause ;common syllable
)
"List of common English abbreviations or full words.
These are nouns (as opposed to verbs) for use in creating expanded
versions of names.This is an alist with each element of the form:
(MATCH . RESULT)
MATCH is a regexp to match in the type field.
RESULT is a string."
:group 'document
:type '(repeat (cons (string :tag "Regexp")
(string :tag "Doc Text"))))
(defcustom srecode-document-autocomment-function-alist
'(
("abort" . "Aborts the")
;; trick to get re-alloc and alloc to pair into one sentence.
("realloc" . "moves or ")
("alloc\\(ate\\)?" . "Allocates and initializes a new ")
("clean" . "Cleans up the")
("clobber" . "Removes")
("close" . "Cleanly closes")
("check" . "Checks the")
("comp\\(are\\)?" . "Compares the")
("create" . "Creates a new ")
("find" . "Finds ")
("free" . "Frees up space")
("gen\\(erate\\)?" . "Generates a new ")
("get\\|find" . "Looks for the given ")
("gobble" . "Removes")
("he?lp" . "Provides help for")
("li?ste?n" . "Listens for ")
("connect" . "Connects to ")
("acc?e?pt" . "Accepts a ")
("load" . "Loads in ")
("match" . "Check that parameters match")
("name" . "Provides a name which ")
("new" . "Allocates a ")
("parse" . "Parses the parameters and returns ")
("print\\|display" . "Prints out")
("read" . "Reads from")
("reset" . "Resets the parameters and returns")
("scan" . "Scans the ")
("setup\\|init\\(iallize\\)?" . "Initializes the ")
("select" . "Chooses the ")
("send" . "Sends a")
("re?c\\(v\\|ieves?\\)" . "Receives a ")
("to" . "Converts ")
("update" . "Updates the ")
("wait" . "Waits for ")
("write" . "Writes to")
)
"List of names to string match against the function name.
This is an alist with each element of the form:
(MATCH . RESULT)
MATCH is a regexp to match in the type field.
RESULT is a string.
Certain prefixes may always mean the same thing, and the same comment
can be used as a beginning for the description. Regexp should be
lower case since the string they are compared to is downcased.
A string may end in a space, in which case, last-alist is searched to
see how best to describe what can be returned.
Doesn't always work correctly, but that is just because English
doesn't always work correctly."
:group 'document
:type '(repeat (cons (string :tag "Regexp")
(string :tag "Doc Text"))))
(defcustom srecode-document-autocomment-common-nouns-abbrevs
'(
("sock\\(et\\)?" . "socket")
("addr\\(ess\\)?" . "address")
("buf\\(f\\(er\\)?\\)?" . "buffer")
("cur\\(r\\(ent\\)?\\)?" . "current")
("dev\\(ice\\)?" . "device")
("file" . "file")
("line" . "line")
("msg\\|message" . "message")
("name" . "name")
("next\\|nxt" . "next")
("port" . "port")
("host" . "host")
("obj\\|object" . "object")
("previous\\|prev" . "previous")
("str\\(ing\\)?" . "string")
("use?r" . "user")
("num\\(ber\\)?" . "number")
("\\(^\\|\\s-\\)id\\($\\|\\s-\\)" . "Identifier") ;complex cause ;commen sylable
)
"List of common English abbreviations or full words.
These are nouns (as opposed to verbs) for use in creating expanded
versions of names.This is an alist with each element of the form:
(MATCH . RESULT)
MATCH is a regexp to match in the type field.
RESULT is a string."
:group 'document
:type '(repeat (cons (string :tag "Regexp")
(string :tag "Doc Text"))))
(defcustom srecode-document-autocomment-return-first-alist
'(
;; Static must be first in the list to provide the intro to the sentence
("static" . "Locally defined function which ")
("Bool\\|BOOL" . "Status of ")
)
"List of regexp matches for types.
They provide a little bit of text when typing information is
described.
This is an alist with each element of the form:
(MATCH . RESULT)
MATCH is a regexp to match in the type field.
RESULT is a string."
:group 'document
:type '(repeat (cons (string :tag "Regexp")
(string :tag "Doc Text"))))
(defcustom srecode-document-autocomment-return-last-alist
'(
("static[ \t\n]+struct \\([a-zA-Z0-9_]+\\)" . "%s")
("struct \\([a-zA-Z0-9_]+\\)" . "%s")
("static[ \t\n]+union \\([a-zA-Z0-9_]+\\)" . "%s")
("union \\([a-zA-Z0-9_]+\\)" . "%s")
("static[ \t\n]+enum \\([a-zA-Z0-9_]+\\)" . "%s")
("enum \\([a-zA-Z0-9_]+\\)" . "%s")
("static[ \t\n]+\\([a-zA-Z0-9_]+\\)" . "%s")
("\\([a-zA-Z0-9_]+\\)" . "of type %s")
)
"List of regexps which provide the type of the return value.
This is an alist with each element of the form:
(MATCH . RESULT)
MATCH is a regexp to match in the type field.
RESULT is a string, which can contain %s, whih is replaced with
`match-string' 1."
:group 'document
:type '(repeat (cons (string :tag "Regexp")
(string :tag "Doc Text"))))
(defcustom srecode-document-autocomment-param-alist
'( ("[Cc]txt" . "Context")
("[Ii]d" . "Identifier of")
("[Tt]ype" . "Type of")
("[Nn]ame" . "Name of")
("argc" . "Number of arguments")
("argv" . "Argument vector")
("envp" . "Environment variable vector")
)
"Alist of common variable names appearing as function parameters.
This is an alist with each element of the form:
(MATCH . RESULT)
MATCH is a regexp to match in the type field.
RESULT is a string of text to use to describe MATCH.
When one is encountered, document-insert-parameters will automatically
place this comment after the parameter name."
:group 'document
:type '(repeat (cons (string :tag "Regexp")
(string :tag "Doc Text"))))
(defcustom srecode-document-autocomment-param-type-alist
'(("const" . "Constant")
("void" . "Empty")
("char[ ]*\\*" . "String ")
("\\*\\*" . "Pointer to ")
("\\*" . "Pointer ")
("char[ ]*\\([^ \t*]\\|$\\)" . "Character")
("int\\|long" . "Number of")
("FILE" . "File of")
("float\\|double" . "Value of")
;; How about some X things?
("Bool\\|BOOL" . "Flag")
("Window" . "Window")
("GC" . "Graphic Context")
("Widget" . "Widget")
)
"Alist of input parameter types and strings desribing them.
This is an alist with each element of the form:
(MATCH . RESULT)
MATCH is a regexp to match in the type field.
RESULT is a string."
:group 'document
:type '(repeat (cons (string :tag "Regexp")
(string :tag "Doc Text"))))
;;;###autoload
(defun srecode-document-insert-comment ()
"Insert some comments.
Whack any comments that may be in the way and replace them.
If the region is active, then insert group function comments.
If the cursor is in a comment, figure out what kind of comment it is
and replace it.
If the cursor is in a function, insert a function comment.
If the cursor is on a one line prototype, then insert post-fcn comments."
(interactive)
(semantic-fetch-tags)
(let ((ctxt (srecode-calculate-context)))
(if ;; Active region stuff.
(or srecode-handle-region-when-non-active-flag
(eq last-command 'mouse-drag-region)
(and transient-mark-mode mark-active))
(if (> (point) (mark))
(srecode-document-insert-group-comments (mark) (point))
(srecode-document-insert-group-comments (point) (mark)))
;; ELSE
;; A declaration comment. Find what it documents.
(when (equal ctxt '("declaration" "comment"))
;; If we are on a one line tag/comment, go to that fcn.
(if (save-excursion (back-to-indentation)
(semantic-current-tag))
(back-to-indentation)
;; Else, do we have a fcn following us?
(let ((tag (semantic-find-tag-by-overlay-next)))
(when tag (semantic-go-to-tag tag))))
)
;; Now analyze the tag we may be on.
(if (semantic-current-tag)
(cond
;; A one-line variable
((and (semantic-tag-of-class-p (semantic-current-tag) 'variable)
(srecode-document-one-line-tag-p (semantic-current-tag)))
(srecode-document-insert-variable-one-line-comment))
;; A plain function
((semantic-tag-of-class-p (semantic-current-tag) 'function)
(srecode-document-insert-function-comment))
;; Don't know.
(t
(error "Not sure what to comment"))
)
;; ELSE, no tag. Perhaps we should just insert a nice section
;; header??
(let ((title (read-string "Section Title (RET to skip): ")))
(when (and (stringp title) (not (= (length title) 0)))
(srecode-document-insert-section-comment title)))
))))
(defun srecode-document-insert-section-comment (&optional title)
"Insert a section comment with TITLE."
(interactive "sSection Title: ")
(srecode-load-tables-for-mode major-mode)
(srecode-load-tables-for-mode major-mode 'document)
(if (not (srecode-table))
(error "No template table found for mode %s" major-mode))
(let* ((dict (srecode-create-dictionary))
(temp (srecode-template-get-table (srecode-table)
"section-comment"
"declaration"
'document)))
(if (not temp)
(error "No templates for inserting section comments"))
(when title
(srecode-dictionary-set-value
dict "TITLE" title))
(srecode-insert-fcn temp dict)
))
(defun srecode-document-trim-whitespace (str)
"Strip stray whitespace from around STR."
(when (string-match "^\\(\\s-\\|\n\\)+" str)
(setq str (replace-match "" t t str)))
(when (string-match "\\(\\s-\\|\n\\)+$" str)
(setq str (replace-match "" t t str)))
str)
;;;###autoload
(defun srecode-document-insert-function-comment (&optional fcn-in)
"Insert or replace a function comment.
FCN-IN is the Semantic tag of the function to add a comment too.
If FCN-IN is not provied, the current tag is used instead.
It is assumed that the comment occurs just in front of FCN-IN."
(interactive)
(srecode-load-tables-for-mode major-mode)
(srecode-load-tables-for-mode major-mode 'document)
(if (not (srecode-table))
(error "No template table found for mode %s" major-mode))
(let* ((dict (srecode-create-dictionary))
(temp (srecode-template-get-table (srecode-table)
"function-comment"
"declaration"
'document)))
(if (not temp)
(error "No templates for inserting function comments"))
;; Try to figure out the tag we want to use.
(when (not fcn-in)
(semantic-fetch-tags)
(setq fcn-in (semantic-current-tag)))
(when (or (not fcn-in)
(not (semantic-tag-of-class-p fcn-in 'function)))
(error "No tag of class 'function to insert comment for"))
(if (not (eq (current-buffer) (semantic-tag-buffer fcn-in)))
(error "Only insert comments for tags in the current buffer"))
;; Find any existing doc strings.
(semantic-go-to-tag fcn-in)
(beginning-of-line)
(forward-char -1)
(let ((lextok (semantic-documentation-comment-preceeding-tag fcn-in 'lex))
(doctext
(srecode-document-function-name-comment fcn-in))
)
(when lextok
(let* ((s (semantic-lex-token-start lextok))
(e (semantic-lex-token-end lextok))
(plaintext
(srecode-document-trim-whitespace
(save-excursion
(goto-char s)
(semantic-doc-snarf-comment-for-tag nil))))
(extract (condition-case nil
(srecode-extract temp s e)
(error nil))
)
(distance (count-lines e (semantic-tag-start fcn-in)))
(belongelsewhere (save-excursion
(goto-char s)
(back-to-indentation)
(semantic-current-tag)))
)
(when (not belongelsewhere)
(pulse-momentary-highlight-region s e)
;; There are many possible states that comment could be in.
;; Take a guess about what the user would like to do, and ask
;; the right kind of question.
(when (or (not (> distance 2))
(y-or-n-p "Replace this comment? "))
(when (> distance 2)
(goto-char e)
(delete-horizontal-space)
(delete-blank-lines))
(cond
((and plaintext (not extract))
(if (y-or-n-p "Convert old-style comment to Template with old text? ")
(setq doctext plaintext))
(delete-region s e)
(goto-char s))
(extract
(when (y-or-n-p "Refresh pre-existing comment (recycle old doc)? ")
(delete-region s e)
(goto-char s)
(setq doctext
(srecode-document-trim-whitespace
(srecode-dictionary-lookup-name extract "DOC")))))
))
)))
(beginning-of-line)
;; Perform the insertion
(let ((srecode-semantic-selected-tag fcn-in)
(srecode-semantic-apply-tag-augment-hook
(lambda (tag dict)
(srecode-dictionary-set-value
dict "DOC"
(if (eq tag fcn-in)
doctext
(srecode-document-parameter-comment tag))
)))
)
(srecode-insert-fcn temp dict)
))
))
;;;###autoload
(defun srecode-document-insert-variable-one-line-comment (&optional var-in)
"Insert or replace a variable comment.
VAR-IN is the Semantic tag of the function to add a comment too.
If VAR-IN is not provied, the current tag is used instead.
It is assumed that the comment occurs just after VAR-IN."
(interactive)
(srecode-load-tables-for-mode major-mode)
(srecode-load-tables-for-mode major-mode 'document)
(if (not (srecode-table))
(error "No template table found for mode %s" major-mode))
(let* ((dict (srecode-create-dictionary))
(temp (srecode-template-get-table (srecode-table)
"variable-same-line-comment"
"declaration"
'document)))
(if (not temp)
(error "No templates for inserting variable comments"))
;; Try to figure out the tag we want to use.
(when (not var-in)
(semantic-fetch-tags)
(setq var-in (semantic-current-tag)))
(when (or (not var-in)
(not (semantic-tag-of-class-p var-in 'variable)))
(error "No tag of class 'variable to insert comment for"))
(if (not (eq (current-buffer) (semantic-tag-buffer var-in)))
(error "Only insert comments for tags in the current buffer"))
;; Find any existing doc strings.
(goto-char (semantic-tag-end var-in))
(skip-syntax-forward "-" (point-at-eol))
(let ((lextok (semantic-doc-snarf-comment-for-tag 'lex))
)
(when lextok
(let ((s (semantic-lex-token-start lextok))
(e (semantic-lex-token-end lextok)))
(pulse-momentary-highlight-region s e)
(when (not (y-or-n-p "A comment already exists. Replace? "))
(error "Quit"))
;; Extract text from the existing comment.
(srecode-extract temp s e)
(delete-region s e)
(goto-char s) ;; To avoid adding a CR.
))
)
;; Clean up the end of the line and use handy comment-column.
(end-of-line)
(delete-horizontal-space)
(move-to-column comment-column t)
(when (< (point) (point-at-eol)) (end-of-line))
;; Perform the insertion
(let ((srecode-semantic-selected-tag var-in)
(srecode-semantic-apply-tag-augment-hook
(lambda (tag dict)
(srecode-dictionary-set-value
dict "DOC" (srecode-document-parameter-comment
tag))))
)
(srecode-insert-fcn temp dict)
))
)
;;;###autoload
(defun srecode-document-insert-group-comments (beg end)
"Insert group comments around the active between BEG and END.
If the region includes only parts of some tags, expand out
to the beginning and end of the tags on the region.
If there is only one tag in the region, complain."
(interactive "r")
(srecode-load-tables-for-mode major-mode)
(srecode-load-tables-for-mode major-mode 'document)
(if (not (srecode-table))
(error "No template table found for mode %s" major-mode))
(let* ((dict (srecode-create-dictionary))
(context "declaration")
(temp-start nil)
(temp-end nil)
(tag-start (save-excursion
(goto-char beg)
(or (semantic-current-tag)
(semantic-find-tag-by-overlay-next))))
(tag-end (save-excursion
(goto-char end)
(or (semantic-current-tag)
(semantic-find-tag-by-overlay-prev))))
(parent-tag nil)
(first-pos beg)
(second-pos end)
)
;; If beg/end wrapped nothing, then tag-start,end would actually
;; point at some odd stuff that is out of order.
(when (or (not tag-start) (not tag-end)
(> (semantic-tag-end tag-start)
(semantic-tag-start tag-end)))
(setq tag-start nil
tag-end nil))
(when tag-start
;; If tag-start and -end are the same, and it is a class or
;; struct, try to find child tags inside the classdecl.
(cond
((and (eq tag-start tag-end)
tag-start
(semantic-tag-of-class-p tag-start 'type))
(setq parent-tag tag-start)
(setq tag-start (semantic-find-tag-by-overlay-next beg)
tag-end (semantic-find-tag-by-overlay-prev end))
)
((eq (semantic-find-tag-parent-by-overlay tag-start) tag-end)
(setq parent-tag tag-end)
(setq tag-end (semantic-find-tag-by-overlay-prev end))
)
((eq tag-start (semantic-find-tag-parent-by-overlay tag-end))
(setq parent-tag tag-start)
(setq tag-start (semantic-find-tag-by-overlay-next beg))
)
)
(when parent-tag
;; We are probably in a classdecl
;; @todo -could I really use (srecode-calculate-context) ?
(setq context "classdecl")
)
;; Derive start and end locations based on the tags.
(setq first-pos (semantic-tag-start tag-start)
second-pos (semantic-tag-end tag-end))
)
;; Now load the templates
(setq temp-start (srecode-template-get-table (srecode-table)
"group-comment-start"
context
'document)
temp-end (srecode-template-get-table (srecode-table)
"group-comment-end"
context
'document))
(when (or (not temp-start) (not temp-end))
(error "No templates for inserting group comments"))
;; Setup the name of this group ahead of time.
;; @todo - guess at a name based on common strings
;; of the tags in the group.
(srecode-dictionary-set-value
dict "GROUPNAME"
(read-string "Name of group: "))
;; Perform the insertion
;; Do the end first so we don't need to recalculate anything.
;;
(goto-char second-pos)
(end-of-line)
(srecode-insert-fcn temp-end dict)
(goto-char first-pos)
(beginning-of-line)
(srecode-insert-fcn temp-start dict)
))
;;; Document Generation Functions
;;
;; Routines for making up English style comments.
(defun srecode-document-function-name-comment (tag)
"Create documentation for the function defined in TAG.
If we can identify a verb in the list followed by some
name part then check the return value to see if we can use that to
finish off the sentence. ie. any function with 'alloc' in it will be
allocating something based on its type."
(let ((al srecode-document-autocomment-return-first-alist)
(dropit nil)
(tailit nil)
(news "")
(fname (semantic-tag-name tag))
(retval (or (semantic-tag-type tag) "")))
(if (listp retval)
;; convert a type list into a long string to analyze.
(setq retval (car retval)))
;; check for modifiers like static
(while al
(if (string-match (car (car al)) (downcase retval))
(progn
(setq news (concat news (cdr (car al))))
(setq dropit t)
(setq al nil)))
(setq al (cdr al)))
;; check for verb parts!
(setq al srecode-document-autocomment-function-alist)
(while al
(if (string-match (car (car al)) (downcase fname))
(progn
(setq news
(concat news (if dropit (downcase (cdr (car al)))
(cdr (car al)))))
;; if we end in a space, then we are expecting a potential
;; return value.
(if (= ? (aref news (1- (length news))))
(setq tailit t))
(setq al nil)))
(setq al (cdr al)))
;; check for noun parts!
(setq al srecode-document-autocomment-common-nouns-abbrevs)
(while al
(if (string-match (car (car al)) (downcase fname))
(progn
(setq news
(concat news (if dropit (downcase (cdr (car al)))
(cdr (car al)))))
(setq al nil)))
(setq al (cdr al)))
;; add tailers to names which are obviously returning something.
(if tailit
(progn
(setq al srecode-document-autocomment-return-last-alist)
(while al
(if (string-match (car (car al)) (downcase retval))
(progn
(setq news
(concat news " "
;; this one may use parts of the return value.
(format (cdr (car al))
(srecode-document-programmer->english
(substring retval (match-beginning 1)
(match-end 1))))))
(setq al nil)))
(setq al (cdr al)))))
news))
(defun srecode-document-parameter-comment (param &optional commentlist)
"Convert tag or string PARAM into a name,comment pair.
Optional COMMENTLIST is list of previously existing comments to
use instead in alist form. If the name doesn't appear in the list of
standard names, then englishify it instead."
(let ((cmt "")
(aso srecode-document-autocomment-param-alist)
(fnd nil)
(name (if (stringp param) param (semantic-tag-name param)))
(tt (if (stringp param) nil (semantic-tag-type param))))
;; Make sure the type is a string.
(if (listp tt)
(setq tt (semantic-tag-name tt)))
;; Find name description parts.
(while aso
(if (string-match (car (car aso)) name)
(progn
(setq fnd t)
(setq cmt (concat cmt (cdr (car aso))))))
(setq aso (cdr aso)))
(if (/= (length cmt) 0)
nil
;; finally check for array parts
(if (and (not (stringp param)) (semantic-tag-modifiers param))
(setq cmt (concat cmt "array of ")))
(setq aso srecode-document-autocomment-param-type-alist)
(while (and aso tt)
(if (string-match (car (car aso)) tt)
(setq cmt (concat cmt (cdr (car aso)))))
(setq aso (cdr aso))))
;; Convert from programmer to english.
(if (not fnd)
(setq cmt (concat cmt " "
(srecode-document-programmer->english name))))
cmt))
(defun srecode-document-programmer->english (programmer)
"Take PROGRAMMER and convert it into English.
Works with the following rules:
1) convert all _ into spaces.
2) inserts spaces between CamelCasing word breaks.
3) expands noun names based on common programmer nouns.
This function is designed for variables, not functions. This does
not account for verb parts."
(if (string= "" programmer)
""
(let ((ind 0) ;index in string
(llow nil) ;lower/upper case flag
(newstr nil) ;new string being generated
(al nil)) ;autocomment list
;;
;; 1) Convert underscores
;;
(while (< ind (length programmer))
(setq newstr (concat newstr
(if (= (aref programmer ind) ?_)
" " (char-to-string (aref programmer ind)))))
(setq ind (1+ ind)))
(setq programmer newstr
newstr nil
ind 0)
;;
;; 2) Find word breaks between case changes
;;
(while (< ind (length programmer))
(setq newstr
(concat newstr
(let ((tc (aref programmer ind)))
(if (and (>= tc ?a) (<= tc ?z))
(progn
(setq llow t)
(char-to-string tc))
(if llow
(progn
(setq llow nil)
(concat " " (char-to-string tc)))
(char-to-string tc))))))
(setq ind (1+ ind)))
;;
;; 3) Expand the words if possible
;;
(setq llow nil
ind 0
programmer newstr
newstr nil)
(while (string-match (concat "^\\s-*\\([^ \t\n]+\\)") programmer)
(let ((ts (substring programmer (match-beginning 1) (match-end 1)))
(end (match-end 1)))
(setq al srecode-document-autocomment-common-nouns-abbrevs)
(setq llow nil)
(while al
(if (string-match (car (car al)) (downcase ts))
(progn
(setq newstr (concat newstr (cdr (car al))))
;; don't terminate because we may actuall have 2 words
;; next to eachother we didn't identify before
(setq llow t)))
(setq al (cdr al)))
(if (not llow) (setq newstr (concat newstr ts)))
(setq newstr (concat newstr " "))
(setq programmer (substring programmer end))))
newstr)))
;;; UTILS
;;
(defun srecode-document-one-line-tag-p (tag)
"Does TAG fit on one line with space on the end?"
(save-excursion
(semantic-go-to-tag tag)
(and (<= (semantic-tag-end tag) (point-at-eol))
(goto-char (semantic-tag-end tag))
(< (current-column) 70))))
(provide 'srecode/document)
;; Local variables:
;; generated-autoload-file: "loaddefs.el"
;; generated-autoload-feature: srecode/loaddefs
;; generated-autoload-load-name: "srecode/document"
;; End:
;;; srecode/document.el ends here

113
lisp/cedet/srecode/el.el Normal file
View file

@ -0,0 +1,113 @@
;;; srecode/el.el --- Emacs Lisp specific arguments
;; Copyright (C) 2008 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:
;;
;; Emacs Lisp specific handlers. To use these handlers in your
;; template, add the :name part to your template argument list.
;;
;; Error if not in a Emacs Lisp mode
;;; Code:
(require 'srecode)
(require 'srecode/semantic)
(declare-function semanticdb-brute-find-tags-by-class "semantic/db-find")
;;;###autoload
(defun srecode-semantic-handle-:el (dict)
"Add macros into the dictionary DICT based on the current Emacs Lisp file.
Adds the following:
PRENAME - The common name prefix of this file."
(let* ((names (append (semantic-find-tags-by-class 'function (current-buffer))
(semantic-find-tags-by-class 'variable (current-buffer)))
)
(common (try-completion "" names)))
(srecode-dictionary-set-value dict "PRENAME" common)
))
;;;###autoload
(defun srecode-semantic-handle-:el-custom (dict)
"Add macros into the dictionary DICT based on the current Emacs Lisp file.
Adds the following:
GROUP - The 'defgroup' name we guess you want for variables.
FACEGROUP - The `defgroup' name you might want for faces."
(require 'semantic/db-find)
(let ((groups (semanticdb-strip-find-results
(semanticdb-brute-find-tags-by-class 'customgroup)))
(varg nil)
(faceg nil)
)
;; Pick the best group
(while groups
(cond ((string-match "face" (semantic-tag-name (car groups)))
(setq faceg (car groups)))
((not varg)
(setq varg (car groups)))
(t
;; What about other groups?
))
(setq groups (cdr groups)))
;; Double check the facegroup.
(setq faceg (or faceg varg))
;; Setup some variables
(srecode-dictionary-set-value dict "GROUP" (semantic-tag-name varg))
(srecode-dictionary-set-value dict "FACEGROUP" (semantic-tag-name faceg))
))
(define-mode-local-override srecode-semantic-apply-tag-to-dict
emacs-lisp-mode (tagobj dict)
"Apply Emacs Lisp specific features from TAGOBJ into DICT.
Calls `srecode-semantic-apply-tag-to-dict-default' first."
(srecode-semantic-apply-tag-to-dict-default tagobj dict)
;; Pull out the tag for the individual pieces.
(let* ((tag (oref tagobj :prime))
(doc (semantic-tag-docstring tag)))
;; It is much more common to have doc on ELisp.
(srecode-dictionary-set-value dict "DOC" doc)
(cond
;;
;; FUNCTION
;;
((eq (semantic-tag-class tag) 'function)
(if (semantic-tag-get-attribute tag :user-visible-flag)
(srecode-dictionary-set-value dict "INTERACTIVE" " (interactive)\n ")
(srecode-dictionary-set-value dict "INTERACTIVE" ""))))))
(provide 'srecode/el)
;; Local variables:
;; generated-autoload-file: "loaddefs.el"
;; generated-autoload-feature: srecode/loaddefs
;; generated-autoload-load-name: "srecode/el"
;; End:
;;; srecode/el.el ends here

132
lisp/cedet/srecode/expandproto.el Normal file
View file

@ -0,0 +1,132 @@
;;; srecode/expandproto.el --- Expanding prototypes.
;; Copyright (C) 2007 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:
;;
;; Methods for expanding a prototype into an implementation.
(require 'ring)
(require 'semantic)
(require 'semantic/analyze)
(require 'srecode/insert)
(require 'srecode/dictionary)
(declare-function semantic-brute-find-tag-by-attribute-value "semantic/find")
;;; Code:
(defcustom srecode-expandproto-template-file-alist
'( ( c++-mode . "srecode-expandproto-cpp.srt" )
)
;; @todo - Make this variable auto-generated from the Makefile.
"Associate template files for expanding prototypes to a major mode."
:group 'srecode
:type '(repeat (cons (sexp :tag "Mode")
(sexp :tag "Filename"))
))
;;;###autoload
(defun srecode-insert-prototype-expansion ()
"Insert get/set methods for the current class."
(interactive)
(srecode-load-tables-for-mode major-mode)
(srecode-load-tables-for-mode major-mode
srecode-expandproto-template-file-alist)
(if (not (srecode-table))
(error "No template table found for mode %s" major-mode))
(let ((proto
;; Step 1: Find the prototype, or prototype list to expand.
(srecode-find-prototype-for-expansion)))
(if (not proto)
(error "Could not find prototype to expand"))
;; Step 2: Insert implementations of the prototypes.
))
(defun srecode-find-prototype-for-expansion ()
"Find a prototype to use for expanding into an implementation."
;; We may find a prototype tag in one of several places.
;; Search in order of logical priority.
(let ((proto nil)
)
;; 1) A class full of prototypes under point.
(let ((tag (semantic-current-tag)))
(when tag
(when (not (semantic-tag-of-class-p tag 'type))
(setq tag (semantic-current-tag-parent))))
(when (and tag (semantic-tag-of-class-p tag 'type))
;; If the current class has prototype members, then
;; we will do the whole class!
(require 'semantic/find)
(if (semantic-brute-find-tag-by-attribute-value
:prototype t
(semantic-tag-type-members tag))
(setq proto tag)))
)
;; 2) A prototype under point.
(when (not proto)
(let ((tag (semantic-current-tag)))
(when (and tag
(and
(semantic-tag-of-class-p tag 'function)
(semantic-tag-get-attribute tag :prototype)))
(setq proto tag))))
;; 3) A tag in the kill ring that is a prototype
(when (not proto)
(if (ring-empty-p senator-tag-ring)
nil ;; Not for us.
(let ((tag (ring-ref senator-tag-ring 0))
)
(when
(and tag
(or
(and
(semantic-tag-of-class-p tag 'function)
(semantic-tag-get-attribute tag :prototype))
(and
(semantic-tag-of-class-p tag 'type)
(require 'semantic/find)
(semantic-brute-find-tag-by-attribute-value
:prototype t
(semantic-tag-type-members tag))))
)
(setq proto tag))
)))
proto))
(provide 'srecode-expandproto)
;; Local variables:
;; generated-autoload-file: "loaddefs.el"
;; generated-autoload-feature: srecode/loaddefs
;; generated-autoload-load-name: "srecode/expandproto"
;; End:
;;; srecode/expandproto.el ends here

242
lisp/cedet/srecode/extract.el Normal file
View file

@ -0,0 +1,242 @@
;;; srecode/extract.el --- Extract content from previously inserted macro.
;; Copyright (C) 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:
;;
;; Extract content from a previously inserted macro.
;;
;; The extraction routines can be handy if you want to extract users
;; added text from the middle of a template inserted block of text.
;; This code will not work for all templates. It will only work for
;; templates with unique static text between all the different insert
;; macros.
;;
;; That said, it will handle include and section templates, so complex
;; or deep template calls can be extracted.
;;
;; This code was specifically written for srecode-document, which
;; wants to extract user written text, and re-use it in a reformatted
;; comment.
(require 'srecode)
(require 'srecode/compile)
(require 'srecode/insert)
;;; Code:
(defclass srecode-extract-state ()
((anchor :initform nil
:documentation
"The last known plain-text end location.")
(lastinserter :initform nil
:documentation
"The last inserter with 'later extraction type.")
(lastdict :initform nil
:documentation
"The dictionary associated with lastinserter.")
)
"The current extraction state.")
(defmethod srecode-extract-state-set ((st srecode-extract-state) ins dict)
"Set onto the extract state ST a new inserter INS and dictinary DICT."
(oset st lastinserter ins)
(oset st lastdict dict))
(defmethod srecode-extract-state-set-anchor ((st srecode-extract-state))
"Reset the achor point on extract state ST."
(oset st anchor (point)))
(defmethod srecode-extract-state-extract ((st srecode-extract-state)
endpoint)
"Perform an extraction on the extract state ST with ENDPOITNT.
If there was no waiting inserter, do nothing."
(when (oref st lastinserter)
(save-match-data
(srecode-inserter-extract (oref st lastinserter)
(oref st anchor)
endpoint
(oref st lastdict)
st))
;; Clear state.
(srecode-extract-state-set st nil nil)))
;;; Extraction
;l
(defun srecode-extract (template start end)
"Extract TEMPLATE from between START and END in the current buffer.
Uses TEMPLATE's constant strings to break up the text and guess what
the dictionary entries were for that block of text."
(save-excursion
(save-restriction
(narrow-to-region start end)
(let ((dict (srecode-create-dictionary t))
(state (srecode-extract-state "state"))
)
(goto-char start)
(srecode-extract-method template dict state)
dict))))
(defmethod srecode-extract-method ((st srecode-template) dictionary
state)
"Extract template ST and store extracted text in DICTIONARY.
Optional STARTRETURN is a symbol in which the start of the first
plain-text match occured."
(srecode-extract-code-stream (oref st code) dictionary state))
(defun srecode-extract-code-stream (code dictionary state)
"Extract CODE from buffer text into DICTIONARY.
Uses string constants in CODE to split up the buffer.
Uses STATE to maintain the current extraction state."
(while code
(cond
;; constant strings need mark the end of old inserters that
;; need to extract values, or are just there.
((stringp (car code))
(srecode-extract-state-set-anchor state)
;; When we have a string, find it in the collection, then extract
;; that start point as the end point of the inserter
(unless (re-search-forward (regexp-quote (car code))
(point-max) t)
(error "Unable to extract all dictionary entries"))
(srecode-extract-state-extract state (match-beginning 0))
(goto-char (match-end 0))
)
;; Some inserters are simple, and need to be extracted after
;; we find our next block of static text.
((eq (srecode-inserter-do-extract-p (car code)) 'later)
(srecode-extract-state-set state (car code) dictionary)
)
;; Some inserter want to start extraction now, such as sections.
;; We can't predict the end point till we parse out the middle.
((eq (srecode-inserter-do-extract-p (car code)) 'now)
(srecode-extract-state-set-anchor state)
(srecode-inserter-extract (car code) (point) nil dictionary state))
)
(setq code (cdr code))
))
;;; Inserter Base Extractors
;;
(defmethod srecode-inserter-do-extract-p ((ins srecode-template-inserter))
"Return non-nil if this inserter can extract values."
nil)
(defmethod srecode-inserter-extract ((ins srecode-template-inserter)
start end dict state)
"Extract text from START/END and store in DICT.
Return nil as this inserter will extract nothing."
nil)
;;; Variable extractor is simple and can extract later.
;;
(defmethod srecode-inserter-do-extract-p ((ins srecode-template-inserter-variable))
"Return non-nil if this inserter can extract values."
'later)
(defmethod srecode-inserter-extract ((ins srecode-template-inserter-variable)
start end vdict state)
"Extract text from START/END and store in VDICT.
Return t if something was extracted.
Return nil if this inserter doesn't need to extract anything."
(srecode-dictionary-set-value vdict
(oref ins :object-name)
(buffer-substring-no-properties
start end)
)
t)
;;; Section Inserter
;;
(defmethod srecode-inserter-do-extract-p ((ins srecode-template-inserter-section-start))
"Return non-nil if this inserter can extract values."
'now)
(defmethod srecode-inserter-extract ((ins srecode-template-inserter-section-start)
start end indict state)
"Extract text from START/END and store in INDICT.
Return the starting location of the first plain-text match.
Return nil if nothing was extracted."
(let ((name (oref ins :object-name))
(subdict (srecode-create-dictionary indict))
(allsubdict nil)
)
;; Keep extracting till we can extract no more.
(while (condition-case nil
(progn
(srecode-extract-method
(oref ins template) subdict state)
t)
(error nil))
;; Success means keep this subdict, and also make a new one for
;; the next iteration.
(setq allsubdict (cons subdict allsubdict))
(setq subdict (srecode-create-dictionary indict))
)
(srecode-dictionary-set-value indict name (nreverse allsubdict))
nil))
;;; Include Extractor must extract now.
;;
(defmethod srecode-inserter-do-extract-p ((ins srecode-template-inserter-include))
"Return non-nil if this inserter can extract values."
'now)
(defmethod srecode-inserter-extract ((ins srecode-template-inserter-include)
start end dict state)
"Extract text from START/END and store in DICT.
Return the starting location of the first plain-text match.
Return nil if nothing was extracted."
(goto-char start)
(srecode-insert-include-lookup ins dict)
;; There are two modes for includes. One is with no dict,
;; so it is inserted straight. If the dict has a name, then
;; we need to run once per dictionary occurance.
(if (not (string= (oref ins :object-name) ""))
;; With a name, do the insertion.
(let ((subdict (srecode-dictionary-add-section-dictionary
dict (oref ins :object-name))))
(error "Need to implement include w/ name extractor.")
;; Recurse into the new template while no errors.
(while (condition-case nil
(progn
(srecode-extract-method
(oref ins includedtemplate) subdict
state)
t)
(error nil))))
;; No stream, do the extraction into the current dictionary.
(srecode-extract-method (oref ins includedtemplate) dict
state))
)
(provide 'srecode/extract)
;;; srecode/extract.el ends here

438
lisp/cedet/srecode/fields.el Normal file
View file

@ -0,0 +1,438 @@
;;; srecode/fields.el --- Handling type-in fields in a buffer.
;;
;; Copyright (C) 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:
;;
;; Idea courtesy of yasnippets.
;;
;; If someone prefers not to type unknown dictionary entries into
;; mini-buffer prompts, it could instead use in-buffer fields.
;;
;; A template-region specifies an area in which the fields exist. If
;; the cursor exits the region, all fields are cleared.
;;
;; Each field is independent, but some are linked together by name.
;; Typing in one will cause the matching ones to change in step.
;;
;; Each field has 2 overlays. The second overlay allows control in
;; the character just after the field, but does not highlight it.
;; Keep this library independent of SRecode proper.
(require 'eieio)
;;; Code:
(defvar srecode-field-archive nil
"While inserting a set of fields, collect in this variable.
Once an insertion set is done, these fields will be activated.")
(defface srecode-field-face
'((((class color) (background dark))
(:underline "green"))
(((class color) (background light))
(:underline "green4")))
"*Face used to specify editable fields from a template."
:group 'semantic-faces)
;;; BASECLASS
;;
;; Fields and the template region share some basic overlay features.
(defclass srecode-overlaid ()
((overlay :documentation
"Overlay representing this field.
The overlay will crossreference this object.")
)
"An object that gets automatically bound to an overlay.
Has virtual :start and :end initializers.")
(defmethod initialize-instance ((olaid srecode-overlaid) &optional args)
"Initialize OLAID, being sure it archived."
;; Extract :start and :end from the olaid list.
(let ((newargs nil)
(olay nil)
start end
)
(while args
(cond ((eq (car args) :start)
(setq args (cdr args))
(setq start (car args))
(setq args (cdr args))
)
((eq (car args) :end)
(setq args (cdr args))
(setq end (car args))
(setq args (cdr args))
)
(t
(push (car args) newargs)
(setq args (cdr args))
(push (car args) newargs)
(setq args (cdr args)))
))
;; Create a temporary overlay now. We have to use an overlay and
;; not a marker becaues of the in-front insertion rules. The rules
;; are backward from what is wanted while typing.
(setq olay (make-overlay start end (current-buffer) t nil))
(overlay-put olay 'srecode-init-only t)
(oset olaid overlay olay)
(call-next-method olaid (nreverse newargs))
))
(defmethod srecode-overlaid-activate ((olaid srecode-overlaid))
"Activate the overlaid area."
(let* ((ola (oref olaid overlay))
(start (overlay-start ola))
(end (overlay-end ola))
;; Create a new overlay here.
(ol (make-overlay start end (current-buffer) nil t)))
;; Remove the old one.
(delete-overlay ola)
(overlay-put ol 'srecode olaid)
(oset olaid overlay ol)
))
(defmethod srecode-delete ((olaid srecode-overlaid))
"Delete the overlay from OLAID."
(delete-overlay (oref olaid overlay))
(slot-makeunbound olaid 'overlay)
)
(defmethod srecode-empty-region-p ((olaid srecode-overlaid))
"Return non-nil if the region covered by OLAID is of length 0."
(= 0 (srecode-region-size olaid)))
(defmethod srecode-region-size ((olaid srecode-overlaid))
"Return the length of region covered by OLAID."
(let ((start (overlay-start (oref olaid overlay)))
(end (overlay-end (oref olaid overlay))))
(- end start)))
(defmethod srecode-point-in-region-p ((olaid srecode-overlaid))
"Return non-nil if point is in the region of OLAID."
(let ((start (overlay-start (oref olaid overlay)))
(end (overlay-end (oref olaid overlay))))
(and (>= (point) start) (<= (point) end))))
(defun srecode-overlaid-at-point (class)
"Return a list of overlaid fields of type CLASS at point."
(let ((ol (overlays-at (point)))
(ret nil))
(while ol
(let ((tmp (overlay-get (car ol) 'srecode)))
(when (and tmp (object-of-class-p tmp class))
(setq ret (cons tmp ret))))
(setq ol (cdr ol)))
(car (nreverse ret))))
(defmethod srecode-overlaid-text ((olaid srecode-overlaid) &optional set-to)
"Return the text under OLAID.
If SET-TO is a string, then replace the text of OLAID wit SET-TO."
(let* ((ol (oref olaid overlay))
(start (overlay-start ol)))
(if (not (stringp set-to))
;; Just return it.
(buffer-substring-no-properties start (overlay-end ol))
;; Replace it.
(save-excursion
(delete-region start (overlay-end ol))
(goto-char start)
(insert set-to)
(move-overlay ol start (+ start (length set-to))))
nil)))
;;; INSERTED REGION
;;
;; Managing point-exit, and flushing fields.
(defclass srecode-template-inserted-region (srecode-overlaid)
((fields :documentation
"A list of field overlays in this region.")
(active-region :allocation :class
:initform nil
:documentation
"The template region currently being handled.")
)
"Manage a buffer region in which fields exist.")
(defmethod initialize-instance ((ir srecode-template-inserted-region)
&rest args)
"Initialize IR, capturing the active fields, and creating the overlay."
;; Fill in the fields
(oset ir fields srecode-field-archive)
(setq srecode-field-archive nil)
;; Initailize myself first.
(call-next-method)
)
(defmethod srecode-overlaid-activate ((ir srecode-template-inserted-region))
"Activate the template area for IR."
;; Activate all our fields
(dolist (F (oref ir fields))
(srecode-overlaid-activate F))
;; Activate our overlay.
(call-next-method)
;; Position the cursor at the first field
(let ((first (car (oref ir fields))))
(goto-char (overlay-start (oref first overlay))))
;; Set ourselves up as 'active'
(oset ir active-region ir)
;; Setup the post command hook.
(add-hook 'post-command-hook 'srecode-field-post-command t t)
)
(defmethod srecode-delete ((ir srecode-template-inserted-region))
"Call into our base, but also clear out the fields."
;; Clear us out of the baseclass.
(oset ir active-region nil)
;; Clear our fields.
(mapc 'srecode-delete (oref ir fields))
;; Call to our base
(call-next-method)
;; Clear our hook.
(remove-hook 'post-command-hook 'srecode-field-post-command t)
)
(defsubst srecode-active-template-region ()
"Return the active region for template fields."
(oref srecode-template-inserted-region active-region))
(defun srecode-field-post-command ()
"Srecode field handler in the post command hook."
(let ((ar (srecode-active-template-region))
)
(if (not ar)
;; Find a bug and fix it.
(remove-hook 'post-command-hook 'srecode-field-post-command t)
(if (srecode-point-in-region-p ar)
nil ;; Keep going
;; We moved out of the temlate. Cancel the edits.
(srecode-delete ar)))
))
;;; FIELDS
(defclass srecode-field (srecode-overlaid)
((tail :documentation
"Overlay used on character just after this field.
Used to provide useful keybindings there.")
(name :initarg :name
:documentation
"The name of this field.
Usually initialized from the dictionary entry name that
the users needs to edit.")
(prompt :initarg :prompt
:documentation
"A prompt string to use if this were in the minibuffer.
Display when the cursor enters this field.")
(read-fcn :initarg :read-fcn
:documentation
"A function that would be used to read a string.
Try to use this to provide useful completion when available.")
)
"Representation of one field.")
(defvar srecode-field-keymap
(let ((km (make-sparse-keymap)))
(define-key km "\C-i" 'srecode-field-next)
(define-key km "\M-\C-i" 'srecode-field-prev)
(define-key km "\C-e" 'srecode-field-end)
(define-key km "\C-a" 'srecode-field-start)
(define-key km "\M-m" 'srecode-field-start)
(define-key km "\C-c\C-c" 'srecode-field-exit-ask)
km)
"Keymap applied to field overlays.")
(defmethod initialize-instance ((field srecode-field) &optional args)
"Initialize FIELD, being sure it archived."
(add-to-list 'srecode-field-archive field t)
(call-next-method)
)
(defmethod srecode-overlaid-activate ((field srecode-field))
"Activate the FIELD area."
(call-next-method)
(let* ((ol (oref field overlay))
(end nil)
(tail nil))
(overlay-put ol 'face 'srecode-field-face)
(overlay-put ol 'keymap srecode-field-keymap)
(overlay-put ol 'modification-hooks '(srecode-field-mod-hook))
(overlay-put ol 'insert-behind-hooks '(srecode-field-behind-hook))
(overlay-put ol 'insert-in-front-hooks '(srecode-field-mod-hook))
(setq end (overlay-end ol))
(setq tail (make-overlay end (+ end 1) (current-buffer)))
(overlay-put tail 'srecode field)
(overlay-put tail 'keymap srecode-field-keymap)
(overlay-put tail 'face 'srecode-field-face)
(oset field tail tail)
)
)
(defmethod srecode-delete ((olaid srecode-field))
"Delete our secondary overlay."
;; Remove our spare overlay
(delete-overlay (oref olaid tail))
(slot-makeunbound olaid 'tail)
;; Do our baseclass work.
(call-next-method)
)
(defvar srecode-field-replication-max-size 100
"Maximum size of a field before cancelling replication.")
(defun srecode-field-mod-hook (ol after start end &optional pre-len)
"Modification hook for the field overlay.
OL is the overlay.
AFTER is non-nil if it is called after the change.
START and END are the bounds of the change.
PRE-LEN is used in the after mode for the length of the changed text."
(when (and after (not undo-in-progress))
(let* ((field (overlay-get ol 'srecode))
(inhibit-point-motion-hooks t)
(inhibit-modification-hooks t)
)
;; Sometimes a field is deleted, but we might still get a stray
;; event. Lets just ignore those events.
(when (slot-boundp field 'overlay)
;; First, fixup the two overlays, in case they got confused.
(let ((main (oref field overlay))
(tail (oref field tail)))
(move-overlay main
(overlay-start main)
(1- (overlay-end tail)))
(move-overlay tail
(1- (overlay-end tail))
(overlay-end tail)))
;; Now capture text from the main overlay, and propagate it.
(let* ((new-text (srecode-overlaid-text field))
(region (srecode-active-template-region))
(allfields (when region (oref region fields)))
(name (oref field name)))
(dolist (F allfields)
(when (and (not (eq F field))
(string= name (oref F name)))
(if (> (length new-text) srecode-field-replication-max-size)
(message "Field size too large for replication.")
;; If we find other fields with the same name, then keep
;; then all together. Disable change hooks to make sure
;; we don't get a recursive edit.
(srecode-overlaid-text F new-text)
))))
))))
(defun srecode-field-behind-hook (ol after start end &optional pre-len)
"Modification hook for the field overlay.
OL is the overlay.
AFTER is non-nil if it is called after the change.
START and END are the bounds of the change.
PRE-LEN is used in the after mode for the length of the changed text."
(when after
(let* ((field (overlay-get ol 'srecode))
)
(move-overlay ol (overlay-start ol) end)
(srecode-field-mod-hook ol after start end pre-len))
))
(defmethod srecode-field-goto ((field srecode-field))
"Goto the FIELD."
(goto-char (overlay-start (oref field overlay))))
(defun srecode-field-next ()
"Move to the next field."
(interactive)
(let* ((f (srecode-overlaid-at-point 'srecode-field))
(tr (srecode-overlaid-at-point 'srecode-template-inserted-region))
)
(when (not f) (error "Not in a field"))
(when (not tr) (error "Not in a template region"))
(let ((fields (oref tr fields)))
(while fields
;; Loop over fields till we match. Then move to the next one.
(when (eq f (car fields))
(if (cdr fields)
(srecode-field-goto (car (cdr fields)))
(srecode-field-goto (car (oref tr fields))))
(setq fields nil)
)
(setq fields (cdr fields))))
))
(defun srecode-field-prev ()
"Move to the prev field."
(interactive)
(let* ((f (srecode-overlaid-at-point 'srecode-field))
(tr (srecode-overlaid-at-point 'srecode-template-inserted-region))
)
(when (not f) (error "Not in a field"))
(when (not tr) (error "Not in a template region"))
(let ((fields (reverse (oref tr fields))))
(while fields
;; Loop over fields till we match. Then move to the next one.
(when (eq f (car fields))
(if (cdr fields)
(srecode-field-goto (car (cdr fields)))
(srecode-field-goto (car (oref tr fields))))
(setq fields nil)
)
(setq fields (cdr fields))))
))
(defun srecode-field-end ()
"Move to the end of this field."
(interactive)
(let* ((f (srecode-overlaid-at-point 'srecode-field)))
(goto-char (overlay-end (oref f overlay)))))
(defun srecode-field-start ()
"Move to the end of this field."
(interactive)
(let* ((f (srecode-overlaid-at-point 'srecode-field)))
(goto-char (overlay-start (oref f overlay)))))
(defun srecode-field-exit-ask ()
"Ask if the user wants to exit field-editing mini-mode."
(interactive)
(when (y-or-n-p "Exit field-editing mode? ")
(srecode-delete (srecode-active-template-region))))
(provide 'srecode/fields)
;;; srecode/fields.el ends here

56
lisp/cedet/srecode/filters.el Normal file
View file

@ -0,0 +1,56 @@
;;; srecode/filters.el --- Filters for use in template variables.
;; 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:
;;
;; Various useful srecoder template functions.
;;; Code:
(require 'newcomment)
(require 'srecode/table)
(require 'srecode/insert)
(defun srecode-comment-prefix (str)
"Prefix each line of STR with the comment prefix characters."
(let* ((dict srecode-inserter-variable-current-dictionary)
;; Derive the comment characters to put in front of each line.
(cs (or (and dict
(srecode-dictionary-lookup-name dict "comment_prefix"))
(and comment-multi-line comment-continue)
(and (not comment-multi-line) comment-start)))
(strs (split-string str "\n"))
(newstr "")
)
(while strs
(cond ((and (not comment-multi-line) (string= (car strs) ""))
; (setq newstr (concat newstr "\n")))
)
(t
(setq newstr (concat newstr cs " " (car strs)))))
(setq strs (cdr strs))
(when strs (setq newstr (concat newstr "\n"))))
newstr))
(provide 'srecode/filters)
;;; srecode/filters.el ends here

261
lisp/cedet/srecode/find.el Normal file
View file

@ -0,0 +1,261 @@
;;;; srecode/find.el --- Tools for finding templates in the database.
;; 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:
;;
;; Various routines that search through various template tables
;; in search of the right template.
(require 'srecode/ctxt)
(require 'srecode/table)
(require 'srecode/map)
(declare-function srecode-compile-file "srecode/compile")
;;; Code:
(defun srecode-table (&optional mode)
"Return the currently active Semantic Recoder table for this buffer.
Optional argument MODE specifies the mode table to use."
(let* ((modeq (or mode major-mode))
(table (srecode-get-mode-table modeq)))
;; If there isn't one, keep searching backwards for a table.
(while (and (not table) (setq modeq (get-mode-local-parent modeq)))
(setq table (srecode-get-mode-table modeq)))
;; Last ditch effort.
(when (not table)
(setq table (srecode-get-mode-table 'default)))
table))
;;; TRACKER
;;
;; Template file tracker for between sessions.
;;
(defun srecode-load-tables-for-mode (mmode &optional appname)
"Load all the template files for MMODE.
Templates are found in the SRecode Template Map.
See `srecode-get-maps' for more.
APPNAME is the name of an application. In this case,
all template files for that application will be loaded."
(require 'srecode/compile)
(let ((files
(if appname
(apply 'append
(mapcar
(lambda (map)
(srecode-map-entries-for-app-and-mode map appname mmode))
(srecode-get-maps)))
(apply 'append
(mapcar
(lambda (map)
(srecode-map-entries-for-mode map mmode))
(srecode-get-maps)))))
)
;; Don't recurse if we are already the 'default state.
(when (not (eq mmode 'default))
;; Are we a derived mode? If so, get the parent mode's
;; templates loaded too.
(if (get-mode-local-parent mmode)
(srecode-load-tables-for-mode (get-mode-local-parent mmode)
appname)
;; No parent mode, all templates depend on the defaults being
;; loaded in, so get that in instead.
(srecode-load-tables-for-mode 'default appname)))
;; Load in templates for our major mode.
(dolist (f files)
(let ((mt (srecode-get-mode-table mmode))
)
(when (or (not mt) (not (srecode-mode-table-find mt (car f))))
(srecode-compile-file (car f)))
))
))
;;; SEARCH
;;
;; Find a given template based on name, and features of the current
;; buffer.
(defmethod srecode-template-get-table ((tab srecode-template-table)
template-name &optional
context application)
"Find in the template in table TAB, the template with TEMPLATE-NAME.
Optional argument CONTEXT specifies that the template should part
of a particular context.
The APPLICATION argument is unused."
(if context
;; If a context is specified, then look it up there.
(let ((ctxth (gethash context (oref tab contexthash))))
(when ctxth
(gethash template-name ctxth)))
;; No context, perhaps a merged name?
(gethash template-name (oref tab namehash))))
(defmethod srecode-template-get-table ((tab srecode-mode-table)
template-name &optional
context application)
"Find in the template in mode table TAB, the template with TEMPLATE-NAME.
Optional argument CONTEXT specifies a context a particular template
would belong to.
Optional argument APPLICATION restricts searches to only template tables
belonging to a specific application. If APPLICATION is nil, then only
tables that do not belong to an application will be searched."
(let* ((mt tab)
(tabs (oref mt :tables))
(ans nil))
(while (and (not ans) tabs)
(let ((app (oref (car tabs) :application)))
(when (or (and (not application) (null app))
(and application (eq app application)))
(setq ans (srecode-template-get-table (car tabs) template-name
context)))
(setq tabs (cdr tabs))))
(or ans
;; Recurse to the default.
(when (not (equal (oref tab :major-mode) 'default))
(srecode-template-get-table (srecode-get-mode-table 'default)
template-name context application)))))
;;
;; Find a given template based on a key binding.
;;
(defmethod srecode-template-get-table-for-binding
((tab srecode-template-table) binding &optional context)
"Find in the template name in table TAB, the template with BINDING.
Optional argument CONTEXT specifies that the template should part
of a particular context."
(let* ((keyout nil)
(hashfcn (lambda (key value)
(when (and (slot-boundp value 'binding)
(oref value binding)
(= (aref (oref value binding) 0) binding))
(setq keyout key))))
(contextstr (cond ((listp context)
(car-safe context))
((stringp context)
context)
(t nil)))
)
(if context
(let ((ctxth (gethash contextstr (oref tab contexthash))))
(when ctxth
;; If a context is specified, then look it up there.
(maphash hashfcn ctxth)
;; Context hashes EXCLUDE the context prefix which
;; we need to include, so concat it here
(when keyout
(setq keyout (concat contextstr ":" keyout)))
)))
(when (not keyout)
;; No context, or binding in context. Try full hash.
(maphash hashfcn (oref tab namehash)))
keyout))
(defmethod srecode-template-get-table-for-binding
((tab srecode-mode-table) binding &optional context application)
"Find in the template name in mode table TAB, the template with BINDING.
Optional argument CONTEXT specifies a context a particular template
would belong to.
Optional argument APPLICATION restricts searches to only template tables
belonging to a specific application. If APPLICATION is nil, then only
tables that do not belong to an application will be searched."
(let* ((mt tab)
(tabs (oref mt :tables))
(ans nil))
(while (and (not ans) tabs)
(let ((app (oref (car tabs) :application)))
(when (or (and (not application) (null app))
(and application (eq app application)))
(setq ans (srecode-template-get-table-for-binding
(car tabs) binding context)))
(setq tabs (cdr tabs))))
(or ans
;; Recurse to the default.
(when (not (equal (oref tab :major-mode) 'default))
(srecode-template-get-table-for-binding
(srecode-get-mode-table 'default) binding context)))))
;;; Interactive
;;
;; Interactive queries into the template data.
;;
(defvar srecode-read-template-name-history nil
"History for completing reads for template names.")
(defun srecode-all-template-hash (&optional mode hash)
"Create a hash table of all the currently available templates.
Optional argument MODE is the major mode to look for.
Optional argument HASH is the hash table to fill in."
(let* ((mhash (or hash (make-hash-table :test 'equal)))
(mmode (or mode major-mode))
(mp (get-mode-local-parent mmode))
)
;; Get the parent hash table filled into our current hash.
(when (not (eq mode 'default))
(if mp
(srecode-all-template-hash mp mhash)
(srecode-all-template-hash 'default mhash)))
;; Load up the hash table for our current mode.
(let* ((mt (srecode-get-mode-table mmode))
(tabs (when mt (oref mt :tables)))
)
(while tabs
;; Exclude templates for a perticular application.
(when (not (oref (car tabs) :application))
(maphash (lambda (key temp)
(puthash key temp mhash)
)
(oref (car tabs) namehash)))
(setq tabs (cdr tabs)))
mhash)))
(defun srecode-calculate-default-template-string (hash)
"Calculate the name of the template to use as a DEFAULT.
Templates are read from HASH.
Context into which the template is inserted is calculated
with `srecode-calculate-context'."
(let* ((ctxt (srecode-calculate-context))
(ans (concat (nth 0 ctxt) ":" (nth 1 ctxt))))
(if (gethash ans hash)
ans
;; No hash at the specifics, at least offer
;; the prefix for the completing read
(concat (nth 0 ctxt) ":"))))
(defun srecode-read-template-name (prompt &optional initial hist default)
"Completing read for Semantic Recoder template names.
PROMPT is used to query for the name of the template desired.
INITIAL is the initial string to use.
HIST is a history variable to use.
DEFAULT is what to use if the user presses RET."
(srecode-load-tables-for-mode major-mode)
(let* ((hash (srecode-all-template-hash))
(def (or initial
(srecode-calculate-default-template-string hash))))
(completing-read prompt hash
nil t def
(or hist
'srecode-read-template-name-history))))
(provide 'srecode/find)
;;; srecode/find.el ends here

366
lisp/cedet/srecode/getset.el Normal file
View file

@ -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

983
lisp/cedet/srecode/insert.el Normal file
View file

@ -0,0 +1,983 @@
;;; srecode/insert --- Insert srecode templates to an output stream.
;;; Copyright (C) 2005, 2007, 2008, 2009 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 <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; Define and implements specific inserter objects.
;;
;; Manage the insertion process for a template.
;;
(require 'srecode/compile)
(require 'srecode/find)
(require 'srecode/dictionary)
(defvar srecode-template-inserter-point)
(declare-function srecode-overlaid-activate "srecode/fields")
(declare-function srecode-template-inserted-region "srecode/fields")
;;; Code:
(defcustom srecode-insert-ask-variable-method 'ask
"Determine how to ask for a dictionary value when inserting a template.
Only the ASK style inserter will query the user for a value.
Dictionary value references that ask begin with the ? character.
Possible values are:
'ask - Prompt in the minibuffer as the value is inserted.
'field - Use the dictionary macro name as the inserted value,
and place a field there. Matched fields change together.
NOTE: The field feature does not yet work with XEmacs."
:group 'srecode
:type '(choice (const :tag "Ask" ask)
(cons :tag "Field" field)))
(defvar srecode-insert-with-fields-in-progress nil
"Non-nil means that we are actively inserting a template with fields.")
;;; INSERTION COMMANDS
;;
;; User level commands for inserting stuff.
(defvar srecode-insertion-start-context nil
"The context that was at point at the beginning of the template insertion.")
(defun srecode-insert-again ()
"Insert the previously inserted template (by name) again."
(interactive)
(let ((prev (car srecode-read-template-name-history)))
(if prev
(srecode-insert prev)
(call-interactively 'srecode-insert))))
;;;###autoload
(defun srecode-insert (template-name &rest dict-entries)
"Inesrt the template TEMPLATE-NAME into the current buffer at point.
DICT-ENTRIES are additional dictionary values to add."
(interactive (list (srecode-read-template-name "Template Name: ")))
(if (not (srecode-table))
(error "No template table found for mode %s" major-mode))
(let ((newdict (srecode-create-dictionary))
(temp (srecode-template-get-table (srecode-table) template-name))
(srecode-insertion-start-context (srecode-calculate-context))
)
(if (not temp)
(error "No Template named %s" template-name))
(while dict-entries
(srecode-dictionary-set-value newdict
(car dict-entries)
(car (cdr dict-entries)))
(setq dict-entries (cdr (cdr dict-entries))))
;;(srecode-resolve-arguments temp newdict)
(srecode-insert-fcn temp newdict)
;; Don't put code here. We need to return the end-mark
;; for this insertion step.
))
(defun srecode-insert-fcn (template dictionary &optional stream skipresolver)
"Insert TEMPLATE using DICTIONARY into STREAM.
Optional SKIPRESOLVER means to avoid refreshing the tag list,
or resolving any template arguments. It is assumed the caller
has set everything up already."
;; Perform the insertion.
(let ((standard-output (or stream (current-buffer)))
(end-mark nil))
(unless skipresolver
;; Make sure the semantic tags are up to date.
(semantic-fetch-tags)
;; Resolve the arguments
(srecode-resolve-arguments template dictionary))
;; Insert
(if (bufferp standard-output)
;; If there is a buffer, turn off various hooks. This will cause
;; the mod hooks to be buffered up during the insert, but
;; prevent tools like font-lock from fontifying mid-template.
;; Especialy important during insertion of complex comments that
;; cause the new font-lock to comment-color stuff after the inserted
;; comment.
;;
;; I'm not sure about the motion hooks. It seems like a good
;; idea though.
;;
;; Borrowed these concepts out of font-lock.
;;
;; I tried `combine-after-change-calls', but it did not have
;; the effect I wanted.
(let ((start (point)))
(let ((inhibit-point-motion-hooks t)
(inhibit-modification-hooks t)
)
(srecode--insert-into-buffer template dictionary)
)
;; Now call those after change functions.
(run-hook-with-args 'after-change-functions
start (point) 0)
)
(srecode-insert-method template dictionary))
;; Handle specialization of the POINT inserter.
(when (and (bufferp standard-output)
(slot-boundp 'srecode-template-inserter-point 'point)
)
(set-buffer standard-output)
(setq end-mark (point-marker))
(goto-char (oref srecode-template-inserter-point point)))
(oset-default 'srecode-template-inserter-point point eieio-unbound)
;; Return the end-mark.
(or end-mark (point)))
)
(defun srecode--insert-into-buffer (template dictionary)
"Insert a TEMPLATE with DICTIONARY into a buffer.
Do not call this function yourself. Instead use:
`srecode-insert' - Inserts by name.
`srecode-insert-fcn' - Insert with objects.
This function handles the case from one of the above functions when
the template is inserted into a buffer. It looks
at `srecode-insert-ask-variable-method' to decide if unbound dictionary
entries ask questions or insert editable fields.
Buffer based features related to change hooks is handled one level up."
;; This line prevents the field archive from being let bound
;; while the field insert tool is loaded via autoloads during
;; the insert.
(when (eq srecode-insert-ask-variable-method 'field)
(require 'srecode-fields))
(let ((srecode-field-archive nil) ; Prevent field leaks during insert
(start (point)) ; Beginning of the region.
)
;; This sub-let scopes the 'in-progress' piece so we know
;; when to setup the end-template.
(let ((srecode-insert-with-fields-in-progress
(if (eq srecode-insert-ask-variable-method 'field) t nil))
)
(srecode-insert-method template dictionary)
)
;; If we are not in-progress, and we insert fields, then
;; create the end-template with fields editable area.
(when (and (not srecode-insert-with-fields-in-progress)
(eq srecode-insert-ask-variable-method 'field) ; Only if user asked
srecode-field-archive ; Only if there were fields created
)
(let ((reg
;; Create the field-driven editable area.
(srecode-template-inserted-region
"TEMPLATE" :start start :end (point))))
(srecode-overlaid-activate reg))
)
;; We return with 'point being the end of the template insertion
;; area. Return value is not important.
))
;;; TEMPLATE ARGUMENTS
;;
;; Some templates have arguments. Each argument is assocaited with
;; a function that can resolve the inputs needed.
(defun srecode-resolve-arguments (temp dict)
"Resolve all the arguments needed by the template TEMP.
Apply anything learned to the dictionary DICT."
(srecode-resolve-argument-list (oref temp args) dict temp))
(defun srecode-resolve-argument-list (args dict &optional temp)
"Resolve arguments in the argument list ARGS.
ARGS is a list of symbols, such as :blank, or :file.
Apply values to DICT.
Optional argument TEMP is the template that is getting it's arguments resolved."
(let ((fcn nil))
(while args
(setq fcn (intern-soft (concat "srecode-semantic-handle-"
(symbol-name (car args)))))
(if (not fcn)
(error "Error resolving template argument %S" (car args)))
(if temp
(condition-case nil
;; Allow some to accept a 2nd argument optionally.
;; They throw an error if not available, so try again.
(funcall fcn dict temp)
(wrong-number-of-arguments (funcall fcn dict)))
(funcall fcn dict))
(setq args (cdr args)))
))
;;; INSERTION STACK & METHOD
;;
;; Code managing the top-level insert method and the current
;; insertion stack.
;;
(defmethod srecode-push ((st srecode-template))
"Push the srecoder template ST onto the active stack."
(oset st active (cons st (oref st active))))
(defmethod srecode-pop :STATIC ((st srecode-template))
"Pop the srecoder template ST onto the active stack.
ST can be a class, or an object."
(oset st active (cdr (oref st active))))
(defmethod srecode-peek :STATIC ((st srecode-template))
"Fetch the topmost active template record. ST can be a class."
(car (oref st active)))
(defmethod srecode-insert-method ((st srecode-template) dictionary)
"Insert the srecoder template ST."
;; Merge any template entries into the input dictionary.
(when (slot-boundp st 'dictionary)
(srecode-dictionary-merge dictionary (oref st dictionary)))
;; Do an insertion.
(unwind-protect
(let ((c (oref st code)))
(srecode-push st)
(srecode-insert-code-stream c dictionary))
;; Poping the stack is protected
(srecode-pop st)))
(defun srecode-insert-code-stream (code dictionary)
"Insert the CODE from a template into `standard-output'.
Use DICTIONARY to resolve any macros."
(while code
(cond ((stringp (car code))
(princ (car code)))
(t
(srecode-insert-method (car code) dictionary)))
(setq code (cdr code))))
;;; INSERTERS
;;
;; Specific srecode inserters.
;; The base class is from srecode-compile.
;;
;; Each inserter handles various macro codes from the temlate.
;; The `code' slot specifies a character used to identify which
;; inserter is to be created.
;;
(defclass srecode-template-inserter-newline (srecode-template-inserter)
((key :initform "\n"
:allocation :class
:documentation
"The character code used to identify inserters of this style.")
(hard :initform nil
:initarg :hard
:documentation
"Is this a hard newline (always inserted) or optional?
Optional newlines don't insert themselves if they are on a blank line
by themselves.")
)
"Insert a newline, and possibly do indenting.
Specify the :indent argument to enable automatic indentation when newlines
occur in your template.")
(defmethod srecode-insert-method ((sti srecode-template-inserter-newline)
dictionary)
"Insert the STI inserter."
;; To be safe, indent the previous line since the template will
;; change what is there to indent
(let ((i (srecode-dictionary-lookup-name dictionary "INDENT"))
(inbuff (bufferp standard-output))
(doit t)
(pm (point-marker)))
(when (and inbuff (not (oref sti hard)))
;; If this is not a hard newline, we need do the calculation
;; and set "doit" to nil.
(beginning-of-line)
(save-restriction
(narrow-to-region (point) pm)
(when (looking-at "\\s-*$")
(setq doit nil)))
(goto-char pm)
)
;; Do indentation reguardless of the newline.
(when (and (eq i t) inbuff)
(indent-according-to-mode)
(goto-char pm))
(when doit
(princ "\n")
;; Indent after the newline, particularly for numeric indents.
(cond ((and (eq i t) (bufferp standard-output))
;; WARNING - indent according to mode requires that standard-output
;; is a buffer!
;; @todo - how to indent in a string???
(setq pm (point-marker))
(indent-according-to-mode)
(goto-char pm))
((numberp i)
(princ (make-string i " ")))
((stringp i)
(princ i))))))
(defmethod srecode-dump ((ins srecode-template-inserter-newline) indent)
"Dump the state of the SRecode template inserter INS."
(call-next-method)
(when (oref ins hard)
(princ " : hard")
))
(defclass srecode-template-inserter-blank (srecode-template-inserter)
((key :initform "\r"
:allocation :class
:documentation
"The character represeinting this inserter style.
Can't be blank, or it might be used by regular variable insertion.")
(where :initform 'begin
:initarg :where
:documentation
"This should be 'begin or 'end, indicating where to insrt a CR.
When set to 'begin, it will insert a CR if we are not at 'bol'.
When set to 'end it will insert a CR if we are not at 'eol'")
;; @TODO - Add slot and control for the number of blank
;; lines before and after point.
)
"Insert a newline before and after a template, and possibly do indenting.
Specify the :blank argument to enable this inserter.")
(defmethod srecode-insert-method ((sti srecode-template-inserter-blank)
dictionary)
"Make sure there is no text before or after point."
(let ((i (srecode-dictionary-lookup-name dictionary "INDENT"))
(inbuff (bufferp standard-output))
(pm (point-marker)))
(when (and inbuff
;; Don't do this if we are not the active template.
(= (length (oref srecode-template active)) 1))
(when (and (eq i t) inbuff (not (eq (oref sti where) 'begin)))
(indent-according-to-mode)
(goto-char pm))
(cond ((and (eq (oref sti where) 'begin) (not (bolp)))
(princ "\n"))
((eq (oref sti where) 'end)
;; If there is whitespace after pnt, then clear it out.
(when (looking-at "\\s-*$")
(delete-region (point) (point-at-eol)))
(when (not (eolp))
(princ "\n")))
)
(setq pm (point-marker))
(when (and (eq i t) inbuff (not (eq (oref sti where) 'end)))
(indent-according-to-mode)
(goto-char pm))
)))
(defclass srecode-template-inserter-comment (srecode-template-inserter)
((key :initform ?!
:allocation :class
:documentation
"The character code used to identify inserters of this style.")
)
"Allow comments within template coding. This inserts nothing.")
(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-comment)
escape-start escape-end)
"Insert an example using inserter INS.
Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
(princ " ")
(princ escape-start)
(princ "! Miscellaneous text commenting in your template. ")
(princ escape-end)
(terpri)
)
(defmethod srecode-insert-method ((sti srecode-template-inserter-comment)
dictionary)
"Don't insert anything for comment macros in STI."
nil)
(defclass srecode-template-inserter-variable (srecode-template-inserter)
((key :initform nil
:allocation :class
:documentation
"The character code used to identify inserters of this style."))
"Insert the value of a dictionary entry
If there is no entry, insert nothing.")
(defvar srecode-inserter-variable-current-dictionary nil
"The active dictionary when calling a variable filter.")
(defmethod srecode-insert-variable-secondname-handler
((sti srecode-template-inserter-variable) dictionary value secondname)
"For VALUE handle SECONDNAME behaviors for this variable inserter.
Return the result as a string.
By default, treat as a function name.
If SECONDNAME is nil, return VALUE."
(if secondname
(let ((fcnpart (read secondname)))
(if (fboundp fcnpart)
(let ((srecode-inserter-variable-current-dictionary dictionary))
(funcall fcnpart value))
;; Else, warn.
(error "Variable insertion second arg %s is not a function."
secondname)))
value))
(defmethod srecode-insert-method ((sti srecode-template-inserter-variable)
dictionary)
"Insert the STI inserter."
;; Convert the name into a name/fcn pair
(let* ((name (oref sti :object-name))
(fcnpart (oref sti :secondname))
(val (srecode-dictionary-lookup-name
dictionary name))
(do-princ t)
)
;; Alert if a macro wasn't found.
(when (not val)
(message "Warning: macro %S was not found in the dictionary." name)
(setq val ""))
;; If there was a functional part, call that function.
(cond ;; Strings
((stringp val)
(setq val (srecode-insert-variable-secondname-handler
sti dictionary val fcnpart)))
;; Compound data value
((srecode-dictionary-compound-value-child-p val)
;; Force FCN to be a symbol
(when fcnpart (setq fcnpart (read fcnpart)))
;; Convert compound value to a string with the fcn.
(setq val (srecode-compound-toString val fcnpart dictionary))
;; If the value returned is nil, then it may be a special
;; field inserter that requires us to set do-princ to nil.
(when (not val)
(setq do-princ nil)
)
)
;; Dictionaries... not allowed in this style
((srecode-dictionary-child-p val)
(error "Macro %s cannot insert a dictionary. Use section macros instead."
name))
;; Other stuff... convert
(t
(error "Macro %s cannot insert arbitrary data." name)
;;(if (and val (not (stringp val)))
;; (setq val (format "%S" val))))
))
;; Output the dumb thing unless the type of thing specifically
;; did the inserting forus.
(when do-princ
(princ val))))
(defclass srecode-template-inserter-ask (srecode-template-inserter-variable)
((key :initform ??
:allocation :class
:documentation
"The character code used to identify inserters of this style.")
(prompt :initarg :prompt
:initform nil
:documentation
"The prompt used to query for this dictionary value.")
(defaultfcn :initarg :defaultfcn
:initform nil
:documentation
"The function which can calculate a default value.")
(read-fcn :initarg :read-fcn
:initform 'read-string
:documentation
"The function used to read in the text for this prompt.")
)
"Insert the value of a dictionary entry
If there is no entry, prompt the user for the value to use.
The prompt text used is derived from the previous PROMPT command in the
template file.")
(defmethod srecode-inserter-apply-state ((ins srecode-template-inserter-ask) STATE)
"For the template inserter INS, apply information from STATE.
Loop over the prompts to see if we have a match."
(let ((prompts (oref STATE prompts))
)
(while prompts
(when (string= (semantic-tag-name (car prompts))
(oref ins :object-name))
(oset ins :prompt
(semantic-tag-get-attribute (car prompts) :text))
(oset ins :defaultfcn
(semantic-tag-get-attribute (car prompts) :default))
(oset ins :read-fcn
(or (semantic-tag-get-attribute (car prompts) :read)
'read-string))
)
(setq prompts (cdr prompts)))
))
(defmethod srecode-insert-method ((sti srecode-template-inserter-ask)
dictionary)
"Insert the STI inserter."
(let ((val (srecode-dictionary-lookup-name
dictionary (oref sti :object-name))))
(if val
;; Does some extra work. Oh well.
(call-next-method)
;; How is our -ask value determined?
(if srecode-insert-with-fields-in-progress
;; Setup editable fields.
(setq val (srecode-insert-method-field sti dictionary))
;; Ask the question...
(setq val (srecode-insert-method-ask sti dictionary)))
;; After asking, save in the dictionary so that
;; the user can use the same name again later.
(srecode-dictionary-set-value
(srecode-root-dictionary dictionary)
(oref sti :object-name) val)
;; Now that this value is safely stowed in the dictionary,
;; we can do what regular inserters do.
(call-next-method))))
(defmethod srecode-insert-ask-default ((sti srecode-template-inserter-ask)
dictionary)
"Derive the default value for an askable inserter STI.
DICTIONARY is used to derive some values."
(let ((defaultfcn (oref sti :defaultfcn)))
(cond ((stringp defaultfcn)
defaultfcn)
((functionp defaultfcn)
(funcall defaultfcn))
((and (listp defaultfcn)
(eq (car defaultfcn) 'macro))
(srecode-dictionary-lookup-name
dictionary (cdr defaultfcn)))
((null defaultfcn)
"")
(t
(error "Unknown default for prompt: %S"
defaultfcn)))))
(defmethod srecode-insert-method-ask ((sti srecode-template-inserter-ask)
dictionary)
"Do the \"asking\" for the template inserter STI.
Use DICTIONARY to resolve values."
(let* ((prompt (oref sti prompt))
(default (srecode-insert-ask-default sti dictionary))
(reader (oref sti :read-fcn))
(val nil)
)
(cond ((eq reader 'y-or-n-p)
(if (y-or-n-p (or prompt
(format "%s? "
(oref sti :object-name))))
(setq val default)
(setq val "")))
((eq reader 'read-char)
(setq val (format
"%c"
(read-char (or prompt
(format "Char for %s: "
(oref sti :object-name))))))
)
(t
(save-excursion
(setq val (funcall reader
(or prompt
(format "Specify %s: "
(oref sti :object-name)))
default
)))))
;; Return our derived value.
val)
)
(defmethod srecode-insert-method-field ((sti srecode-template-inserter-ask)
dictionary)
"Create an editable field for the template inserter STI.
Use DICTIONARY to resolve values."
(let* ((default (srecode-insert-ask-default sti dictionary))
(compound-value
(srecode-field-value (oref sti :object-name)
:firstinserter sti
:defaultvalue default))
)
;; Return this special compound value as the thing to insert.
;; This special compound value will repeat our asked question
;; across multiple locations.
compound-value))
(defmethod srecode-dump ((ins srecode-template-inserter-ask) indent)
"Dump the state of the SRecode template inserter INS."
(call-next-method)
(princ " : \"")
(princ (oref ins prompt))
(princ "\"")
)
(defclass srecode-template-inserter-width (srecode-template-inserter-variable)
((key :initform ?|
:allocation :class
:documentation
"The character code used to identify inserters of this style.")
)
"Inserts the value of a dictionary variable with a specific width.
The second argument specifies the width, and a pad, seperated by a colon.
thus a specification of `10:left' will insert the value of A
to 10 characters, with spaces added to the left. Use `right' for adding
spaces to the right.")
(defmethod srecode-insert-variable-secondname-handler
((sti srecode-template-inserter-width) dictionary value width)
"For VALUE handle WIDTH behaviors for this variable inserter.
Return the result as a string.
By default, treat as a function name."
(if width
;; Trim or pad to new length
(let* ((split (split-string width ":"))
(width (string-to-number (nth 0 split)))
(second (nth 1 split))
(pad (cond ((or (null second) (string= "right" second))
'right)
((string= "left" second)
'left)
(t
(error "Unknown pad type %s" second)))))
(if (>= (length value) width)
;; Simple case - too long.
(substring value 0 width)
;; We need to pad on one side or the other.
(let ((padchars (make-string (- width (length value)) ? )))
(if (eq pad 'left)
(concat padchars value)
(concat value padchars)))))
(error "Width not specified for variable/width inserter.")))
(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-width)
escape-start escape-end)
"Insert an example using inserter INS.
Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
(princ " ")
(princ escape-start)
(princ "|A:10:right")
(princ escape-end)
(terpri)
)
(defvar srecode-template-inserter-point-override nil
"When non-nil, the point inserter will do this functin instead.")
(defclass srecode-template-inserter-point (srecode-template-inserter)
((key :initform ?^
:allocation :class
:documentation
"The character code used to identify inserters of this style.")
(point :type (or null marker)
:allocation :class
:documentation
"Record the value of (point) in this class slot.
It is the responsibility of the inserter algorithm to clear this
after a successful insertion."))
"Record the value of (point) when inserted.
The cursor is placed at the ^ macro after insertion.
Some inserter macros, such as `srecode-template-inserter-include-wrap'
will place text at the ^ macro from the included macro.")
(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-point)
escape-start escape-end)
"Insert an example using inserter INS.
Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
(princ " ")
(princ escape-start)
(princ "^")
(princ escape-end)
(terpri)
)
(defmethod srecode-insert-method ((sti srecode-template-inserter-point)
dictionary)
"Insert the STI inserter.
Save point in the class allocated 'point' slot.
If `srecode-template-inserter-point-override' then this generalized
marker will do something else. See `srecode-template-inserter-include-wrap'
as an example."
(if srecode-template-inserter-point-override
;; Disable the old override while we do this.
(let ((over srecode-template-inserter-point-override)
(srecode-template-inserter-point-override nil))
(funcall over dictionary)
)
(oset sti point (point-marker))
))
(defclass srecode-template-inserter-subtemplate (srecode-template-inserter)
()
"Wrap a section of a template under the control of a macro."
:abstract t)
(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-subtemplate)
escape-start escape-end)
"Insert an example using inserter INS.
Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
(call-next-method)
(princ " Template Text to control")
(terpri)
(princ " ")
(princ escape-start)
(princ "/VARNAME")
(princ escape-end)
(terpri)
)
(defmethod srecode-insert-subtemplate ((sti srecode-template-inserter-subtemplate)
dict slot)
"Insert a subtemplate for the inserter STI with dictionary DICT."
;; make sure that only dictionaries are used.
(when (not (srecode-dictionary-child-p dict))
(error "Only section dictionaries allowed for %s"
(object-name-string sti)))
;; Output the code from the sub-template.
(srecode-insert-method (slot-value sti slot) dict)
)
(defmethod srecode-insert-method-helper ((sti srecode-template-inserter-subtemplate)
dictionary slot)
"Do the work for inserting the STI inserter.
Loops over the embedded CODE which was saved here during compilation.
The template to insert is stored in SLOT."
(let ((dicts (srecode-dictionary-lookup-name
dictionary (oref sti :object-name))))
;; If there is no section dictionary, then don't output anything
;; from this section.
(while dicts
(srecode-insert-subtemplate sti (car dicts) slot)
(setq dicts (cdr dicts)))))
(defmethod srecode-insert-method ((sti srecode-template-inserter-subtemplate)
dictionary)
"Insert the STI inserter.
Calls back to `srecode-insert-method-helper' for this class."
(srecode-insert-method-helper sti dictionary 'template))
(defclass srecode-template-inserter-section-start (srecode-template-inserter-subtemplate)
((key :initform ?#
:allocation :class
:documentation
"The character code used to identify inserters of this style.")
(template :initarg :template
:documentation
"A Template used to frame the codes from this inserter.")
)
"Apply values from a sub-dictionary to a template section.
The dictionary saved at the named dictionary entry will be
applied to the text between the section start and the
`srecode-template-inserter-section-end' macro.")
(defmethod srecode-parse-input ((ins srecode-template-inserter-section-start)
tag input STATE)
"For the section inserter INS, parse INPUT.
Shorten input until the END token is found.
Return the remains of INPUT."
(let* ((out (srecode-compile-split-code tag input STATE
(oref ins :object-name))))
(oset ins template (srecode-template
(object-name-string ins)
:context nil
:args nil
:code (cdr out)))
(car out)))
(defmethod srecode-dump ((ins srecode-template-inserter-section-start) indent)
"Dump the state of the SRecode template inserter INS."
(call-next-method)
(princ "\n")
(srecode-dump-code-list (oref (oref ins template) code)
(concat indent " "))
)
(defclass srecode-template-inserter-section-end (srecode-template-inserter)
((key :initform ?/
:allocation :class
:documentation
"The character code used to identify inserters of this style.")
)
"All template segments between the secion-start and section-end
are treated specially.")
(defmethod srecode-insert-method ((sti srecode-template-inserter-section-end)
dictionary)
"Insert the STI inserter."
)
(defmethod srecode-match-end ((ins srecode-template-inserter-section-end) name)
"For the template inserter INS, do I end a section called NAME?"
(string= name (oref ins :object-name)))
(defclass srecode-template-inserter-include (srecode-template-inserter-subtemplate)
((key :initform ?>
:allocation :class
:documentation
"The character code used to identify inserters of this style.")
(includedtemplate
:initarg :includedtemplate
:documentation
"The template included for this inserter."))
"Include a different template into this one.
The included template will have additional dictionary entries from the subdictionary
stored specified by this macro.")
(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-include)
escape-start escape-end)
"Insert an example using inserter INS.
Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
(princ " ")
(princ escape-start)
(princ ">DICTNAME:contextname:templatename")
(princ escape-end)
(terpri)
)
(defmethod srecode-insert-include-lookup ((sti srecode-template-inserter-include)
dictionary)
"For the template inserter STI, lookup the template to include.
Finds the template with this macro function part and stores it in
this template instance."
(let* ((templatenamepart (oref sti :secondname))
)
;; If there was no template name, throw an error
(if (not templatenamepart)
(error "Include macro %s needs a template name." (oref sti :object-name)))
;; Find the template by name, and save it.
(if (or (not (slot-boundp sti 'includedtemplate))
(not (oref sti includedtemplate)))
(let ((tmpl (srecode-template-get-table (srecode-table)
templatenamepart))
(active (oref srecode-template active))
ctxt)
(when (not tmpl)
;; If it isn't just available, scan back through
;; the active template stack, searching for a matching
;; context.
(while (and (not tmpl) active)
(setq ctxt (oref (car active) context))
(setq tmpl (srecode-template-get-table (srecode-table)
templatenamepart
ctxt))
(when (not tmpl)
(when (slot-boundp (car active) 'table)
(let ((app (oref (oref (car active) table) application)))
(when app
(setq tmpl (srecode-template-get-table
(srecode-table)
templatenamepart
ctxt app)))
)))
(setq active (cdr active)))
(when (not tmpl)
;; If it wasn't in this context, look to see if it
;; defines it's own context
(setq tmpl (srecode-template-get-table (srecode-table)
templatenamepart)))
)
(oset sti :includedtemplate tmpl)))
(if (not (oref sti includedtemplate))
;; @todo - Call into a debugger to help find the template in question.
(error "No template \"%s\" found for include macro `%s'"
templatenamepart (oref sti :object-name)))
))
(defmethod srecode-insert-method ((sti srecode-template-inserter-include)
dictionary)
"Insert the STI inserter.
Finds the template with this macro function part, and inserts it
with the dictionaries found in the dictinary."
(srecode-insert-include-lookup sti dictionary)
;; Insert the template.
;; Our baseclass has a simple way to do this.
(if (srecode-dictionary-lookup-name dictionary (oref sti :object-name))
;; If we have a value, then call the next method
(srecode-insert-method-helper sti dictionary 'includedtemplate)
;; If we don't have a special dictitonary, then just insert with the
;; current dictionary.
(srecode-insert-subtemplate sti dictionary 'includedtemplate))
)
;;
;; This template combines the include template and the sectional template.
;; It will first insert the included template, then insert the embedded
;; template wherever the $^$ in the included template was.
;;
;; Since it uses dual inheretance, it will magically get the end-matching
;; behavior of #, with the including feature of >.
;;
(defclass srecode-template-inserter-include-wrap (srecode-template-inserter-include srecode-template-inserter-section-start)
((key :initform ?<
:allocation :class
:documentation
"The character code used to identify inserters of this style.")
)
"Include a different template into this one, and add text at the ^ macro.
The included template will have additional dictionary entries from the subdictionary
stored specified by this macro. If the included macro includes a ^ macro,
then the text between this macro and the end macro will be inserted at
the ^ macro.")
(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-include-wrap)
escape-start escape-end)
"Insert an example using inserter INS.
Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
(princ " ")
(princ escape-start)
(princ "<DICTNAME:contextname:templatename")
(princ escape-end)
(terpri)
(princ " Template Text to insert at ^ macro")
(terpri)
(princ " ")
(princ escape-start)
(princ "/DICTNAME")
(princ escape-end)
(terpri)
)
(defmethod srecode-insert-method ((sti srecode-template-inserter-include-wrap)
dictionary)
"Insert the template STI.
This will first insert the include part via inheritance, then
insert the section it wraps into the location in the included
template where a ^ inserter occurs."
;; Step 1: Look up the included inserter
(srecode-insert-include-lookup sti dictionary)
;; Step 2: Temporarilly override the point inserter.
(let* ((vaguely-unique-name sti)
(srecode-template-inserter-point-override
(lambda (dict2)
(if (srecode-dictionary-lookup-name
dict2 (oref vaguely-unique-name :object-name))
;; Insert our sectional part with looping.
(srecode-insert-method-helper
vaguely-unique-name dict2 'template)
;; Insert our sectional part just once.
(srecode-insert-subtemplate vaguely-unique-name
dict2 'template))
)))
;; Do a regular insertion for an include, but with our override in
;; place.
(call-next-method)
))
(provide 'srecode/insert)
;; Local variables:
;; generated-autoload-file: "loaddefs.el"
;; generated-autoload-feature: srecode/loaddefs
;; generated-autoload-load-name: "srecode/insert"
;; End:
;;; srecode/insert.el ends here

62
lisp/cedet/srecode/java.el Normal file
View file

@ -0,0 +1,62 @@
;;; srecode-java.el --- Srecode Java support
;; Copyright (C) 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:
;;
;; Special support for the Java language.
;;; Code:
(require 'srecode/dictionary)
;;;###autoload
(defun srecode-semantic-handle-:java (dict)
"Add macros into the dictionary DICT based on the current java file.
Adds the following:
FILENAME_AS_PACKAGE - file/dir converted into a java package name.
FILENAME_AS_CLASS - file converted to a Java class name."
;; A symbol representing
(let* ((fsym (file-name-nondirectory (buffer-file-name)))
(fnox (file-name-sans-extension fsym))
(dir (file-name-directory (buffer-file-name)))
(fpak fsym)
)
(while (string-match "\\.\\| " fpak)
(setq fpak (replace-match "_" t t fpak)))
(if (string-match "src/" dir)
(setq dir (substring dir (match-end 0)))
(setq dir (file-name-nondirectory (directory-file-name dir))))
(while (string-match "/" dir)
(setq dir (replace-match "_" t t dir)))
(srecode-dictionary-set-value dict "FILENAME_AS_PACKAGE"
(concat dir "." fpak))
(srecode-dictionary-set-value dict "FILENAME_AS_CLASS" fnox)
))
(provide 'srecode/java)
;; Local variables:
;; generated-autoload-file: "loaddefs.el"
;; generated-autoload-feature: srecode/loaddefs
;; generated-autoload-load-name: "srecode/java"
;; End:
;;; srecode/java.el ends here

415
lisp/cedet/srecode/map.el Normal file
View file

@ -0,0 +1,415 @@
;;; srecode/map.el --- Manage a template file map
;; Copyright (C) 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:
;;
;; Read template files, and build a map of where they can be found.
;; Save the map to disk, and refer to it when bootstrapping a new
;; Emacs session with srecode.
(require 'semantic)
(require 'eieio-base)
(require 'srecode)
;;; Code:
;; The defcustom is given at the end of the file.
(defvar srecode-map-load-path)
(defun srecode-map-base-template-dir ()
"Find the base template directory for SRecode."
(let* ((lib (locate-library "srecode.el"))
(dir (file-name-directory lib)))
(expand-file-name "templates/" dir)
))
;;; Current MAP
;;
(defvar srecode-current-map nil
"The current map for global SRecode templtes.")
(defcustom srecode-map-save-file (expand-file-name "~/.srecode/srecode-map")
"The save location for SRecode's map file.
If the save file is nil, then the MAP is not saved between sessions."
:group 'srecode
:type 'file)
(defclass srecode-map (eieio-persistent)
((fileheaderline :initform ";; SRECODE TEMPLATE MAP")
(files :initarg :files
:initform nil
:type list
:documentation
"An alist of files and the major-mode that they cover.")
(apps :initarg :apps
:initform nil
:type list
:documentation
"An alist of applications.
Each app keys to an alist of files and modes (as above.)")
)
"A map of srecode templates.")
(defmethod srecode-map-entry-for-file ((map srecode-map) file)
"Return the entry in MAP for FILE."
(assoc file (oref map files)))
(defmethod srecode-map-entries-for-mode ((map srecode-map) mode)
"Return the entries in MAP for major MODE."
(let ((ans nil))
(dolist (f (oref map files))
(when (mode-local-use-bindings-p mode (cdr f))
(setq ans (cons f ans))))
ans))
(defmethod srecode-map-entry-for-app ((map srecode-map) app)
"Return the entry in MAP for APP'lication."
(assoc app (oref map apps))
)
(defmethod srecode-map-entries-for-app-and-mode ((map srecode-map) app mode)
"Return the entries in MAP for major MODE."
(let ((ans nil)
(appentry (srecode-map-entry-for-app map app)))
(dolist (f (cdr appentry))
(when (eq (cdr f) mode)
(setq ans (cons f ans))))
ans))
(defmethod srecode-map-entry-for-file-anywhere ((map srecode-map) file)
"Search in all entry points in MAP for FILE.
Return a list ( APP . FILE-ASSOC ) where APP is nil
in the global map."
(or
;; Look in the global entry
(let ((globalentry (srecode-map-entry-for-file map file)))
(when globalentry
(cons nil globalentry)))
;; Look in each app.
(let ((match nil))
(dolist (app (oref map apps))
(let ((appmatch (assoc file (cdr app))))
(when appmatch
(setq match (cons app appmatch)))))
match)
;; Other?
))
(defmethod srecode-map-delete-file-entry ((map srecode-map) file)
"Update MAP to exclude FILE from the file list."
(let ((entry (srecode-map-entry-for-file map file)))
(when entry
(object-remove-from-list map 'files entry))))
(defmethod srecode-map-update-file-entry ((map srecode-map) file mode)
"Update a MAP entry for FILE to be used with MODE.
Return non-nil if the MAP was changed."
(let ((entry (srecode-map-entry-for-file map file))
(dirty t))
(cond
;; It is already a match.. do nothing.
((and entry (eq (cdr entry) mode))
(setq dirty nil))
;; We have a non-matching entry. Change the cdr.
(entry
(setcdr entry mode))
;; No entry, just add it to the list.
(t
(object-add-to-list map 'files (cons file mode))
))
dirty))
(defmethod srecode-map-delete-file-entry-from-app ((map srecode-map) file app)
"Delete from MAP the FILE entry within the APP'lication."
(let* ((appe (srecode-map-entry-for-app map app))
(fentry (assoc file (cdr appe))))
(setcdr appe (delete fentry (cdr appe))))
)
(defmethod srecode-map-update-app-file-entry ((map srecode-map) file mode app)
"Update the MAP entry for FILE to be used with MODE within APP.
Return non-nil if the map was changed."
(let* ((appentry (srecode-map-entry-for-app map app))
(appfileentry (assoc file (cdr appentry)))
(dirty t)
)
(cond
;; Option 1 - We have this file in this application already
;; with the correct mode.
((and appfileentry (eq (cdr appfileentry) mode))
(setq dirty nil)
)
;; Option 2 - We have a non-matching entry. Change Cdr.
(appfileentry
(setcdr appfileentry mode))
(t
;; For option 3 & 4 - remove the entry from any other lists
;; we can find.
(let ((any (srecode-map-entry-for-file-anywhere map file)))
(when any
(if (null (car any))
;; Global map entry
(srecode-map-delete-file-entry map file)
;; Some app
(let ((appentry (srecode-map-entry-for-app map app)))
(setcdr appentry (delete (cdr any) (cdr appentry))))
)))
;; Now do option 3 and 4
(cond
;; Option 3 - No entry for app. Add to the list.
(appentry
(setcdr appentry (cons (cons file mode) (cdr appentry)))
)
;; Option 4 - No app entry. Add app to list with this file.
(t
(object-add-to-list map 'apps (list app (cons file mode)))
)))
)
dirty))
;;; MAP Updating
;;
;;;###autoload
(defun srecode-get-maps (&optional reset)
"Get a list of maps relevant to the current buffer.
Optional argument RESET forces a reset of the current map."
(interactive "P")
;; Always update the map, but only do a full reset if
;; the user asks for one.
(srecode-map-update-map (not reset))
(if (interactive-p)
;; Dump this map.
(with-output-to-temp-buffer "*SRECODE MAP*"
(princ " -- SRecode Global map --\n")
(srecode-maps-dump-file-list (oref srecode-current-map files))
(princ "\n -- Application Maps --\n")
(dolist (ap (oref srecode-current-map apps))
(let ((app (car ap))
(files (cdr ap)))
(princ app)
(princ " :\n")
(srecode-maps-dump-file-list files))
(princ "\n"))
(princ "\nUse:\n\n M-x customize-variable RET srecode-map-load-path RET")
(princ "\n To change the path where SRecode loads templates from.")
)
;; Eventually, I want to return many maps to search through.
(list srecode-current-map)))
(eval-when-compile (require 'data-debug))
(defun srecode-adebug-maps ()
"Run ADEBUG on the output of `srecode-get-maps'."
(interactive)
(require 'data-debug)
(let ((start (current-time))
(p (srecode-get-maps t)) ;; Time the reset.
(end (current-time))
)
(message "Updating the map took %.2f seconds."
(semantic-elapsed-time start end))
(data-debug-new-buffer "*SRECODE ADEBUG*")
(data-debug-insert-stuff-list p "*")))
(defun srecode-maps-dump-file-list (flist)
"Dump a file list FLIST to `standard-output'."
(princ "Mode\t\t\tFilename\n")
(princ "------\t\t\t------------------\n")
(dolist (fe flist)
(prin1 (cdr fe))
(princ "\t")
(when (> (* 2 8) (length (symbol-name (cdr fe))))
(princ "\t"))
(when (> 8 (length (symbol-name (cdr fe))))
(princ "\t"))
(princ (car fe))
(princ "\n")
))
(defun srecode-map-file-still-valid-p (filename map)
"Return t if FILENAME should be in MAP still."
(let ((valid nil))
(and (file-exists-p filename)
(progn
(dolist (p srecode-map-load-path)
(when (and (< (length p) (length filename))
(string= p (substring filename 0 (length p))))
(setq valid t))
)
valid))
))
(defun srecode-map-update-map (&optional fast)
"Update the current map from `srecode-map-load-path'.
Scans all the files on the path, and makes sure we have entries
for them.
If option FAST is non-nil, then only parse a file for the mode-string
if that file is NEW, otherwise assume the mode has not changed."
(interactive)
;; When no map file, we are configured to not use a save file.
(if (not srecode-map-save-file)
;; 0) Create a MAP when in no save file mode.
(when (not srecode-current-map)
(setq srecode-current-map (srecode-map "SRecode Map"))
(message "SRecode map created in non-save mode.")
)
;; 1) Do we even have a MAP or save file?
(when (and (not srecode-current-map)
(not (file-exists-p srecode-map-save-file)))
(when (not (file-exists-p (file-name-directory srecode-map-save-file)))
;; Only bother with this interactively, not during a build
;; or test.
(when (not noninteractive)
;; No map, make the dir?
(if (y-or-n-p (format "Create dir %s? "
(file-name-directory srecode-map-save-file)))
(make-directory (file-name-directory srecode-map-save-file))
;; No make, change save file
(customize-variable 'srecode-map-save-file)
(error "Change your SRecode map file"))))
;; Have a dir. Make the object.
(setq srecode-current-map
(srecode-map "SRecode Map"
:file srecode-map-save-file)))
;; 2) Do we not have a current map? If so load.
(when (not srecode-current-map)
(setq srecode-current-map
(eieio-persistent-read srecode-map-save-file))
)
)
;;
;; We better have a MAP object now.
;;
(let ((dirty nil))
;; 3) - Purge dead files from the file list.
(dolist (entry (copy-sequence (oref srecode-current-map files)))
(when (not (srecode-map-file-still-valid-p
(car entry) srecode-current-map))
(srecode-map-delete-file-entry srecode-current-map (car entry))
(setq dirty t)
))
(dolist (app (copy-sequence (oref srecode-current-map apps)))
(dolist (entry (copy-sequence (cdr app)))
(when (not (srecode-map-file-still-valid-p
(car entry) srecode-current-map))
(srecode-map-delete-file-entry-from-app
srecode-current-map (car entry) (car app))
(setq dirty t)
)))
;; 4) - Find new files and add them to the map.
(dolist (dir srecode-map-load-path)
(when (file-exists-p dir)
(dolist (f (directory-files dir t "\\.srt$"))
(when (and (not (backup-file-name-p f))
(not (auto-save-file-name-p f))
(file-readable-p f))
(let ((fdirty (srecode-map-validate-file-for-mode f fast)))
(setq dirty (or dirty fdirty))))
)))
;; Only do the save if we are dirty, or if we are in an interactive
;; Emacs.
(when (and dirty (not noninteractive)
(slot-boundp srecode-current-map :file))
(eieio-persistent-save srecode-current-map))
))
(defun srecode-map-validate-file-for-mode (file fast)
"Read and validate FILE via the parser. Return the mode.
Argument FAST implies that the file should not be reparsed if there
is already an entry for it.
Return non-nil if the map changed."
(when (or (not fast)
(not (srecode-map-entry-for-file-anywhere srecode-current-map file)))
(let ((buff-orig (get-file-buffer file))
(dirty nil))
(save-excursion
(if buff-orig
(set-buffer buff-orig)
(set-buffer (get-buffer-create " *srecode-map-tmp*"))
(insert-file-contents file nil nil nil t)
;; Force it to be ready to parse.
(srecode-template-mode)
(let ((semantic-init-hooks nil))
(semantic-new-buffer-fcn))
)
(semantic-fetch-tags)
(let* ((mode-tag
(semantic-find-first-tag-by-name "mode" (current-buffer)))
(val nil)
(app-tag
(semantic-find-first-tag-by-name "application" (current-buffer)))
(app nil))
(if mode-tag
(setq val (car (semantic-tag-variable-default mode-tag)))
(error "There should be a mode declaration in %s" file))
(when app-tag
(setq app (car (semantic-tag-variable-default app-tag))))
(setq dirty
(if app
(srecode-map-update-app-file-entry srecode-current-map
file
(read val)
(read app))
(srecode-map-update-file-entry srecode-current-map
file
(read val))))
)
)
dirty)))
;;; THE PATH
;;
;; We need to do this last since the setter needs the above code.
(defun srecode-map-load-path-set (sym val)
"Set SYM to the new VAL, then update the srecode map."
(set-default sym val)
(srecode-map-update-map t))
(defcustom srecode-map-load-path
(list (srecode-map-base-template-dir)
(expand-file-name "~/.srecode/")
)
"*Global load path for SRecode template files."
:group 'srecode
:type '(repeat file)
:set 'srecode-map-load-path-set)
(provide 'srecode/map)
;; Local variables:
;; generated-autoload-file: "loaddefs.el"
;; generated-autoload-feature: srecode/loaddefs
;; generated-autoload-load-name: "srecode/map"
;; End:
;;; srecode/map.el ends here

420
lisp/cedet/srecode/mode.el Normal file
View file

@ -0,0 +1,420 @@
;;; srecode/mode.el --- Minor mode for managing and using SRecode templates
;; Copyright (C) 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:
;;
;; Minor mode for working with SRecode template files.
;;
;; Depends on Semantic for minor-mode convenience functions.
(require 'mode-local)
(require 'srecode)
(require 'srecode/insert)
(require 'srecode/find)
(require 'srecode/map)
;; (require 'senator)
(require 'semantic/decorate)
(require 'semantic/wisent)
(eval-when-compile (require 'semantic/find))
;;; Code:
(defcustom global-srecode-minor-mode nil
"Non-nil in buffers with Semantic Recoder macro keybindings."
:group 'srecode
:type 'boolean
:require 'srecode-mode
:initialize 'custom-initialize-default
:set (lambda (sym val)
(global-srecode-minor-mode (if val 1 -1))))
(defvar srecode-minor-mode nil
"Non-nil in buffers with Semantic Recoder macro keybindings.")
(make-variable-buffer-local 'srecode-minor-mode)
(defcustom srecode-minor-mode-hook nil
"Hook run at the end of the function `srecode-minor-mode'."
:group 'srecode
:type 'hook)
;; We don't want to waste space. There is a menu after all.
;;(add-to-list 'minor-mode-alist '(srecode-minor-mode ""))
(defvar srecode-prefix-key [(control ?c) ?/]
"The common prefix key in srecode minor mode.")
(defvar srecode-prefix-map
(let ((km (make-sparse-keymap)))
;; Basic template codes
(define-key km "/" 'srecode-insert)
(define-key km [insert] 'srecode-insert)
(define-key km "." 'srecode-insert-again)
(define-key km "E" 'srecode-edit)
;; Template indirect binding
(let ((k ?a))
(while (<= k ?z)
(define-key km (format "%c" k) 'srecode-bind-insert)
(setq k (1+ k))))
km)
"Keymap used behind the srecode prefix key in in srecode minor mode.")
(defvar srecode-menu-bar
(list
"SRecoder"
(senator-menu-item
["Insert Template"
srecode-insert
:active t
:help "Insert a template by name."
])
(senator-menu-item
["Insert Template Again"
srecode-insert-again
:active t
:help "Run the same template as last time again."
])
(senator-menu-item
["Edit Template"
srecode-edit
:active t
:help "Edit a template for this language by name."
])
"---"
'( "Insert ..." :filter srecode-minor-mode-templates-menu )
`( "Generate ..." :filter srecode-minor-mode-generate-menu )
"---"
(senator-menu-item
["Customize..."
(customize-group "srecode")
:active t
:help "Customize SRecode options"
])
(list
"Debugging Tools..."
(senator-menu-item
["Dump Template MAP"
srecode-get-maps
:active t
:help "Calculate (if needed) and display the current template file map."
])
(senator-menu-item
["Dump Tables"
srecode-dump-templates
:active t
:help "Dump the current template table."
])
(senator-menu-item
["Dump Dictionary"
srecode-dictionary-dump
:active t
:help "Calculate a dump a dictionary for point."
])
)
)
"Menu for srecode minor mode.")
(defvar srecode-minor-menu nil
"Menu keymap build from `srecode-menu-bar'.")
(defcustom srecode-takeover-INS-key nil
"Use the insert key for inserting templates."
:group 'srecode
:type 'boolean)
(defvar srecode-mode-map
(let ((km (make-sparse-keymap)))
(define-key km srecode-prefix-key srecode-prefix-map)
(easy-menu-define srecode-minor-menu km "Srecode Minor Mode Menu"
srecode-menu-bar)
(when srecode-takeover-INS-key
(define-key km [insert] srecode-prefix-map))
km)
"Keymap for srecode minor mode.")
;;;###autoload
(defun srecode-minor-mode (&optional arg)
"Toggle srecode minor mode.
With prefix argument ARG, turn on if positive, otherwise off. The
minor mode can be turned on only if semantic feature is available and
the current buffer was set up for parsing. Return non-nil if the
minor mode is enabled.
\\{srecode-mode-map}"
(interactive
(list (or current-prefix-arg
(if srecode-minor-mode 0 1))))
;; Flip the bits.
(setq srecode-minor-mode
(if arg
(>
(prefix-numeric-value arg)
0)
(not srecode-minor-mode)))
;; If we are turning things on, make sure we have templates for
;; this mode first.
(when srecode-minor-mode
(when (not (apply
'append
(mapcar (lambda (map)
(srecode-map-entries-for-mode map major-mode))
(srecode-get-maps))))
(setq srecode-minor-mode nil))
)
;; Run hooks if we are turning this on.
(when srecode-minor-mode
(run-hooks 'srecode-minor-mode-hook))
srecode-minor-mode)
;;;###autoload
(defun global-srecode-minor-mode (&optional arg)
"Toggle global use of srecode minor mode.
If ARG is positive, enable, if it is negative, disable.
If ARG is nil, then toggle."
(interactive "P")
(setq global-srecode-minor-mode
(semantic-toggle-minor-mode-globally
'srecode-minor-mode arg)))
;; Use the semantic minor mode magic stuff.
(semantic-add-minor-mode 'srecode-minor-mode "" srecode-mode-map)
;;; Menu Filters
;;
(defun srecode-minor-mode-templates-menu (menu-def)
"Create a menu item of cascading filters active for this mode.
MENU-DEF is the menu to bind this into."
;; Doing this SEGVs Emacs on windows.
;;(srecode-load-tables-for-mode major-mode)
(let* ((modetable (srecode-get-mode-table major-mode))
(subtab (when modetable (oref modetable :tables)))
(context nil)
(active nil)
(ltab nil)
(temp nil)
(alltabs nil)
)
(if (not subtab)
;; No tables, show a "load the tables" option.
(list (vector "Load Mode Tables..."
(lambda ()
(interactive)
(srecode-load-tables-for-mode major-mode))
))
;; Build something
(setq context (car-safe (srecode-calculate-context)))
(while subtab
(setq ltab (oref (car subtab) templates))
(while ltab
(setq temp (car ltab))
;; Do something with this template.
(let* ((ctxt (oref temp context))
(ctxtcons (assoc ctxt alltabs))
(bind (if (slot-boundp temp 'binding)
(oref temp binding)))
(name (object-name-string temp)))
(when (not ctxtcons)
(if (string= context ctxt)
;; If this context is not in the current list of contexts
;; is equal to the current context, then manage the
;; active list instead
(setq active
(setq ctxtcons (or active (cons ctxt nil))))
;; This is not an active context, add it to alltabs.
(setq ctxtcons (cons ctxt nil))
(setq alltabs (cons ctxtcons alltabs))))
(let ((new (vector
(if bind
(concat name " (" bind ")")
name)
`(lambda () (interactive)
(srecode-insert (concat ,ctxt ":" ,name)))
t)))
(setcdr ctxtcons (cons
new
(cdr ctxtcons)))))
(setq ltab (cdr ltab)))
(setq subtab (cdr subtab)))
;; Now create the menu
(easy-menu-filter-return
(easy-menu-create-menu
"Semantic Recoder Filters"
(append (cdr active)
alltabs)
))
)))
(defvar srecode-minor-mode-generators nil
"List of code generators to be displayed in the srecoder menu.")
(defun srecode-minor-mode-generate-menu (menu-def)
"Create a menu item of cascading filters active for this mode.
MENU-DEF is the menu to bind this into."
;; Doing this SEGVs Emacs on windows.
;;(srecode-load-tables-for-mode major-mode)
(let ((allgeneratorapps nil))
(dolist (gen srecode-minor-mode-generators)
(setq allgeneratorapps
(cons (vector (cdr gen) (car gen))
allgeneratorapps))
(message "Adding %S to srecode menu" (car gen))
)
(easy-menu-filter-return
(easy-menu-create-menu
"Semantic Recoder Generate Filters"
allgeneratorapps)))
)
;;; Minor Mode commands
;;
(defun srecode-bind-insert ()
"Bound insert for Srecode macros.
This command will insert whichever srecode template has a binding
to the current key."
(interactive)
(let* ((k last-command-event)
(ctxt (srecode-calculate-context))
;; Find the template with the binding K
(template (srecode-template-get-table-for-binding
(srecode-table) k ctxt)))
;; test it.
(when (not template)
(error "No template bound to %c" k))
;; insert
(srecode-insert template)
))
(defun srecode-edit (template-name)
"Switch to the template buffer for TEMPLATE-NAME.
Template is chosen based on the mode of the starting buffer."
;; @todo - Get a template stack from the last run template, and show
;; those too!
(interactive (list (srecode-read-template-name
"Template Name: "
(car srecode-read-template-name-history))))
(if (not (srecode-table))
(error "No template table found for mode %s" major-mode))
(let ((temp (srecode-template-get-table (srecode-table) template-name)))
(if (not temp)
(error "No Template named %s" template-name))
;; We need a template specific table, since tables chain.
(let ((tab (oref temp :table))
(names nil)
)
(find-file (oref tab :file))
(setq names (semantic-find-tags-by-name (oref temp :object-name)
(current-buffer)))
(cond ((= (length names) 1)
(semantic-go-to-tag (car names))
(semantic-momentary-highlight-tag (car names)))
((> (length names) 1)
(let* ((ctxt (semantic-find-tags-by-name (oref temp :context)
(current-buffer)))
(cls (semantic-find-tags-by-class 'context ctxt))
)
(while (and names
(< (semantic-tag-start (car names))
(semantic-tag-start (car cls))))
(setq names (cdr names)))
(if names
(progn
(semantic-go-to-tag (car names))
(semantic-momentary-highlight-tag (car names)))
(error "Can't find template %s" template-name))
))
(t (error "Can't find template %s" template-name)))
)))
(defun srecode-add-code-generator (function name &optional binding)
"Add the srecoder code generator FUNCTION with NAME to the menu.
Optional BINDING specifies the keybinding to use in the srecoder map.
BINDING should be a capital letter. Lower case letters are reserved
for individual templates.
Optional MODE specifies a major mode this function applies to.
Do not specify a mode if this function could be applied to most
programming modes."
;; Update the menu generating part.
(let ((remloop nil))
(while (setq remloop (assoc function srecode-minor-mode-generators))
(setq srecode-minor-mode-generators
(remove remloop srecode-minor-mode-generators))))
(add-to-list 'srecode-minor-mode-generators
(cons function name))
;; Remove this function from any old bindings.
(when binding
(let ((oldkey (where-is-internal function
(list srecode-prefix-map)
t t t)))
(if (or (not oldkey)
(and (= (length oldkey) 1)
(= (length binding) 1)
(= (aref oldkey 0) (aref binding 0))))
;; Its the same.
nil
;; Remove the old binding
(define-key srecode-prefix-map oldkey nil)
)))
;; Update Keybings
(let ((oldbinding (lookup-key srecode-prefix-map binding)))
;; During development, allow overrides.
(when (and oldbinding
(not (eq oldbinding function))
(or (eq this-command 'eval-defun) (eq this-command 'checkdoc-eval-defun))
(y-or-n-p (format "Override old binding %s? " oldbinding)))
(setq oldbinding nil))
(if (not oldbinding)
(define-key srecode-prefix-map binding function)
(if (eq function oldbinding)
nil
;; Not the same.
(message "Conflict binding %S binding to srecode map."
binding))))
)
;; Add default code generators:
(srecode-add-code-generator 'srecode-document-insert-comment "Comments" "C")
(srecode-add-code-generator 'srecode-insert-getset "Get/Set" "G")
(provide 'srecode/mode)
;; Local variables:
;; generated-autoload-file: "loaddefs.el"
;; generated-autoload-feature: srecode/loaddefs
;; generated-autoload-load-name: "srecode/mode"
;; End:
;;; srecode/mode.el ends here

431
lisp/cedet/srecode/semantic.el Normal file
View file

@ -0,0 +1,431 @@
;;; srecode/semantic.el --- Semantic specific extensions to SRecode.
;; 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:
;;
;; 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 'ring)
;;(require 'senator)
;;; 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.")
(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-overload srecode-semantic-apply-tag-to-dict (tagobj dict)
"Insert fewatures 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 it's parts into the dictionary.
(defun srecode-semantic-handle-:tag (dict)
"Add macroes 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)
"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
;; cf class 'type. Apply those parameters to the dictionary.
(defun srecode-semantic-handle-:tagtype (dict)
"Add macroes 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-overload 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 useing 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 occurance 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))
)
)
(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 overriden.
(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

775
lisp/cedet/srecode/srt-mode.el Normal file
View file

@ -0,0 +1,775 @@
;;; srecode/srt-mode.el --- Major mode for writing screcode macros
;; Copyright (C) 2005, 2007, 2008, 2009 Free Software Foundation, Inc.
;; 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:
;; Originally named srecode-template-mode.el in the CEDET repository.
(require 'srecode/compile)
(require 'srecode/ctxt)
(require 'srecode/template)
(require 'semantic)
(require 'semantic/analyze)
(require 'semantic/wisent)
(eval-when-compile
(require 'semantic/find))
(declare-function srecode-create-dictionary "srecode/dictionary")
(declare-function srecode-resolve-argument-list "srecode/insert")
;;; Code:
(defvar srecode-template-mode-syntax-table
(let ((table (make-syntax-table (standard-syntax-table))))
(modify-syntax-entry ?\; ". 12" table) ;; SEMI, Comment start ;;
(modify-syntax-entry ?\n ">" table) ;; Comment end
(modify-syntax-entry ?$ "." table) ;; Punctuation
(modify-syntax-entry ?: "." table) ;; Punctuation
(modify-syntax-entry ?< "." table) ;; Punctuation
(modify-syntax-entry ?> "." table) ;; Punctuation
(modify-syntax-entry ?# "." table) ;; Punctuation
(modify-syntax-entry ?! "." table) ;; Punctuation
(modify-syntax-entry ?? "." table) ;; Punctuation
(modify-syntax-entry ?\" "\"" table) ;; String
(modify-syntax-entry ?\- "_" table) ;; Symbol
(modify-syntax-entry ?\\ "\\" table) ;; Quote
(modify-syntax-entry ?\` "'" table) ;; Prefix ` (backquote)
(modify-syntax-entry ?\' "'" table) ;; Prefix ' (quote)
(modify-syntax-entry ?\, "'" table) ;; Prefix , (comma)
table)
"Syntax table used in semantic recoder macro buffers.")
(defface srecode-separator-face
'((t (:weight bold :strike-through t)))
"Face used for decorating separators in srecode template mode."
:group 'srecode)
(defvar srecode-font-lock-keywords
'(
;; Template
("^\\(template\\)\\s-+\\(\\w*\\)\\(\\( \\(:\\w+\\)\\|\\)+\\)$"
(1 font-lock-keyword-face)
(2 font-lock-function-name-face)
(3 font-lock-builtin-face ))
("^\\(sectiondictionary\\)\\s-+\""
(1 font-lock-keyword-face))
("^\\(bind\\)\\s-+\""
(1 font-lock-keyword-face))
;; Variable type setting
("^\\(set\\)\\s-+\\(\\w+\\)\\s-+"
(1 font-lock-keyword-face)
(2 font-lock-variable-name-face))
("^\\(show\\)\\s-+\\(\\w+\\)\\s-*$"
(1 font-lock-keyword-face)
(2 font-lock-variable-name-face))
("\\<\\(macro\\)\\s-+\""
(1 font-lock-keyword-face))
;; Context type setting
("^\\(context\\)\\s-+\\(\\w+\\)"
(1 font-lock-keyword-face)
(2 font-lock-builtin-face))
;; Prompting setting
("^\\(prompt\\)\\s-+\\(\\w+\\)"
(1 font-lock-keyword-face)
(2 font-lock-variable-name-face))
("\\(default\\(macro\\)?\\)\\s-+\\(\\(\\w\\|\\s_\\)+\\)"
(1 font-lock-keyword-face)
(3 font-lock-type-face))
("\\<\\(default\\(macro\\)?\\)\\>" (1 font-lock-keyword-face))
("\\<\\(read\\)\\s-+\\(\\(\\w\\|\\s_\\)+\\)"
(1 font-lock-keyword-face)
(2 font-lock-type-face))
;; Macro separators
("^----\n" 0 'srecode-separator-face)
;; Macro Matching
(srecode-template-mode-macro-escape-match 1 font-lock-string-face)
((lambda (limit)
(srecode-template-mode-font-lock-macro-helper
limit "\\(\\??\\w+\\)[^ \t\n{}$#@&*()]*"))
1 font-lock-variable-name-face)
((lambda (limit)
(srecode-template-mode-font-lock-macro-helper
limit "\\([#/]\\w+\\)[^ \t\n{}$#@&*()]*"))
1 font-lock-keyword-face)
((lambda (limit)
(srecode-template-mode-font-lock-macro-helper
limit "\\([<>]\\w*\\):\\(\\w+\\):\\(\\w+\\)"))
(1 font-lock-keyword-face)
(2 font-lock-builtin-face)
(3 font-lock-type-face))
((lambda (limit)
(srecode-template-mode-font-lock-macro-helper
limit "\\([<>?]?\\w*\\):\\(\\w+\\)"))
(1 font-lock-keyword-face)
(2 font-lock-type-face))
((lambda (limit)
(srecode-template-mode-font-lock-macro-helper
limit "!\\([^{}$]*\\)"))
1 font-lock-comment-face)
)
"Keywords for use with srecode macros and font-lock.")
(defun srecode-template-mode-font-lock-macro-helper (limit expression)
"Match against escape characters.
Don't scan past LIMIT. Match with EXPRESSION."
(let* ((done nil)
(md nil)
(es (regexp-quote (srecode-template-get-escape-start)))
(ee (regexp-quote (srecode-template-get-escape-end)))
(regex (concat es expression ee))
)
(while (not done)
(save-match-data
(if (re-search-forward regex limit t)
(when (equal (car (srecode-calculate-context)) "code")
(setq md (match-data)
done t))
(setq done t))))
(set-match-data md)
;; (when md (message "Found a match!"))
(when md t)))
(defun srecode-template-mode-macro-escape-match (limit)
"Match against escape characters.
Don't scan past LIMIT."
(let* ((done nil)
(md nil)
(es (regexp-quote (srecode-template-get-escape-start)))
(ee (regexp-quote (srecode-template-get-escape-end)))
(regex (concat "\\(" es "\\|" ee "\\)"))
)
(while (not done)
(save-match-data
(if (re-search-forward regex limit t)
(when (equal (car (srecode-calculate-context)) "code")
(setq md (match-data)
done t))
(setq done t))))
(set-match-data md)
;;(when md (message "Found a match!"))
(when md t)))
(defvar srecode-font-lock-macro-keywords nil
"Dynamically generated `font-lock' keywords for srecode templates.
Once the escape_start, and escape_end sequences are known, then
we can tell font lock about them.")
(defvar srecode-template-mode-map
(let ((km (make-sparse-keymap)))
(define-key km "\C-c\C-c" 'srecode-compile-templates)
(define-key km "\C-c\C-m" 'srecode-macro-help)
(define-key km "/" 'srecode-self-insert-complete-end-macro)
km)
"Keymap used in srecode mode.")
;;;###autoload
(defun srecode-template-mode ()
"Major-mode for writing srecode macros."
(interactive)
(kill-all-local-variables)
(setq major-mode 'srecode-template-mode
mode-name "SRecoder"
comment-start ";;"
comment-end "")
(set (make-local-variable 'parse-sexp-ignore-comments) t)
(set (make-local-variable 'comment-start-skip)
"\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *")
(set-syntax-table srecode-template-mode-syntax-table)
(use-local-map srecode-template-mode-map)
(set (make-local-variable 'font-lock-defaults)
'(srecode-font-lock-keywords
nil ;; perform string/comment fontification
nil ;; keywords are case sensitive.
;; This puts _ & - as a word constituant,
;; simplifying our keywords significantly
((?_ . "w") (?- . "w"))))
(run-hooks 'srecode-template-mode-hook))
;;;###autoload
(defalias 'srt-mode 'srecode-template-mode)
;;; Template Commands
;;
(defun srecode-self-insert-complete-end-macro ()
"Self insert the current key, then autocomplete the end macro."
(interactive)
(call-interactively 'self-insert-command)
(when (and (semantic-current-tag)
(semantic-tag-of-class-p (semantic-current-tag) 'function)
)
(let* ((es (srecode-template-get-escape-start))
(ee (srecode-template-get-escape-end))
(name (save-excursion
(forward-char (- (length es)))
(forward-char -1)
(if (looking-at (regexp-quote es))
(srecode-up-context-get-name (point) t))))
)
(when name
(insert name)
(insert ee))))
)
(defun srecode-macro-help ()
"Provide help for working with macros in a tempalte."
(interactive)
(let* ((root 'srecode-template-inserter)
(chl (aref (class-v root) class-children))
(ess (srecode-template-get-escape-start))
(ees (srecode-template-get-escape-end))
)
(with-output-to-temp-buffer "*SRecode Macros*"
(princ "Description of known SRecode Template Macros.")
(terpri)
(terpri)
(while chl
(let* ((C (car chl))
(name (symbol-name C))
(key (when (slot-exists-p C 'key)
(oref C key)))
(showexample t)
)
(setq chl (cdr chl))
(setq chl (append (aref (class-v C) class-children) chl))
(catch 'skip
(when (eq C 'srecode-template-inserter-section-end)
(throw 'skip nil))
(when (class-abstract-p C)
(throw 'skip nil))
(princ "`")
(princ name)
(princ "'")
(when (slot-exists-p C 'key)
(when key
(princ " - Character Key: ")
(if (stringp key)
(progn
(setq showexample nil)
(cond ((string= key "\n")
(princ "\"\\n\"")
)
(t
(prin1 key)
)))
(prin1 (format "%c" key))
)))
(terpri)
(princ (documentation-property C 'variable-documentation))
(terpri)
(when showexample
(princ "Example:")
(terpri)
(srecode-inserter-prin-example C ess ees)
)
(terpri)
) ;; catch
);; let*
))))
;;; Misc Language Overrides
;;
(define-mode-local-override semantic-ia-insert-tag
srecode-template-mode (tag)
"Insert the SRecode TAG into the current buffer."
(insert (semantic-tag-name tag)))
;;; Local Context Parsing.
(defun srecode-in-macro-p (&optional point)
"Non-nil if POINT is inside a macro bounds.
If the ESCAPE_START and END are different sequences,
a simple search is used. If ESCAPE_START and END are the same
characteres, start at the beginning of the line, and find out
how many occur."
(let ((tag (semantic-current-tag))
(es (regexp-quote (srecode-template-get-escape-start)))
(ee (regexp-quote (srecode-template-get-escape-end)))
(start (or point (point)))
)
(when (and tag (semantic-tag-of-class-p tag 'function))
(if (string= es ee)
(save-excursion
(beginning-of-line)
(while (re-search-forward es start t 2))
(if (re-search-forward es start t)
;; If there is a single, the the answer is yes.
t
;; If there wasn't another, then the answer is no.
nil)
)
;; ES And EE are not the same.
(save-excursion
(and (re-search-backward es (semantic-tag-start tag) t)
(>= (or (re-search-forward ee (semantic-tag-end tag) t)
;; No end match means an incomplete macro.
start)
start)))
))))
(defun srecode-up-context-get-name (&optional point find-unmatched)
"Move up one context as for `semantic-up-context', and return the name.
Moves point to the opening characters of the section macro text.
If there is no upper context, return nil.
Starts at POINT if provided.
If FIND-UNMATCHED is specified as non-nil, then we are looking for an unmatched
section."
(when point (goto-char (point)))
(let* ((tag (semantic-current-tag))
(es (regexp-quote (srecode-template-get-escape-start)))
(start (concat es "[#<]\\(\\w+\\)"))
(orig (point))
(name nil)
(res nil))
(when (semantic-tag-of-class-p tag 'function)
(while (and (not res)
(re-search-backward start (semantic-tag-start tag) t))
(when (save-excursion
(setq name (match-string 1))
(let ((endr (concat es "/" name)))
(if (re-search-forward endr (semantic-tag-end tag) t)
(< orig (point))
(if (not find-unmatched)
(error "Unmatched Section Template")
;; We found what we want.
t))))
(setq res (point)))
)
;; Restore in no result found.
(goto-char (or res orig))
name)))
(define-mode-local-override semantic-up-context
srecode-template-mode (&optional point)
"Move up one context in the current code.
Moves out one named section."
(not (srecode-up-context-get-name point)))
(define-mode-local-override semantic-beginning-of-context
srecode-template-mode (&optional point)
"Move to the beginning of the current context.
Moves the the beginning of one named section."
(if (semantic-up-context point)
t
(let ((es (regexp-quote (srecode-template-get-escape-start)))
(ee (regexp-quote (srecode-template-get-escape-end))))
(re-search-forward es) ;; move over the start chars.
(re-search-forward ee) ;; Move after the end chars.
nil)))
(define-mode-local-override semantic-end-of-context
srecode-template-mode (&optional point)
"Move to the beginning of the current context.
Moves the the beginning of one named section."
(let ((name (srecode-up-context-get-name point))
(tag (semantic-current-tag))
(es (regexp-quote (srecode-template-get-escape-start))))
(if (not name)
t
(unless (re-search-forward (concat es "/" name) (semantic-tag-end tag) t)
(error "Section %s has no end" name))
(goto-char (match-beginning 0))
nil)))
(define-mode-local-override semantic-get-local-variables
srecode-template-mode (&optional point)
"Get local variables from an SRecode template."
(save-excursion
(when point (goto-char (point)))
(let* ((tag (semantic-current-tag))
(name (save-excursion
(srecode-up-context-get-name (point))))
(subdicts (semantic-tag-get-attribute tag :dictionaries))
(global nil)
)
(dolist (D subdicts)
(setq global (cons (semantic-tag-new-variable (car D) nil)
global)))
(if name
;; Lookup any subdictionaries in TAG.
(let ((res nil))
(while (and (not res) subdicts)
;; Find the subdictionary with the same name. Those variables
;; are now local to this section.
(when (string= (car (car subdicts)) name)
(setq res (cdr (car subdicts))))
(setq subdicts (cdr subdicts)))
;; Pre-pend our global vars.
(append global res))
;; If we aren't in a subsection, just do the global variables
global
))))
(define-mode-local-override semantic-get-local-arguments
srecode-template-mode (&optional point)
"Get local arguments from an SRecode template."
(require 'srecode/insert)
(save-excursion
(when point (goto-char (point)))
(let* ((tag (semantic-current-tag))
(args (semantic-tag-function-arguments tag))
(argsym (mapcar 'intern args))
(argvars nil)
;; Create a temporary dictionary in which the
;; arguments can be resolved so we can extract
;; the results.
(dict (srecode-create-dictionary t))
)
;; Resolve args into our temp dictionary
(srecode-resolve-argument-list argsym dict)
(maphash
(lambda (key entry)
(setq argvars
(cons (semantic-tag-new-variable key nil entry)
argvars)))
(oref dict namehash))
argvars)))
(define-mode-local-override semantic-ctxt-current-symbol
srecode-template-mode (&optional point)
"Return the current symbol under POINT.
Return nil if point is not on/in a template macro."
(let ((macro (srecode-parse-this-macro point)))
(cdr macro))
)
(defun srecode-parse-this-macro (&optional point)
"Return the current symbol under POINT.
Return nil if point is not on/in a template macro.
The first element is the key for the current macro, such as # for a
section or ? for an ask variable."
(save-excursion
(if point (goto-char point))
(let ((tag (semantic-current-tag))
(es (regexp-quote (srecode-template-get-escape-start)))
(ee (regexp-quote (srecode-template-get-escape-end)))
(start (point))
(macrostart nil)
(raw nil)
)
(when (and tag (semantic-tag-of-class-p tag 'function)
(srecode-in-macro-p point)
(re-search-backward es (semantic-tag-start tag) t))
(setq macrostart (match-end 0))
(goto-char macrostart)
;; We have a match
(when (not (re-search-forward ee (semantic-tag-end tag) t))
(goto-char start) ;; Pretend we are ok for completion
(set-match-data (list start start))
)
(if (> start (point))
;; If our starting point is after the found point, that
;; means we are not inside the macro. Retur nil.
nil
;; We are inside the macro, extract the text so far.
(let* ((macroend (match-beginning 0))
(raw (buffer-substring-no-properties
macrostart macroend))
(STATE (srecode-compile-state "TMP"))
(inserter (condition-case nil
(srecode-compile-parse-inserter
raw STATE)
(error nil)))
)
(when inserter
(let ((base
(cons (oref inserter :object-name)
(if (and (slot-boundp inserter :secondname)
(oref inserter :secondname))
(split-string (oref inserter :secondname)
":")
nil)))
(key (oref inserter key)))
(cond ((null key)
;; A plain variable
(cons nil base))
(t
;; A complex variable thingy.
(cons (format "%c" key)
base)))))
)
)))
))
(define-mode-local-override semantic-analyze-current-context
srecode-template-mode (point)
"Provide a Semantic analysis in SRecode template mode."
(let* ((context-return nil)
(prefixandbounds (semantic-ctxt-current-symbol-and-bounds))
(prefix (car prefixandbounds))
(bounds (nth 2 prefixandbounds))
(key (car (srecode-parse-this-macro (point))))
(prefixsym nil)
(prefix-var nil)
(prefix-context nil)
(prefix-function nil)
(prefixclass (semantic-ctxt-current-class-list))
(globalvar (semantic-find-tags-by-class 'variable (current-buffer)))
(argtype 'macro)
(scope (semantic-calculate-scope point))
)
(oset scope fullscope (append (oref scope localvar) globalvar))
(when prefix
;; First, try to find the variable for the first
;; entry in the prefix list.
(setq prefix-var (semantic-find-first-tag-by-name
(car prefix) (oref scope fullscope)))
(cond
((and (or (not key) (string= key "?"))
(> (length prefix) 1))
;; Variables can have lisp function names.
(with-mode-local emacs-lisp-mode
(let ((fcns (semanticdb-find-tags-by-name (car (last prefix)))))
(setq prefix-function (car (semanticdb-find-result-nth fcns 0)))
(setq argtype 'elispfcn)))
)
((or (string= key "<") (string= key ">"))
;; Includes have second args that is the template name.
(if (= (length prefix) 3)
(let ((contexts (semantic-find-tags-by-class
'context (current-buffer))))
(setq prefix-context
(or (semantic-find-first-tag-by-name
(nth 1 prefix) contexts)
;; Calculate from location
(semantic-tag
(symbol-name
(srecode-template-current-context))
'context)))
(setq argtype 'template))
(setq prefix-context
;; Calculate from location
(semantic-tag
(symbol-name (srecode-template-current-context))
'context))
(setq argtype 'template)
)
;; The last one?
(when (> (length prefix) 1)
(let ((toc (srecode-template-find-templates-of-context
(read (semantic-tag-name prefix-context))))
)
(setq prefix-function
(or (semantic-find-first-tag-by-name
(car (last prefix)) toc)
;; Not in this buffer? Search the master
;; templates list.
nil))
))
)
)
(setq prefixsym
(cond ((= (length prefix) 3)
(list (or prefix-var (nth 0 prefix))
(or prefix-context (nth 1 prefix))
(or prefix-function (nth 2 prefix))))
((= (length prefix) 2)
(list (or prefix-var (nth 0 prefix))
(or prefix-function (nth 1 prefix))))
((= (length prefix) 1)
(list (or prefix-var (nth 0 prefix)))
)))
(setq context-return
(semantic-analyze-context-functionarg
"context-for-srecode"
:buffer (current-buffer)
:scope scope
:bounds bounds
:prefix (or prefixsym
prefix)
:prefixtypes nil
:prefixclass prefixclass
:errors nil
;; Use the functionarg analyzer class so we
;; can save the current key, and the index
;; into the macro part we are completing on.
:function (list key)
:index (length prefix)
:argument (list argtype)
))
context-return)))
(define-mode-local-override semantic-analyze-possible-completions
srecode-template-mode (context)
"Return a list of possible completions based on NONTEXT."
(save-excursion
(set-buffer (oref context buffer))
(let* ((prefix (car (last (oref context :prefix))))
(prefixstr (cond ((stringp prefix)
prefix)
((semantic-tag-p prefix)
(semantic-tag-name prefix))))
; (completetext (cond ((semantic-tag-p prefix)
; (semantic-tag-name prefix))
; ((stringp prefix)
; prefix)
; ((stringp (car prefix))
; (car prefix))))
(argtype (car (oref context :argument)))
(matches nil))
;; Depending on what the analyzer is, we have different ways
;; of creating completions.
(cond ((eq argtype 'template)
(setq matches (semantic-find-tags-for-completion
prefixstr (current-buffer)))
(setq matches (semantic-find-tags-by-class
'function matches))
)
((eq argtype 'elispfcn)
(with-mode-local emacs-lisp-mode
(setq matches (semanticdb-find-tags-for-completion
prefixstr))
(setq matches (semantic-find-tags-by-class
'function matches))
)
)
((eq argtype 'macro)
(let ((scope (oref context scope)))
(setq matches
(semantic-find-tags-for-completion
prefixstr (oref scope fullscope))))
)
)
matches)))
;;; Utils
;;
(defun srecode-template-get-mode ()
"Get the supported major mode for this template file."
(let ((m (semantic-find-first-tag-by-name "mode" (current-buffer))))
(when m (read (semantic-tag-variable-default m)))))
(defun srecode-template-get-escape-start ()
"Get the current escape_start characters."
(let ((es (semantic-find-first-tag-by-name "escape_start" (current-buffer)))
)
(if es (car (semantic-tag-get-attribute es :default-value))
"{{")))
(defun srecode-template-get-escape-end ()
"Get the current escape_end characters."
(let ((ee (semantic-find-first-tag-by-name "escape_end" (current-buffer)))
)
(if ee (car (semantic-tag-get-attribute ee :default-value))
"}}")))
(defun srecode-template-current-context (&optional point)
"Calculate the context encompassing POINT."
(save-excursion
(when point (goto-char (point)))
(let ((ct (semantic-current-tag)))
(when (not ct)
(setq ct (semantic-find-tag-by-overlay-prev)))
;; Loop till we find the context.
(while (and ct (not (semantic-tag-of-class-p ct 'context)))
(setq ct (semantic-find-tag-by-overlay-prev
(semantic-tag-start ct))))
(if ct
(read (semantic-tag-name ct))
'declaration))))
(defun srecode-template-find-templates-of-context (context &optional buffer)
"Find all the templates belonging to a particular CONTEXT.
When optional BUFFER is provided, search that buffer."
(save-excursion
(when buffer (set-buffer buffer))
(let ((tags (semantic-fetch-available-tags))
(cc 'declaration)
(scan nil)
(ans nil))
(when (eq cc context)
(setq scan t))
(dolist (T tags)
;; Handle contexts
(when (semantic-tag-of-class-p T 'context)
(setq cc (read (semantic-tag-name T)))
(when (eq cc context)
(setq scan t)))
;; Scan
(when (and scan (semantic-tag-of-class-p T 'function))
(setq ans (cons T ans)))
)
(nreverse ans))))
;;; MMM-Mode support ??
;;(condition-case nil
;; (require 'mmm-mode)
;; (error (message "SRecoder Template Mode: No multi-mode not support.")))
;;
;;(defun srecode-template-add-submode ()
;; "Add a submode to the current template file using mmm-mode.
;;If mmm-mode isn't available, then do nothing."
;; (if (not (featurep 'mmm-mode))
;; nil ;; Nothing to do.
;; ;; Else, set up mmm-mode in this buffer.
;; (let ((submode (semantic-find-tags-by-name "mode")))
;; (if (not submode)
;; nil ;; Nothing to do.
;; ;; Well, we have a mode, lets try turning on mmm-mode.
;;
;; ;; (mmm-mode-on)
;;
;;
;;
;; ))))
;;
(provide 'srecode/srt-mode)
;; The autoloads in this file must go into the global loaddefs.el, not
;; the srecode one, so that srecode-template-mode can be called from
;; auto-mode-alist.
;; Local variables:
;; generated-autoload-load-name: "srecode/srt-mode"
;; End:
;;; srecode/srt-mode.el ends here

277
lisp/cedet/srecode/srt-wy.el Normal file
View file

@ -0,0 +1,277 @@
;;; srecode/srt-wy.el --- Generated parser support file
;; Copyright (C) 2005, 2007, 2008, 2009 Free Software Foundation, Inc.
;; 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:
;; Generated from srecode-template.wy in the CEDET repository.
;;; Code:
(require 'semantic/lex)
;;; Prologue
;;
;;; Declarations
;;
(defconst srecode-template-wy--keyword-table
(semantic-lex-make-keyword-table
'(("set" . SET)
("show" . SHOW)
("macro" . MACRO)
("context" . CONTEXT)
("template" . TEMPLATE)
("sectiondictionary" . SECTIONDICTIONARY)
("prompt" . PROMPT)
("default" . DEFAULT)
("defaultmacro" . DEFAULTMACRO)
("read" . READ)
("bind" . BIND))
'(("bind" summary "bind \"<letter>\"")
("read" summary "prompt <symbol> \"Describe Symbol: \" [default[macro] <lispsym>|\"valuetext\"] [read <lispsym>]")
("defaultmacro" summary "prompt <symbol> \"Describe Symbol: \" [default[macro] <lispsym>|\"valuetext\"] [read <lispsym>]")
("default" summary "prompt <symbol> \"Describe Symbol: \" [default[macro] <lispsym>|\"valuetext\"] [read <lispsym>]")
("prompt" summary "prompt <symbol> \"Describe Symbol: \" [default[macro] <lispsym>|\"valuetext\"] [read <lispsym>]")
("sectiondictionary" summary "sectiondictionary <name>\\n <dictionary entries>")
("template" summary "template <name>\\n <template definition>")
("context" summary "context <name>")
("macro" summary "... macro \"string\" ...")
("show" summary "show <name> ; to show a section")
("set" summary "set <name> <value>")))
"Table of language keywords.")
(defconst srecode-template-wy--token-table
(semantic-lex-make-type-table
'(("number"
(number))
("string"
(string))
("symbol"
(symbol))
("property"
(property))
("separator"
(TEMPLATE_BLOCK . "^----"))
("newline"
(newline)))
'(("number" :declared t)
("string" :declared t)
("symbol" :declared t)
("property" :declared t)
("newline" :declared t)
("punctuation" syntax "\\s.+")
("punctuation" :declared t)
("keyword" :declared t)))
"Table of lexical tokens.")
(defconst srecode-template-wy--parse-table
(progn
(eval-when-compile
(require 'semantic/wisent/comp))
(wisent-compile-grammar
'((SET SHOW MACRO CONTEXT TEMPLATE SECTIONDICTIONARY PROMPT DEFAULT DEFAULTMACRO READ BIND newline TEMPLATE_BLOCK property symbol string number)
nil
(template_file
((newline)
nil)
((context))
((prompt))
((variable))
((template)))
(context
((CONTEXT symbol newline)
(wisent-raw-tag
(semantic-tag $2 'context))))
(prompt
((PROMPT symbol string opt-default-fcn opt-read-fcn newline)
(wisent-raw-tag
(semantic-tag $2 'prompt :text
(read $3)
:default $4 :read $5))))
(opt-default-fcn
((DEFAULT symbol)
(progn
(read $2)))
((DEFAULT string)
(progn
(read $2)))
((DEFAULTMACRO string)
(progn
(cons 'macro
(read $2))))
(nil nil))
(opt-read-fcn
((READ symbol)
(progn
(read $2)))
(nil nil))
(variable
((SET symbol insertable-string-list newline)
(wisent-raw-tag
(semantic-tag-new-variable $2 nil $3)))
((SHOW symbol newline)
(wisent-raw-tag
(semantic-tag-new-variable $2 nil t))))
(insertable-string-list
((insertable-string)
(list $1))
((insertable-string-list insertable-string)
(append $1
(list $2))))
(insertable-string
((string)
(read $1))
((MACRO string)
(cons 'macro
(read $2))))
(template
((TEMPLATE templatename opt-dynamic-arguments newline opt-string opt-section-dictionaries TEMPLATE_BLOCK newline opt-bind)
(wisent-raw-tag
(semantic-tag-new-function $2 nil $3 :documentation $5 :code $7 :dictionaries $6 :binding $9))))
(templatename
((symbol))
((PROMPT))
((CONTEXT))
((TEMPLATE))
((DEFAULT))
((MACRO))
((DEFAULTMACRO))
((READ))
((SET)))
(opt-dynamic-arguments
((property opt-dynamic-arguments)
(cons $1 $2))
(nil nil))
(opt-string
((string newline)
(read $1))
(nil nil))
(opt-section-dictionaries
(nil nil)
((section-dictionary-list)))
(section-dictionary-list
((one-section-dictionary)
(list $1))
((section-dictionary-list one-section-dictionary)
(append $1
(list $2))))
(one-section-dictionary
((SECTIONDICTIONARY string newline variable-list)
(cons
(read $2)
$4)))
(variable-list
((variable)
(wisent-cook-tag $1))
((variable-list variable)
(append $1
(wisent-cook-tag $2))))
(opt-bind
((BIND string newline)
(read $2))
(nil nil)))
'(template_file)))
"Parser table.")
(defun srecode-template-wy--install-parser ()
"Setup the Semantic Parser."
(semantic-install-function-overrides
'((parse-stream . wisent-parse-stream)))
(setq semantic-parser-name "LALR"
semantic--parse-table srecode-template-wy--parse-table
semantic-debug-parser-source "srecode-template.wy"
semantic-flex-keywords-obarray srecode-template-wy--keyword-table
semantic-lex-types-obarray srecode-template-wy--token-table)
;; Collect unmatched syntax lexical tokens
(semantic-make-local-hook 'wisent-discarding-token-functions)
(add-hook 'wisent-discarding-token-functions
'wisent-collect-unmatched-syntax nil t))
;;; Analyzers
;;
(define-lex-keyword-type-analyzer srecode-template-wy--<keyword>-keyword-analyzer
"keyword analyzer for <keyword> tokens."
"\\(\\sw\\|\\s_\\)+")
(define-lex-regex-type-analyzer srecode-template-wy--<symbol>-regexp-analyzer
"regexp analyzer for <symbol> tokens."
"\\(\\sw\\|\\s_\\)+"
nil
'symbol)
(define-lex-sexp-type-analyzer srecode-template-wy--<string>-sexp-analyzer
"sexp analyzer for <string> tokens."
"\\s\""
'string)
(define-lex-regex-type-analyzer srecode-template-wy--<number>-regexp-analyzer
"regexp analyzer for <number> tokens."
semantic-lex-number-expression
nil
'number)
(define-lex-string-type-analyzer srecode-template-wy--<punctuation>-string-analyzer
"string analyzer for <punctuation> tokens."
"\\s.+"
nil
'punctuation)
;;; Epilogue
;;
(define-lex-simple-regex-analyzer srecode-template-property-analyzer
"Detect and create a dynamic argument properties."
":\\(\\w\\|\\s_\\)*" 'property 0)
(define-lex-regex-analyzer srecode-template-separator-block
"Detect and create a template quote block."
"^----\n"
(semantic-lex-push-token
(semantic-lex-token
'TEMPLATE_BLOCK
(match-end 0)
(semantic-lex-unterminated-syntax-protection 'TEMPLATE_BLOCK
(goto-char (match-end 0))
(re-search-forward "^----$")
(match-beginning 0))))
(setq semantic-lex-end-point (point)))
(define-lex wisent-srecode-template-lexer
"Lexical analyzer that handles SRecode Template buffers.
It ignores whitespace, newlines and comments."
semantic-lex-newline
semantic-lex-ignore-whitespace
semantic-lex-ignore-newline
semantic-lex-ignore-comments
srecode-template-separator-block
srecode-template-wy--<keyword>-keyword-analyzer
srecode-template-property-analyzer
srecode-template-wy--<symbol>-regexp-analyzer
srecode-template-wy--<number>-regexp-analyzer
srecode-template-wy--<string>-sexp-analyzer
srecode-template-wy--<punctuation>-string-analyzer
semantic-lex-default-action
)
(provide 'srecode/srt-wy)
;;; srecode/srt-wy.el ends here

106
lisp/cedet/srecode/srt.el Normal file
View file

@ -0,0 +1,106 @@
;;; srecode/srt.el --- argument handlers for SRT files
;; Copyright (C) 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:
;;
;; Filters for SRT files, the Semantic Recoder template files.
;;; Code:
(require 'eieio)
(require 'srecode/dictionary)
(require 'srecode/insert)
(defvar srecode-read-variable-name-history nil
"History for `srecode-read-variable-name'.")
(defun srecode-read-variable-name (prompt &optional initial hist default)
"Read in the name of a declaired variable in the current SRT file.
PROMPT is the prompt to use.
INITIAL is the initial string.
HIST is the history value, otherwise `srecode-read-variable-name-history'
is used.
DEFAULT is the default if RET is hit."
(let* ((newdict (srecode-create-dictionary))
(currfcn (semantic-current-tag))
)
(srecode-resolve-argument-list
(mapcar 'read
(semantic-tag-get-attribute currfcn :arguments))
newdict)
(with-slots (namehash) newdict
(completing-read prompt namehash nil nil initial
(or hist 'srecode-read-variable-name-history)
default))
))
(defvar srecode-read-major-mode-history nil
"History for `srecode-read-variable-name'.")
(defun srecode-read-major-mode-name (prompt &optional initial hist default)
"Read in the name of a desired `major-mode'.
PROMPT is the prompt to use.
INITIAL is the initial string.
HIST is the history value, otherwise `srecode-read-variable-name-history'
is used.
DEFAULT is the default if RET is hit."
(completing-read prompt obarray
(lambda (s) (string-match "-mode$" (symbol-name s)))
nil initial (or hist 'srecode-read-major-mode-history))
)
(defun srecode-semantic-handle-:srt (dict)
"Add macros into the dictionary DICT based on the current SRT file.
Adds the following:
ESCAPE_START - This files value of escape_start
ESCAPE_END - This files value of escape_end
MODE - The mode of this buffer. If not declared yet, guess."
(let* ((es (semantic-find-first-tag-by-name "escape_start" (current-buffer)))
(ee (semantic-find-first-tag-by-name "escape_end" (current-buffer)))
(mode-var (semantic-find-first-tag-by-name "mode" (current-buffer)))
(mode (if mode-var
(semantic-tag-variable-default mode-var)
nil))
)
(srecode-dictionary-set-value dict "ESCAPE_START"
(if es
(car (semantic-tag-variable-default es))
"{{"))
(srecode-dictionary-set-value dict "ESCAPE_END"
(if ee
(car (semantic-tag-variable-default ee))
"}}"))
(when (not mode)
(let* ((fname (file-name-nondirectory
(buffer-file-name (current-buffer))))
)
(when (string-match "-\\(\\w+\\)\\.srt" fname)
(setq mode (concat (match-string 1 fname) "-mode")))))
(when mode
(srecode-dictionary-set-value dict "MAJORMODE" mode))
))
(provide 'srecode/srt)
;;; srecode/srt.el ends here

248
lisp/cedet/srecode/table.el Normal file
View file

@ -0,0 +1,248 @@
;;; srecode/table.el --- Tables of Semantic Recoders
;; 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:
;;
;; Semantic Recoder tables manage lists of templates and the major
;; modes they are associated with.
;;
(require 'eieio)
(require 'eieio-base)
(require 'mode-local)
(require 'srecode)
(declare-function srecode-load-tables-for-mode "srecode/find")
;;; Code:
;;; TEMPLATE TABLE
;;
(defclass srecode-template-table ()
(;;
;; Raw file tracking
;;
(file :initarg :file
:type string
:documentation
"The name of the file this table was built from.")
(filesize :initarg :filesize
:type number
:documentation
"The size of the file when it was parsed.")
(filedate :initarg :filedate
:type cons
:documentation
"Date from the inode of the file when it was last edited.
Format is from the `file-attributes' function.")
(major-mode :initarg :major-mode
:documentation
"The major mode this table of templates is associated with.")
;;
;; Template file sorting data
;;
(application :initarg :application
:type symbol
:documentation
"Tracks the name of the application these templates belong to.
If this is nil, then this template table belongs to a set of generic
templates that can be used with no additional dictionary values.
When it is non-nil, it is assumed the template macros need specialized
Emacs Lisp code to fill in the dictoinary.")
(priority :initarg :priority
:type number
:documentation
"For file of this Major Mode, what is the priority of this file.
When there are multiple template files with similar names, templates with
the highest priority are scanned last, allowing them to override values in
previous template files.")
;;
;; Parsed Data from the template file
;;
(templates :initarg :templates
:type list
:documentation
"The list of templates compiled into this table.")
(namehash :initarg :namehash
:documentation
"Hash table containing the names of all the templates.")
(contexthash :initarg :contexthash
:documentation
"")
(variables :initarg :variables
:documentation
"AList of variables.
These variables are used to initialize dictionaries.")
)
"Semantic recoder template table.
A Table contains all templates from a single .srt file.
Tracks various lookup hash tables.")
;;; MODE TABLE
;;
(defvar srecode-mode-table-list nil
"List of all the SRecode mode table classes that have been built.")
(defclass srecode-mode-table (eieio-instance-tracker)
((tracking-symbol :initform 'srecode-mode-table-list)
(major-mode :initarg :major-mode
:documentation
"Table of template tables for this major-mode.")
(tables :initarg :tables
:documentation
"All the tables that have been defined for this major mode.")
)
"Track template tables for a particular major mode.
Tracks all the template-tables for a specific major mode.")
(defun srecode-get-mode-table (mode)
"Get the SRecoder mode table for the major mode MODE.
Optional argument SOFT indicates to not make a new one if a table
was not found."
(let ((ans nil))
(while (and (not ans) mode)
(setq ans (eieio-instance-tracker-find
mode 'major-mode 'srecode-mode-table-list)
mode (get-mode-local-parent mode)))
ans))
(defun srecode-make-mode-table (mode)
"Get the SRecoder mode table for the major mode MODE."
(let ((old (eieio-instance-tracker-find
mode 'major-mode 'srecode-mode-table-list)))
(if old
old
(let* ((ms (if (stringp mode) mode (symbol-name mode)))
(new (srecode-mode-table ms
:major-mode mode
:tables nil)))
;; Save this new mode table in that mode's variable.
(eval `(setq-mode-local ,mode srecode-table ,new))
new))))
(defmethod srecode-mode-table-find ((mt srecode-mode-table) file)
"Look in the mode table MT for a template table from FILE.
Return nil if there was none."
(object-assoc file 'file (oref mt tables)))
(defun srecode-mode-table-new (mode file &rest init)
"Create a new template table for MODE in FILE.
INIT are the initialization parametrs for the new template table."
(let* ((mt (srecode-make-mode-table mode))
(old (srecode-mode-table-find mt file))
(attr (file-attributes file))
(new (apply 'srecode-template-table
(file-name-nondirectory file)
:file file
:filesize (nth 7 attr)
:filedate (nth 5 attr)
:major-mode mode
init
)))
;; Whack the old table.
(when old (object-remove-from-list mt 'tables old))
;; Add the new table
(object-add-to-list mt 'tables new)
;; Sort the list in reverse order. When other routines
;; go front-to-back, the highest priority items are put
;; into the search table first, allowing lower priority items
;; to be the items found in the search table.
(object-sort-list mt 'tables (lambda (a b)
(> (oref a :priority)
(oref b :priority))))
;; Return it.
new))
(defun object-sort-list (object slot predicate)
"Sort the items in OBJECT's SLOT.
Use PREDICATE is the same as for the `sort' function."
(when (slot-boundp object slot)
(when (listp (eieio-oref object slot))
(eieio-oset object slot (sort (eieio-oref object slot) predicate)))))
;;; DEBUG
;;
;; Dump out information about the current srecoder compiled templates.
;;
(defun srecode-dump-templates (mode)
"Dump a list of the current templates for MODE."
(interactive "sMode: ")
(require 'srecode/find)
(let ((modesym (cond ((string= mode "")
major-mode)
((not (string-match "-mode" mode))
(intern-soft (concat mode "-mode")))
(t
(intern-soft mode)))))
(srecode-load-tables-for-mode modesym)
(let ((tmp (srecode-get-mode-table modesym))
)
(if (not tmp)
(error "No table found for mode %S" modesym))
(with-output-to-temp-buffer "*SRECODE DUMP*"
(srecode-dump tmp))
)))
(defmethod srecode-dump ((tab srecode-mode-table))
"Dump the contents of the SRecode mode table TAB."
(princ "MODE TABLE FOR ")
(princ (oref tab :major-mode))
(princ "\n--------------------------------------------\n\nNumber of tables: ")
(let ((subtab (oref tab :tables)))
(princ (length subtab))
(princ "\n\n")
(while subtab
(srecode-dump (car subtab))
(setq subtab (cdr subtab)))
))
(defmethod srecode-dump ((tab srecode-template-table))
"Dump the contents of the SRecode template table TAB."
(princ "Template Table for ")
(princ (object-name-string tab))
(princ "\nPriority: ")
(prin1 (oref tab :priority))
(when (oref tab :application)
(princ "\nApplication: ")
(princ (oref tab :application)))
(princ "\n\nVariables:\n")
(let ((vars (oref tab variables)))
(while vars
(princ (car (car vars)))
(princ "\t")
(if (< (length (car (car vars))) 9)
(princ "\t"))
(prin1 (cdr (car vars)))
(princ "\n")
(setq vars (cdr vars))))
(princ "\n\nTemplates:\n")
(let ((temp (oref tab templates)))
(while temp
(srecode-dump (car temp))
(setq temp (cdr temp))))
)
(provide 'srecode/table)
;;; srecode/table.el ends here

69
lisp/cedet/srecode/template.el Normal file
View file

@ -0,0 +1,69 @@
;;; srecode-template.el --- SRecoder template language parser support.
;;; Copyright (C) 2005, 2007, 2008 Free Software Foundation, Inc.
;; 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:
;;
;; Parser setup for the semantic recoder template parser.
;;; Code:
(require 'semantic)
(require 'semantic/ctxt)
(require 'semantic/wisent)
(require 'srecode/srt-wy)
(define-mode-local-override semantic-tag-components
srecode-template-mode (tag)
"Return sectiondictionary tags."
(when (semantic-tag-of-class-p tag 'function)
(let ((dicts (semantic-tag-get-attribute tag :dictionaries))
(ans nil))
(while dicts
(setq ans (append ans (cdr (car dicts))))
(setq dicts (cdr dicts)))
ans)
))
(defun srecode-template-setup-parser ()
"Setup buffer for parse."
(srecode-template-wy--install-parser)
(setq
;; Lexical Analysis
semantic-lex-analyzer 'wisent-srecode-template-lexer
;; Parsing
;; Environment
semantic-imenu-summary-function 'semantic-format-tag-name
imenu-create-index-function 'semantic-create-imenu-index
semantic-command-separation-character "\n"
semantic-lex-comment-regex ";;"
;; Speedbar
semantic-symbol->name-assoc-list
'((function . "Template")
(variable . "Variable")
)
;; Navigation
senator-step-at-tag-classes '(function variable)
))
;;;;###autoload
(add-hook 'srecode-template-mode-hook 'srecode-template-setup-parser)
(provide 'srecode/template)
;;; srecode/template.el ends here

282
lisp/cedet/srecode/texi.el Normal file
View file

@ -0,0 +1,282 @@
;;; srecode-texi.el --- Srecode texinfo support.
;; Copyright (C) 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:
;;
;; Texinfo semantic recoder support.
;;
;; Contains some handlers, and a few simple texinfo srecoder applications.
(require 'semantic)
(require 'semantic/texi)
(require 'srecode/semantic)
;;; Code:
(defun srecode-texi-add-menu (newnode)
"Add an item into the current menu. Add @node statements as well.
Argument NEWNODE is the name of the new node."
(interactive "sName of new node: ")
(srecode-load-tables-for-mode major-mode)
(semantic-fetch-tags)
(let ((currnode (reverse (semantic-find-tag-by-overlay)))
(nodebounds nil))
(when (not currnode)
(error "Cannot find node to put menu item into"))
(setq currnode (car currnode))
(setq nodebounds (semantic-tag-texi-section-text-bounds currnode))
;; Step 1:
;; Limit search within this node.
;; Step 2:
;; Find the menu. If there isn't one, add one to the end.
;; Step 3:
;; Add new item to end of menu list.
;; Step 4:
;; Find correct node new item should show up after, and stick
;; the new node there.
(if (string= (semantic-texi-current-environment) "menu")
;; We are already in a menu, so insert the new item right here.
(beginning-of-line)
;; Else, try to find a menu item to append to.
(goto-char (car nodebounds))
(if (not (re-search-forward "^@menu" (car (cdr nodebounds)) t))
(progn
(goto-char (car (cdr nodebounds)))
(if (not (y-or-n-p "Add menu here? "))
(error "Abort"))
(srecode-insert "declaration:menu"))
;; Else, find the end
(re-search-forward "@end menu")
(beginning-of-line)))
;; At this point, we are in a menu... or not.
;; If we are, do stuff, else error.
(when (string= (semantic-texi-current-environment) "menu")
(let ((menuname newnode)
(returnpoint nil))
(srecode-insert "declaration:menuitem" "NAME" menuname)
(set-mark (point))
(setq returnpoint (make-marker))
;; Update the bound since we added text
(setq nodebounds (semantic-tag-texi-section-text-bounds currnode))
(beginning-of-line)
(forward-char -1)
(beginning-of-line)
(let ((end nil))
(if (not (looking-at "\\* \\([^:]+\\):"))
(setq end (car (cdr nodebounds)))
(let* ((nname (match-string 1))
(tag
(semantic-deep-find-tags-by-name nname (current-buffer))))
(when tag
(setq end (semantic-tag-end (car tag))))
))
(when (not end)
(goto-char returnpoint)
(error "Could not find location for new node" ))
(when end
(goto-char end)
(when (bolp) (forward-char -1))
(insert "\n")
(if (eq (semantic-current-tag) currnode)
(srecode-insert "declaration:subnode" "NAME" menuname)
(srecode-insert "declaration:node" "NAME" menuname))
)
)))
))
;;;###autoload
(defun srecode-semantic-handle-:texi (dict)
"Add macros into the dictionary DICT based on the current texinfo file.
Adds the following:
LEVEL - chapter, section, subsection, etc
NEXTLEVEL - One below level"
;; LEVEL and NEXTLEVEL calculation
(semantic-fetch-tags)
(let ((tags (reverse (semantic-find-tag-by-overlay)))
(level nil))
(while (and tags (not (semantic-tag-of-class-p (car tags) 'section)))
(setq tags (cdr tags)))
(when tags
(save-excursion
(goto-char (semantic-tag-start (car tags)))
(when (looking-at "@node")
(forward-line 1)
(beginning-of-line))
(when (looking-at "@\\(\\w+\\)")
(setq level (match-string 1))
)))
(srecode-dictionary-set-value dict "LEVEL" (or level "chapter"))
(let ((nl (assoc level '( ( nil . "top" )
("top" . "chapter")
("chapter" . "section")
("section" . "subsection")
("subsection" . "subsubsection")
("subsubsection" . "subsubsection")
))))
(srecode-dictionary-set-value dict "NEXTLEVEL" (cdr nl))))
)
;;;###autoload
(defun srecode-semantic-handle-:texitag (dict)
"Add macros into the dictionary DICT based on the current :tag file.
Adds the following:
TAGDOC - Texinfo formatted doc string for :tag."
;; If we also have a TAG, what is the doc?
(let ((tag (srecode-dictionary-lookup-name dict "TAG"))
(doc nil)
)
;; If the user didn't apply :tag, then do so now.
(when (not tag)
(srecode-semantic-handle-:tag dict))
(setq tag (srecode-dictionary-lookup-name dict "TAG"))
(when (not tag)
(error "No tag to insert for :texitag template argument"))
;; Extract the tag out of the compound object.
(setq tag (oref tag :prime))
;; Extract the doc string
(setq doc (semantic-documentation-for-tag tag))
(when doc
(srecode-dictionary-set-value dict "TAGDOC"
(srecode-texi-massage-to-texinfo
tag (semantic-tag-buffer tag)
doc)))
))
;;; OVERRIDES
;;
;; Override some semantic and srecode features with texi specific
;; versions.
(define-mode-local-override semantic-insert-foreign-tag
texinfo-mode (foreign-tag)
"Insert TAG from a foreign buffer in TAGFILE.
Assume TAGFILE is a source buffer, and create a documentation
thingy from it using the `document' tool."
(let ((srecode-semantic-selected-tag foreign-tag))
;; @todo - choose of the many types of tags to insert,
;; or put all that logic into srecode.
(srecode-insert "declaration:function")))
;;; Texinfo mangling.
(define-overloadable-function srecode-texi-texify-docstring
(docstring)
"Texify the doc string DOCSTRING.
Takes plain text formatting that may exist, and converts it to
using TeXinfo formatting.")
(defun srecode-texi-texify-docstring-default (docstring)
"Texify the doc string DOCSTRING.
Takes a few very generic guesses as to what the formatting is."
(let ((case-fold-search nil)
(start 0))
(while (string-match
"\\(^\\|[^{]\\)\\<\\([A-Z0-9_-]+\\)\\>\\($\\|[^}]\\)"
docstring start)
(let ((ms (match-string 2 docstring)))
;(when (eq mode 'emacs-lisp-mode)
; (setq ms (downcase ms)))
(when (not (or (string= ms "A")
(string= ms "a")
))
(setq docstring (concat (substring docstring 0 (match-beginning 2))
"@var{"
ms
"}"
(substring docstring (match-end 2))))))
(setq start (match-end 2)))
;; Return our modified doc string.
docstring))
(defun srecode-texi-massage-to-texinfo (tag buffer string)
"Massage TAG's documentation from BUFFER as STRING.
This is to take advantage of TeXinfo's markup symbols."
(save-excursion
(if buffer
(progn (set-buffer buffer)
(srecode-texi-texify-docstring string))
;; Else, no buffer, so lets do something else
(with-mode-local texinfo-mode
(srecode-texi-texify-docstring string)))))
(define-mode-local-override srecode-texi-texify-docstring emacs-lisp-mode
(string)
"Take STRING, (a normal doc string), and convert it into a texinfo string.
For instances where CLASS is the class being referenced, do not Xref
that class.
`function' => @dfn{function}
`variable' => @code{variable}
`class' => @code{class} @xref{class}
`unknown' => @code{unknonwn}
\"text\" => ``text''
'quoteme => @code{quoteme}
non-nil => non-@code{nil}
t => @code{t}
:tag => @code{:tag}
[ stuff ] => @code{[ stuff ]}
Key => @kbd{Key} (key is C\\-h, M\\-h, SPC, RET, TAB and the like)
... => @dots{}"
(while (string-match "`\\([-a-zA-Z0-9<>.]+\\)'" string)
(let* ((vs (substring string (match-beginning 1) (match-end 1)))
(v (intern-soft vs)))
(setq string
(concat
(replace-match (concat
(if (fboundp v)
"@dfn{" "@code{")
vs "}")
nil t string)))))
(while (string-match "\\( \\|^\\)\\(nil\\|t\\|'[-a-zA-Z0-9]+\\|:[-a-zA-Z0-9]+\\)\\([. ,]\\|$\\)" string)
(setq string (replace-match "@code{\\2}" t nil string 2)))
(while (string-match "\\( \\|^\\)\\(\\(non-\\)\\(nil\\)\\)\\([. ,]\\|$\\)" string)
(setq string (replace-match "\\3@code{\\4}" t nil string 2)))
(while (string-match "\\( \\|^\\)\\(\\[[^]]+\\]\\)\\( \\|$\\)" string)
(setq string (replace-match "@code{\\2}" t nil string 2)))
(while (string-match "\\( \\|^\\)\\(\\(\\(C-\\|M-\\|S-\\)+\\([^ \t\n]\\|RET\\|SPC\\|TAB\\)\\)\\|\\(RET\\|SPC\\|TAB\\)\\)\\( \\|\\s.\\|$\\)" string)
(setq string (replace-match "@kbd{\\2}" t nil string 2)))
(while (string-match "\"\\(.+\\)\"" string)
(setq string (replace-match "``\\1''" t nil string 0)))
(while (string-match "\\.\\.\\." string)
(setq string (replace-match "@dots{}" t nil string 0)))
;; Also do base docstring type.
(srecode-texi-texify-docstring-default string))
(provide 'srecode/texi)
;; Local variables:
;; generated-autoload-file: "loaddefs.el"
;; generated-autoload-feature: srecode/loaddefs
;; generated-autoload-load-name: "srecode/texi"
;; End:
;;; srecode/texi.el ends here

1
lisp/files.el
View file

@ -2203,6 +2203,7 @@ since only a single case-insensitive search through the alist is made."
("\\.f9[05]\\'" . f90-mode)
("\\.indent\\.pro\\'" . fundamental-mode) ; to avoid idlwave-mode
("\\.\\(pro\\|PRO\\)\\'" . idlwave-mode)
("\\.srt\\'" . srecode-template-mode) ; in the CEDET library
("\\.prolog\\'" . prolog-mode)
("\\.tar\\'" . tar-mode)
;; The list of archive file extensions should be in sync with

266
test/cedet/srecode-tests.el Normal file
View file

@ -0,0 +1,266 @@
;;; From srecode-fields:
(require 'srecode/fields)
(defvar srecode-field-utest-text
"This is a test buffer.
It is filled with some text."
"Text for tests.")
(defun srecode-field-utest ()
"Test the srecode field manager."
(interactive)
(if (featurep 'xemacs)
(message "There is no XEmacs support for SRecode Fields.")
(srecode-field-utest-impl)))
(defun srecode-field-utest-impl ()
"Implementation of the SRecode field utest."
(save-excursion
(find-file "/tmp/srecode-field-test.txt")
(erase-buffer)
(goto-char (point-min))
(insert srecode-field-utest-text)
(set-buffer-modified-p nil)
;; Test basic field generation.
(let ((srecode-field-archive nil)
(f nil))
(end-of-line)
(forward-word -1)
(setq f (srecode-field "Test"
:name "TEST"
:start 6
:end 8))
(when (or (not (slot-boundp f 'overlay)) (not (oref f overlay)))
(error "Field test: Overlay info not created for field"))
(when (and (overlay-p (oref f overlay))
(not (overlay-get (oref f overlay) 'srecode-init-only)))
(error "Field creation overlay is not tagged w/ init flag"))
(srecode-overlaid-activate f)
(when (or (not (overlay-p (oref f overlay)))
(overlay-get (oref f overlay) 'srecode-init-only))
(error "New field overlay not created during activation"))
(when (not (= (length srecode-field-archive) 1))
(error "Field test: Incorrect number of elements in the field archive"))
(when (not (eq f (car srecode-field-archive)))
(error "Field test: Field did not auto-add itself to the field archive"))
(when (not (overlay-get (oref f overlay) 'keymap))
(error "Field test: Overlay keymap not set"))
(when (not (string= "is" (srecode-overlaid-text f)))
(error "Field test: Expected field text 'is', not %s"
(srecode-overlaid-text f)))
;; Test deletion.
(srecode-delete f)
(when (slot-boundp f 'overlay)
(error "Field test: Overlay not deleted after object delete"))
)
;; Test basic region construction.
(let* ((srecode-field-archive nil)
(reg nil)
(fields
(list
(srecode-field "Test1" :name "TEST-1" :start 5 :end 10)
(srecode-field "Test2" :name "TEST-2" :start 15 :end 20)
(srecode-field "Test3" :name "TEST-3" :start 25 :end 30)
(srecode-field "Test4" :name "TEST-4" :start 35 :end 35))
))
(when (not (= (length srecode-field-archive) 4))
(error "Region Test: Found %d fields. Expected 4"
(length srecode-field-archive)))
(setq reg (srecode-template-inserted-region "REG"
:start 4
:end 40))
(srecode-overlaid-activate reg)
;; Make sure it was cleared.
(when srecode-field-archive
(error "Region Test: Did not clear field archive"))
;; Auto-positioning.
(when (not (eq (point) 5))
(error "Region Test: Did not reposition on first field"))
;; Active region
(when (not (eq (srecode-active-template-region) reg))
(error "Region Test: Active region not set"))
;; Various sizes
(mapc (lambda (T)
(if (string= (object-name-string T) "Test4")
(progn
(when (not (srecode-empty-region-p T))
(error "Field %s is not empty"
(object-name T)))
)
(when (not (= (srecode-region-size T) 5))
(error "Calculated size of %s was not 5"
(object-name T)))))
fields)
;; Make sure things stay up after a 'command'.
(srecode-field-post-command)
(when (not (eq (srecode-active-template-region) reg))
(error "Region Test: Active region did not stay up"))
;; Test field movement.
(when (not (eq (srecode-overlaid-at-point 'srecode-field)
(nth 0 fields)))
(error "Region Test: Field %s not under point"
(object-name (nth 0 fields))))
(srecode-field-next)
(when (not (eq (srecode-overlaid-at-point 'srecode-field)
(nth 1 fields)))
(error "Region Test: Field %s not under point"
(object-name (nth 1 fields))))
(srecode-field-prev)
(when (not (eq (srecode-overlaid-at-point 'srecode-field)
(nth 0 fields)))
(error "Region Test: Field %s not under point"
(object-name (nth 0 fields))))
;; Move cursor out of the region and have everything cleaned up.
(goto-char 42)
(srecode-field-post-command)
(when (srecode-active-template-region)
(error "Region Test: Active region did not clear on move out"))
(mapc (lambda (T)
(when (slot-boundp T 'overlay)
(error "Overlay did not clear off of of field %s"
(object-name T))))
fields)
;; End of LET
)
;; Test variable linkage.
(let* ((srecode-field-archive nil)
(f1 (srecode-field "Test1" :name "TEST" :start 6 :end 8))
(f2 (srecode-field "Test2" :name "TEST" :start 28 :end 30))
(f3 (srecode-field "Test3" :name "NOTTEST" :start 35 :end 40))
(reg (srecode-template-inserted-region "REG" :start 4 :end 40))
)
(srecode-overlaid-activate reg)
(when (not (string= (srecode-overlaid-text f1)
(srecode-overlaid-text f2)))
(error "Linkage Test: Init strings are not ="))
(when (string= (srecode-overlaid-text f1)
(srecode-overlaid-text f3))
(error "Linkage Test: Init string on dissimilar fields is now the same"))
(goto-char 7)
(insert "a")
(when (not (string= (srecode-overlaid-text f1)
(srecode-overlaid-text f2)))
(error "Linkage Test: mid-insert strings are not ="))
(when (string= (srecode-overlaid-text f1)
(srecode-overlaid-text f3))
(error "Linkage Test: mid-insert string on dissimilar fields is now the same"))
(goto-char 9)
(insert "t")
(when (not (string= (srecode-overlaid-text f1) "iast"))
(error "Linkage Test: tail-insert failed to captured added char"))
(when (not (string= (srecode-overlaid-text f1)
(srecode-overlaid-text f2)))
(error "Linkage Test: tail-insert strings are not ="))
(when (string= (srecode-overlaid-text f1)
(srecode-overlaid-text f3))
(error "Linkage Test: tail-insert string on dissimilar fields is now the same"))
(goto-char 6)
(insert "b")
(when (not (string= (srecode-overlaid-text f1) "biast"))
(error "Linkage Test: tail-insert failed to captured added char"))
(when (not (string= (srecode-overlaid-text f1)
(srecode-overlaid-text f2)))
(error "Linkage Test: tail-insert strings are not ="))
(when (string= (srecode-overlaid-text f1)
(srecode-overlaid-text f3))
(error "Linkage Test: tail-insert string on dissimilar fields is now the same"))
;; Cleanup
(srecode-delete reg)
)
(set-buffer-modified-p nil)
(message " All field tests passed.")
))
;;; From srecode-document:
(require 'srecode/doc)
(defun srecode-document-function-comment-extract-test ()
"Test old comment extraction.
Dump out the extracted dictionary."
(interactive)
(srecode-load-tables-for-mode major-mode)
(srecode-load-tables-for-mode major-mode 'document)
(if (not (srecode-table))
(error "No template table found for mode %s" major-mode))
(let* ((temp (srecode-template-get-table (srecode-table)
"function-comment"
"declaration"
'document))
(fcn-in (semantic-current-tag)))
(if (not temp)
(error "No templates for function comments"))
;; Try to figure out the tag we want to use.
(when (or (not fcn-in)
(not (semantic-tag-of-class-p fcn-in 'function)))
(error "No tag of class 'function to insert comment for"))
(let ((lextok (semantic-documentation-comment-preceeding-tag fcn-in 'lex))
)
(when (not lextok)
(error "No comment to attempt an extraction"))
(let ((s (semantic-lex-token-start lextok))
(e (semantic-lex-token-end lextok))
(extract nil))
(pulse-momentary-highlight-region s e)
;; Extract text from the existing comment.
(setq extract (srecode-extract temp s e))
(with-output-to-temp-buffer "*SRECODE DUMP*"
(princ "EXTRACTED DICTIONARY FOR ")
(princ (semantic-tag-name fcn-in))
(princ "\n--------------------------------------------\n")
(srecode-dump extract))))))