* 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):
(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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
+
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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))))
+ )
+ )
+ )))
+
+\f
+;;; 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
--- /dev/null
+;;; 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)
+
+\f
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
+
--- /dev/null
+;;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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)
+ ))
+\f
+;;; 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))
+
+\f
+;;; 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)))
+
+\f
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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)
+
+\f
+;;; 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))
+ ))
+
+\f
+;;; 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))
+
+\f
+;;; 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)))
+ ))))
+
+\f
+;;; 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)))
+
+\f
+;;; 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
--- /dev/null
+;;; 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*
+ ))))
+
+\f
+;;; 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)))
+
+\f
+;;; 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)))
+
+
+\f
+;;; 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))))
+
+\f
+;;; 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
--- /dev/null
+;;; 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)
+
+\f
+;;; Prologue
+;;
+\f
+;;; 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))
+
+\f
+;;; 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)
+
+\f
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
+
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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")))
+
+
+\f
+;;; 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
("\\.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
--- /dev/null
+;;; 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))))))
HCoop / bpt / emacs.git / commitdiff