diff options
author | Chong Yidong <cyd@stupidchicken.com> | 2009-09-20 21:06:41 +0000 |
---|---|---|
committer | Chong Yidong <cyd@stupidchicken.com> | 2009-09-20 21:06:41 +0000 |
commit | 4d902e6f13f6bf5d304a0cbcff33e2780a825206 (patch) | |
tree | 20c5dbf4febbaff55e22b4fa0e950cf552e88e70 | |
parent | 70702e9b0ea781fb955c66320c935bc0a8e1d0f1 (diff) | |
download | emacs-4d902e6f13f6bf5d304a0cbcff33e2780a825206.tar.gz |
lisp/cedet/srecode.el:
lisp/cedet/srecode/*.el:
test/cedet/srecode-tests.el: New files
lisp/files.el (auto-mode-alist): Use srecode-template-mode for .srt files.
lisp/cedet/semantic/bovine/scm.el: Add local vars section for autoloading.
29 files changed, 8633 insertions, 0 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 77137241a48..eeb2e331bd6 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -9,6 +9,7 @@ * progmodes/autoconf.el: Provide autoconf as well. * files.el (auto-mode-alist): Use emacs-lisp-mode for Project.ede. + (auto-mode-alist): Use srecode-template-mode for .srt files. * cedet/semantic/bovine/gcc.el (semantic-gcc-test-output-parser) (semantic-gcc-test-output-parser-this-machine): diff --git a/lisp/cedet/semantic/bovine/scm.el b/lisp/cedet/semantic/bovine/scm.el index e57390157ce..3558062d61d 100644 --- a/lisp/cedet/semantic/bovine/scm.el +++ b/lisp/cedet/semantic/bovine/scm.el @@ -115,4 +115,10 @@ syntax as specified by the syntax table." (provide 'semantic/bovine/scm) +;; Local variables: +;; generated-autoload-file: "../loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/bovine/scm" +;; End: + ;;; semantic/bovine/scm.el ends here diff --git a/lisp/cedet/srecode.el b/lisp/cedet/srecode.el new file mode 100644 index 00000000000..bb87865cc90 --- /dev/null +++ b/lisp/cedet/srecode.el @@ -0,0 +1,53 @@ +;;; srecode.el --- Semantic buffer evaluator. + +;;; Copyright (C) 2005, 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Keywords: codegeneration + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Semantic does the job of converting source code into useful tag +;; information. The set of `semantic-format-tag' functions has one +;; function that will create a prototype of a tag, which has severe +;; issues of complexity (in the format tag file itself) and inaccuracy +;; (for the purpose of C++ code.) +;; +;; Contemplation of the simplistic problem within the scope of +;; semantic showed that the solution was more complex than could +;; possibly be handled in semantic-format.el. Semantic Recode, or +;; srecode is a rich API for generating code out of semantic tags, or +;; recoding the tags. +;; +;; See the srecode manual for specific details. + +(require 'eieio) +(require 'mode-local) +(require 'srecode/loaddefs) + +(defvar srecode-version "1.0pre7" + "Current version of the Semantic Recoder.") + +;;; Code: +(defgroup srecode nil + "Semantic Recoder." + :group 'tools) + +(provide 'srecode) + +;;; srecode.el ends here diff --git a/lisp/cedet/srecode/args.el b/lisp/cedet/srecode/args.el new file mode 100644 index 00000000000..0d45831e9fc --- /dev/null +++ b/lisp/cedet/srecode/args.el @@ -0,0 +1,188 @@ +;;; srecode/args.el --- Provide some simple template arguments + +;;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Srecode templates can accept arguments. These arguments represent +;; sets of dictionary words that need to be derived. This file contains +;; a set of simple arguments for srecode templates. + +(require 'srecode/insert) + +;;; Code: + +;;; :blank +;; +;; Using :blank means that the template should force blank lines +;; before and after the template, reguardless of where the insertion +;; is occuring. +(defun srecode-semantic-handle-:blank (dict) + "Add macros into the dictionary DICT specifying blank line spacing. +The wrapgap means make sure the first and last lines of the macro +do not contain any text from preceeding or following text." + ;; This won't actually get used, but it might be nice + ;; to know about it. + (srecode-dictionary-set-value dict "BLANK" t) + ) + +;;; :indent ARGUMENT HANDLING +;; +;; When a :indent argument is required, the default is to indent +;; for the current major mode. +(defun srecode-semantic-handle-:indent (dict) + "Add macros into the dictionary DICT for indentation." + (srecode-dictionary-set-value dict "INDENT" t) + ) + +;;; :region ARGUMENT HANDLING +;; +;; When a :region argument is required, provide macros that +;; deal with that active region. +;; +;; Regions allow a macro to wrap the region text within the +;; template bounds. +;; +(defvar srecode-handle-region-when-non-active-flag nil + "Non-nil means do region handling w/out the region being active.") + +(defun srecode-semantic-handle-:region (dict) + "Add macros into the dictionary DICT based on the current :region." + ;; Only enable the region section if we can clearly show that + ;; the user is intending to do something with the region. + (when (or srecode-handle-region-when-non-active-flag + (eq last-command 'mouse-drag-region) + (and transient-mark-mode mark-active)) + ;; Show the region section + (srecode-dictionary-show-section dict "REGION") + (srecode-dictionary-set-value + dict "REGIONTEXT" (buffer-substring-no-properties (point) (mark))) + ;; Only whack the region if our template output + ;; is also destined for the current buffer. + (when (eq standard-output (current-buffer)) + (kill-region (point) (mark)))) + ) + +;;; :user ARGUMENT HANDLING +;; +;; When a :user argument is required, fill the dictionary with +;; information about the current Emacs user. +(defun srecode-semantic-handle-:user (dict) + "Add macros into the dictionary DICT based on the current :user." + (srecode-dictionary-set-value dict "AUTHOR" (user-full-name)) + (srecode-dictionary-set-value dict "LOGIN" (user-login-name)) + (srecode-dictionary-set-value dict "EMAIL" user-mail-address) + (srecode-dictionary-set-value dict "EMACSINITFILE" user-init-file) + (srecode-dictionary-set-value dict "UID" (user-uid)) + ) + +;;; :time ARGUMENT HANDLING +;; +;; When a :time argument is required, fill the dictionary with +;; information about the current Emacs time. +(defun srecode-semantic-handle-:time (dict) + "Add macros into the dictionary DICT based on the current :time." + ;; DATE Values + (srecode-dictionary-set-value + dict "YEAR" (format-time-string "%Y" (current-time))) + (srecode-dictionary-set-value + dict "MONTHNAME" (format-time-string "%B" (current-time))) + (srecode-dictionary-set-value + dict "MONTH" (format-time-string "%m" (current-time))) + (srecode-dictionary-set-value + dict "DAY" (format-time-string "%d" (current-time))) + (srecode-dictionary-set-value + dict "WEEKDAY" (format-time-string "%a" (current-time))) + ;; Time Values + (srecode-dictionary-set-value + dict "HOUR" (format-time-string "%H" (current-time))) + (srecode-dictionary-set-value + dict "HOUR12" (format-time-string "%l" (current-time))) + (srecode-dictionary-set-value + dict "AMPM" (format-time-string "%p" (current-time))) + (srecode-dictionary-set-value + dict "MINUTE" (format-time-string "%M" (current-time))) + (srecode-dictionary-set-value + dict "SECOND" (format-time-string "%S" (current-time))) + (srecode-dictionary-set-value + dict "TIMEZONE" (format-time-string "%Z" (current-time))) + ;; Convenience pre-packed date/time + (srecode-dictionary-set-value + dict "DATE" (format-time-string "%D" (current-time))) + (srecode-dictionary-set-value + dict "TIME" (format-time-string "%X" (current-time))) + ) + +;;; :file ARGUMENT HANDLING +;; +;; When a :file argument is required, fill the dictionary with +;; information about the file Emacs is editing at the time of +;; insertion. +(defun srecode-semantic-handle-:file (dict) + "Add macros into the dictionary DICT based on the current :file." + (let* ((bfn (buffer-file-name)) + (file (file-name-nondirectory bfn)) + (dir (file-name-directory bfn))) + (srecode-dictionary-set-value dict "FILENAME" file) + (srecode-dictionary-set-value dict "FILE" (file-name-sans-extension file)) + (srecode-dictionary-set-value dict "EXTENSION" (file-name-extension file)) + (srecode-dictionary-set-value dict "DIRECTORY" dir) + (srecode-dictionary-set-value dict "MODE" (symbol-name major-mode)) + (srecode-dictionary-set-value + dict "SHORTMODE" + (let* ((mode-name (symbol-name major-mode)) + (match (string-match "-mode" mode-name))) + (if match + (substring mode-name 0 match) + mode-name))) + (if (or (file-exists-p "CVS") + (file-exists-p "RCS")) + (srecode-dictionary-show-section dict "RCS") + ))) + +;;; :system ARGUMENT HANDLING +;; +;; When a :system argument is required, fill the dictionary with +;; information about the computer Emacs is running on. +(defun srecode-semantic-handle-:system (dict) + "Add macros into the dictionary DICT based on the current :system." + (srecode-dictionary-set-value dict "SYSTEMCONF" system-configuration) + (srecode-dictionary-set-value dict "SYSTEMTYPE" system-type) + (srecode-dictionary-set-value dict "SYSTEMNAME" (system-name)) + (srecode-dictionary-set-value dict "MAILHOST" (or mail-host-address + (system-name))) + ) + +;;; :kill ARGUMENT HANDLING +;; +;; When a :kill argument is required, fill the dictionary with +;; information about the current kill ring. +(defun srecode-semantic-handle-:kill (dict) + "Add macros into the dictionary DICT based on the kill ring." + (srecode-dictionary-set-value dict "KILL" (car kill-ring)) + (srecode-dictionary-set-value dict "KILL2" (nth 1 kill-ring)) + (srecode-dictionary-set-value dict "KILL3" (nth 2 kill-ring)) + (srecode-dictionary-set-value dict "KILL4" (nth 3 kill-ring)) + ) + +(provide 'srecode/args) + +;;; srecode/args.el ends here + diff --git a/lisp/cedet/srecode/compile.el b/lisp/cedet/srecode/compile.el new file mode 100644 index 00000000000..f744b052162 --- /dev/null +++ b/lisp/cedet/srecode/compile.el @@ -0,0 +1,640 @@ +;;; srecode/compile --- Compilation of srecode template files. + +;;; Copyright (C) 2005, 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Keywords: codegeneration + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Compile a Semantic Recoder template file. +;; +;; Template files are parsed using a Semantic/Wisent parser into +;; a tag table. The code therin is then further parsed down using +;; a regular expression parser. +;; +;; The output are a series of EIEIO objects which represent the +;; templates in a way that could be inserted later. + +(require 'semantic) +(require 'eieio) +(require 'eieio-base) +(require 'srecode) +(require 'srecode/table) + +(declare-function srecode-template-inserter-newline-child-p "srecode/insert") +(declare-function srecode-create-section-dictionary "srecode/dictionary") +(declare-function srecode-dictionary-compound-variable "srecode/dictionary") + +;;; Code: + +;;; Template Class +;; +;; Templatets describe a patter of text that can be inserted into a +;; buffer. +;; +(defclass srecode-template (eieio-named) + ((context :initarg :context + :initform nil + :documentation + "Context this template belongs to.") + (args :initarg :args + :documentation + "List of arguments that this template requires.") + (code :initarg :code + :documentation + "Compiled text from the template.") + (dictionary :initarg :dictionary + :type (or null srecode-dictionary) + :documentation + "List of section dictinaries. +The compiled template can contain lists of section dictionaries, +or values that are expected to be passed down into different +section macros. The template section dictionaries are merged in with +any incomming dictionaries values.") + (binding :initarg :binding + :documentation + "Preferred keybinding for this template in `srecode-minor-mode-map'.") + (active :allocation :class + :initform nil + :documentation + "During template insertion, this is the stack of active templates. +The top-most template is the 'active' template. Use the accessor methods +for push, pop, and peek for the active template.") + (table :initarg :table + :documentation + "The table this template lives in.") + ) + "Class defines storage for semantic recoder templates.") + +(defun srecode-flush-active-templates () + "Flush the active template storage. +Useful if something goes wrong in SRecode, and the active tempalte +stack is broken." + (interactive) + (if (oref srecode-template active) + (when (y-or-n-p (format "%d active templates. Flush? " + (length (oref srecode-template active)))) + (oset-default srecode-template active nil)) + (message "No active templates to flush.")) + ) + +;;; Inserters +;; +;; Each inserter object manages a different thing that +;; might be inserted into a template output stream. +;; +;; The 'srecode-insert-method' on each inserter does the actual +;; work, and the smaller, simple inserter object is saved in +;; the compiled templates. +;; +;; See srecode-insert.el for the specialized classes. +;; +(defclass srecode-template-inserter (eieio-named) + ((secondname :initarg :secondname + :type (or null string) + :documentation + "If there is a colon in the inserter's name, it represents +additional static argument data.")) + "This represents an item to be inserted via a template macro. +Plain text strings are not handled via this baseclass." + :abstract t) + +(defmethod srecode-parse-input ((ins srecode-template-inserter) + tag input STATE) + "For the template inserter INS, parse INPUT. +Shorten input only by the amount needed. +Return the remains of INPUT. +STATE is the current compilation state." + input) + +(defmethod srecode-match-end ((ins srecode-template-inserter) name) + "For the template inserter INS, do I end a section called NAME?" + nil) + +(defmethod srecode-inserter-apply-state ((ins srecode-template-inserter) STATE) + "For the template inserter INS, apply information from STATE." + nil) + +(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter) + escape-start escape-end) + "Insert an example using inserter INS. +Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use." + (princ " ") + (princ escape-start) + (when (and (slot-exists-p ins 'key) (oref ins key)) + (princ (format "%c" (oref ins key)))) + (princ "VARNAME") + (princ escape-end) + (terpri) + ) + + +;;; Compile State +(defclass srecode-compile-state () + ((context :initform "declaration" + :documentation "The active context.") + (prompts :initform nil + :documentation "The active prompts.") + (escape_start :initform "{{" + :documentation "The starting escape sequence.") + (escape_end :initform "}}" + :documentation "The ending escape sequence.") + ) + "Current state of the compile.") + +(defmethod srecode-compile-add-prompt ((state srecode-compile-state) + prompttag) + "Add PROMPTTAG to the current list of prompts." + (with-slots (prompts) state + (let ((match (assoc (semantic-tag-name prompttag) prompts)) + (newprompts prompts)) + (when match + (let ((tmp prompts)) + (setq newprompts nil) + (while tmp + (when (not (string= (car (car tmp)) + (car prompttag))) + (setq newprompts (cons (car tmp) + newprompts))) + (setq tmp (cdr tmp))))) + (setq prompts (cons prompttag newprompts))) + )) + +;;; TEMPLATE COMPILER +;; +(defun srecode-compile-file (fname) + "Compile the templates from the file FNAME." + (let ((peb (get-file-buffer fname))) + (save-excursion + ;; Make whatever it is local. + (if (not peb) + (set-buffer (semantic-find-file-noselect fname)) + (set-buffer peb)) + ;; Do the compile. + (srecode-compile-templates) + ;; Trash the buffer if we had to read it in. + (if (not peb) + (kill-buffer (current-buffer))) + ))) + +;;;###autoload +(defun srecode-compile-templates () + "Compile a semantic recode template file into a mode-local variable." + (interactive) + (require 'srecode-insert) + (message "Compiling template %s..." + (file-name-nondirectory (buffer-file-name))) + (let ((tags (semantic-fetch-tags)) + (tag nil) + (class nil) + (table nil) + (STATE (srecode-compile-state (file-name-nondirectory + (buffer-file-name)))) + (mode nil) + (application nil) + (priority nil) + (vars nil) + ) + + ;; + ;; COMPILE + ;; + (while tags + (setq tag (car tags) + class (semantic-tag-class tag)) + ;; What type of item is it? + (cond + ;; CONTEXT tags specify the context all future tags + ;; belong to. + ((eq class 'context) + (oset STATE context (semantic-tag-name tag)) + ) + + ;; PROMPT tags specify prompts for dictionary ? inserters + ;; which appear in the following templates + ((eq class 'prompt) + (srecode-compile-add-prompt STATE tag) + ) + + ;; VARIABLE tags can specify operational control + ((eq class 'variable) + (let* ((name (semantic-tag-name tag)) + (value (semantic-tag-variable-default tag)) + (firstvalue (car value))) + ;; If it is a single string, and one value, then + ;; look to see if it is one of our special variables. + (if (and (= (length value) 1) (stringp firstvalue)) + (cond ((string= name "mode") + (setq mode (intern firstvalue))) + ((string= name "escape_start") + (oset STATE escape_start firstvalue) + ) + ((string= name "escape_end") + (oset STATE escape_end firstvalue) + ) + ((string= name "application") + (setq application (read firstvalue))) + ((string= name "priority") + (setq priority (read firstvalue))) + (t + ;; Assign this into some table of variables. + (setq vars (cons (cons name firstvalue) vars)) + )) + ;; If it isn't a single string, then the value of the + ;; variable belongs to a compound dictionary value. + ;; + ;; Create a compound dictionary value from "value". + (require 'srecode/dictionary) + (let ((cv (srecode-dictionary-compound-variable + name :value value))) + (setq vars (cons (cons name cv) vars))) + )) + ) + + ;; FUNCTION tags are really templates. + ((eq class 'function) + (setq table (cons (srecode-compile-one-template-tag tag STATE) + table)) + ) + + ;; Ooops + (t (error "Unknown TAG class %s" class)) + ) + ;; Continue + (setq tags (cdr tags))) + + ;; MSG - Before install since nreverse whacks our list. + (message "%d templates compiled for %s" + (length table) mode) + + ;; + ;; APPLY TO MODE + ;; + (if (not mode) + (error "You must specify a MODE for your templates")) + + ;; + ;; Calculate priority + ;; + (if (not priority) + (let ((d (file-name-directory (buffer-file-name))) + (sd (file-name-directory (locate-library "srecode"))) + (defaultdelta (if (eq mode 'default) 20 0))) + (if (string= d sd) + (setq priority (+ 80 defaultdelta)) + (setq priority (+ 30 defaultdelta))) + (message "Templates %s has estimated priority of %d" + (file-name-nondirectory (buffer-file-name)) + priority)) + (message "Compiling templates %s priority %d... done!" + (file-name-nondirectory (buffer-file-name)) + priority)) + + ;; Save it up! + (srecode-compile-template-table table mode priority application vars) + ) +) + +(defun srecode-compile-one-template-tag (tag STATE) + "Compile a template tag TAG into an srecode template class. +STATE is the current compile state as an object `srecode-compile-state'." + (require 'srecode/dictionary) + (let* ((context (oref STATE context)) + (codeout (srecode-compile-split-code + tag (semantic-tag-get-attribute tag :code) + STATE)) + (code (cdr codeout)) + (args (semantic-tag-function-arguments tag)) + (binding (semantic-tag-get-attribute tag :binding)) + (rawdicts (semantic-tag-get-attribute tag :dictionaries)) + (sdicts (srecode-create-section-dictionary rawdicts STATE)) + (addargs nil) + ) +; (message "Compiled %s to %d codes with %d args and %d prompts." +; (semantic-tag-name tag) +; (length code) +; (length args) +; (length prompts)) + (while args + (setq addargs (cons (intern (car args)) addargs)) + (when (eq (car addargs) :blank) + ;; If we have a wrap, then put wrap inserters on both + ;; ends of the code. + (setq code (append + (list (srecode-compile-inserter "BLANK" + "\r" + STATE + :secondname nil + :where 'begin)) + code + (list (srecode-compile-inserter "BLANK" + "\r" + STATE + :secondname nil + :where 'end)) + ))) + (setq args (cdr args))) + (srecode-template (semantic-tag-name tag) + :context context + :args (nreverse addargs) + :dictionary sdicts + :binding binding + :code code) + )) + +(defun srecode-compile-do-hard-newline-p (comp) + "Examine COMP to decide if the upcoming newline should be hard. +It is hard if the previous inserter is a newline object." + (while (and comp (stringp (car comp))) + (setq comp (cdr comp))) + (or (not comp) + (require 'srecode/insert) + (srecode-template-inserter-newline-child-p (car comp)))) + +(defun srecode-compile-split-code (tag str STATE + &optional end-name) + "Split the code for TAG into something templatable. +STR is the string of code from TAG to split. +STATE is the current compile state. +ESCAPE_START and ESCAPE_END are regexps that indicate the beginning +escape character, and end escape character pattern for expandable +macro names. +Optional argument END-NAME specifies the name of a token upon which +parsing should stop. +If END-NAME is specified, and the input string" + (let* ((what str) + (end-token nil) + (comp nil) + (regex (concat "\n\\|" (regexp-quote (oref STATE escape_start)))) + (regexend (regexp-quote (oref STATE escape_end))) + ) + (while (and what (not end-token)) + (cond + ((string-match regex what) + (let* ((prefix (substring what 0 (match-beginning 0))) + (match (substring what + (match-beginning 0) + (match-end 0))) + (namestart (match-end 0)) + (junk (string-match regexend what namestart)) + end tail name) + ;; Add string to compiled output + (when (> (length prefix) 0) + (setq comp (cons prefix comp))) + (if (string= match "\n") + ;; Do newline thingy. + (let ((new-inserter + (srecode-compile-inserter + "INDENT" + "\n" + STATE + :secondname nil + ;; This newline is "hard" meaning ALWAYS do it + ;; if the previous entry is also a newline. + ;; Without it, user entered blank lines will be + ;; ignored. + :hard (srecode-compile-do-hard-newline-p comp) + ))) + ;; Trim WHAT back. + (setq what (substring what namestart)) + (when (> (length what) 0) + ;; make the new inserter, but only if we aren't last. + (setq comp (cons new-inserter comp)) + )) + ;; Regular inserter thingy. + (setq end (if junk + (match-beginning 0) + (error "Could not find end escape for %s" + (semantic-tag-name tag))) + tail (match-end 0)) + (cond ((not end) + (error "No matching escape end for %s" + (semantic-tag-name tag))) + ((<= end namestart) + (error "Stray end escape for %s" + (semantic-tag-name tag))) + ) + ;; Add string to compiled output + (setq name (substring what namestart end) + key nil) + ;; Trim WHAT back. + (setq what (substring what tail)) + ;; Get the inserter + (let ((new-inserter + (srecode-compile-parse-inserter name STATE)) + ) + ;; If this is an end inserter, then assign into + ;; the end-token. + (if (srecode-match-end new-inserter end-name) + (setq end-token new-inserter)) + ;; Add the inserter to our compilation stream. + (setq comp (cons new-inserter comp)) + ;; Allow the inserter an opportunity to modify + ;; the input stream. + (setq what (srecode-parse-input new-inserter tag what + STATE)) + ) + ))) + (t + (if end-name + (error "Unmatched section end %s" end-name)) + (setq comp (cons what comp) + what nil)))) + (cons what (nreverse comp)))) + +(defun srecode-compile-parse-inserter (txt STATE) + "Parse the inserter TXT with the current STATE. +Return an inserter object." + (let ((key (aref txt 0)) + ) + (if (and (or (< key ?A) (> key ?Z)) + (or (< key ?a) (> key ?z)) ) + (setq name (substring txt 1)) + (setq name txt + key nil)) + (let* ((junk (string-match ":" name)) + (namepart (if junk + (substring name 0 (match-beginning 0)) + name)) + (secondname (if junk + (substring name (match-end 0)) + nil)) + (new-inserter (srecode-compile-inserter + namepart key STATE + :secondname secondname + ))) + ;; Return the new inserter + new-inserter))) + +(defun srecode-compile-inserter (name key STATE &rest props) + "Create an srecode inserter object for some macro NAME. +KEY indicates a single character key representing a type +of inserter to create. +STATE is the current compile state. +PROPS are additional properties that might need to be passed +to the inserter constructor." + ;;(message "Compile: %s %S" name props) + (if (not key) + (apply 'srecode-template-inserter-variable name props) + (let ((classes (class-children srecode-template-inserter)) + (new nil)) + ;; Loop over the various subclasses and + ;; create the correct inserter. + (while (and (not new) classes) + (setq classes (append classes (class-children (car classes)))) + ;; Do we have a match? + (when (and (not (class-abstract-p (car classes))) + (equal (oref (car classes) key) key)) + ;; Create the new class, and apply state. + (setq new (apply (car classes) name props)) + (srecode-inserter-apply-state new STATE) + ) + (setq classes (cdr classes))) + (if (not new) (error "SRECODE: Unknown macro code %S" key)) + new))) + +(defun srecode-compile-template-table (templates mode priority application vars) + "Compile a list of TEMPLATES into an semantic recode table. +The table being compiled is for MODE, or the string \"default\". +PRIORITY is a numerical value that indicates this tables location +in an ordered search. +APPLICATION is the name of the application these templates belong to. +A list of defined variables VARS provides a variable table." + (let ((namehash (make-hash-table :test 'equal + :size (length templates))) + (contexthash (make-hash-table :test 'equal :size 10)) + (lp templates) + ) + + (while lp + + (let* ((objname (oref (car lp) :object-name)) + (context (oref (car lp) :context)) + (globalname (concat context ":" objname)) + ) + + ;; Place this template object into the global name hash. + (puthash globalname (car lp) namehash) + + ;; Place this template into the specific context name hash. + (let ((hs (gethash context contexthash))) + ;; Make a new context if none was available. + (when (not hs) + (setq hs (make-hash-table :test 'equal :size 20)) + (puthash context hs contexthash)) + ;; Put into that contenxt's hash. + (puthash objname (car lp) hs) + ) + + (setq lp (cdr lp)))) + + (let* ((table (srecode-mode-table-new mode (buffer-file-name) + :templates (nreverse templates) + :namehash namehash + :contexthash contexthash + :variables vars + :major-mode mode + :priority priority + :application application)) + (tmpl (oref table templates))) + ;; Loop over all the templates, and xref. + (while tmpl + (oset (car tmpl) :table table) + (setq tmpl (cdr tmpl)))) + )) + + + +;;; DEBUG +;; +;; Dump out information about the current srecoder compiled templates. +;; + +(defmethod srecode-dump ((tmp srecode-template)) + "Dump the contents of the SRecode template tmp." + (princ "== Template \"") + (princ (object-name-string tmp)) + (princ "\" in context ") + (princ (oref tmp context)) + (princ "\n") + (when (oref tmp args) + (princ " Arguments: ") + (prin1 (oref tmp args)) + (princ "\n")) + (when (oref tmp dictionary) + (princ " Section Dictionaries:\n") + (srecode-dump (oref tmp dictionary) 4) + ;(princ "\n") + ) + (when (and (slot-boundp tmp 'binding) (oref tmp binding)) + (princ " Binding: ") + (prin1 (oref tmp binding)) + (princ "\n")) + (princ " Compiled Codes:\n") + (srecode-dump-code-list (oref tmp code) " ") + (princ "\n\n") + ) + +(defun srecode-dump-code-list (code indent) + "Dump the CODE from a template code list to standard output. +Argument INDENT specifies the indentation level for the list." + (let ((i 1)) + (while code + (princ indent) + (prin1 i) + (princ ") ") + (cond ((stringp (car code)) + (prin1 (car code))) + ((srecode-template-inserter-child-p (car code)) + (srecode-dump (car code) indent)) + (t + (princ "Unknown Code: ") + (prin1 (car code)))) + (setq code (cdr code) + i (1+ i)) + (when code + (princ "\n")))) + ) + +(defmethod srecode-dump ((ins srecode-template-inserter) indent) + "Dump the state of the SRecode template inserter INS." + (princ "INS: \"") + (princ (object-name-string ins)) + (when (oref ins :secondname) + (princ "\" : \"") + (princ (oref ins :secondname))) + (princ "\" type \"") + (let* ((oc (symbol-name (object-class ins))) + (junk (string-match "srecode-template-inserter-" oc)) + (on (if junk + (substring oc (match-end 0)) + oc))) + (princ on)) + (princ "\"") + ) + +(provide 'srecode/compile) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: srecode/loaddefs +;; generated-autoload-load-name: "srecode/compile" +;; End: + +;;; srecode/compile.el ends here diff --git a/lisp/cedet/srecode/cpp.el b/lisp/cedet/srecode/cpp.el new file mode 100644 index 00000000000..28613a004ed --- /dev/null +++ b/lisp/cedet/srecode/cpp.el @@ -0,0 +1,149 @@ +;;; srecode/cpp.el --- C++ specific handlers for Semantic Recoder + +;; Copyright (C) 2007, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Jan Moringen <scymtym@users.sourceforge.net> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Supply some C++ specific dictionary fillers and helpers + +;;; Code: + +;;; :cpp ARGUMENT HANDLING +;; +;; When a :cpp argument is required, fill the dictionary with +;; information about the current C++ file. +;; +;; Error if not in a C++ mode. + +(require 'srecode) +(require 'srecode/dictionary) +(require 'srecode/semantic) + +;;;###autoload +(defun srecode-semantic-handle-:cpp (dict) + "Add macros into the dictionary DICT based on the current c++ file. +Adds the following: +FILENAME_SYMBOL - filename converted into a C compat symbol. +HEADER - Shown section if in a header file." + ;; A symbol representing + (let ((fsym (file-name-nondirectory (buffer-file-name))) + (case-fold-search t)) + + ;; Are we in a header file? + (if (string-match "\\.\\(h\\|hh\\|hpp\\|h\\+\\+\\)$" fsym) + (srecode-dictionary-show-section dict "HEADER") + (srecode-dictionary-show-section dict "NOTHEADER")) + + ;; Strip out bad characters + (while (string-match "\\.\\| " fsym) + (setq fsym (replace-match "_" t t fsym))) + (srecode-dictionary-set-value dict "FILENAME_SYMBOL" fsym) + ) + ) + +(define-mode-local-override srecode-semantic-apply-tag-to-dict + c++-mode (tag-wrapper dict) + "Apply C++ specific features from TAG-WRAPPER into DICT. +Calls `srecode-semantic-apply-tag-to-dict-default' first. Adds +special behavior for tag of classes include, using and function." + + ;; Use default implementation to fill in the basic properties. + (srecode-semantic-apply-tag-to-dict-default tag-wrapper dict) + + ;; Pull out the tag for the individual pieces. + (let* ((tag (oref tag-wrapper :prime)) + (class (semantic-tag-class tag))) + + ;; Add additional information based on the class of the tag. + (cond + ;; + ;; INCLUDE + ;; + ((eq class 'include) + ;; For include tags, we have to discriminate between system-wide + ;; and local includes. + (if (semantic-tag-include-system-p tag) + (srecode-dictionary-show-section dict "SYSTEM") + (srecode-dictionary-show-section dict "LOCAL"))) + + ;; + ;; USING + ;; + ((eq class 'using) + ;; Insert the subject (a tag) of the include statement as VALUE + ;; entry into the dictionary. + (let ((value-tag (semantic-tag-get-attribute tag :value)) + (value-dict (srecode-dictionary-add-section-dictionary + dict "VALUE"))) + (srecode-semantic-apply-tag-to-dict + (srecode-semantic-tag (semantic-tag-name value-tag) + :prime value-tag) + value-dict)) + ;; Discriminate using statements referring to namespaces and + ;; types. + (when (eq (semantic-tag-get-attribute tag :kind) 'namespace) + (srecode-dictionary-show-section dict "NAMESPACE"))) + + ;; + ;; FUNCTION + ;; + ((eq class 'function) + ;; @todo It would be nice to distinguish member functions from + ;; free functions and only apply the const and pure modifiers, + ;; when they make sense. My best bet would be + ;; (semantic-tag-function-parent tag), but it is not there, when + ;; the function is defined in the scope of a class. + (let ((member 't) + (modifiers (semantic-tag-modifiers tag))) + + ;; Add modifiers into the dictionary + (dolist (modifier modifiers) + (let ((modifier-dict (srecode-dictionary-add-section-dictionary + dict "MODIFIERS"))) + (srecode-dictionary-set-value modifier-dict "NAME" modifier))) + + ;; When the function is a member function, it can have + ;; additional modifiers. + (when member + + ;; For member functions, constness is called + ;; 'methodconst-flag'. + (when (semantic-tag-get-attribute tag :methodconst-flag) + (srecode-dictionary-show-section dict "CONST")) + + ;; If the member function is pure virtual, add a dictionary + ;; entry. + (when (semantic-tag-get-attribute tag :pure-virtual-flag) + (srecode-dictionary-show-section dict "PURE")) + ) + )) + )) + ) + +(provide 'srecode/cpp) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: srecode/loaddefs +;; generated-autoload-load-name: "srecode/cpp" +;; End: + +;;; srecode/cpp.el ends here diff --git a/lisp/cedet/srecode/ctxt.el b/lisp/cedet/srecode/ctxt.el new file mode 100644 index 00000000000..8dc302057ff --- /dev/null +++ b/lisp/cedet/srecode/ctxt.el @@ -0,0 +1,247 @@ +;;; srecode/ctxt.el --- Derive a context from the source buffer. + +;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Manage context calculations for Semantic Recoder. +;; +;; SRecode templates are always bound to a context. By calculating +;; the current context, we can narrow down the selection of possible +;; templates to something reasonable. +;; +;; Alternately, code here will find a context for templates that +;; require different pieces of code placed in multiple areas. + +(require 'semantic) +(require 'semantic/tag-ls) + +(declare-function srecode-dictionary-show-section "srecode/dictionary") +(declare-function srecode-dictionary-set-value "srecode/dictionary") + +;;; Code: + +(define-overload srecode-calculate-context () + "Calculate the context at the current point. +The returned context is a list, with the top-most context first. +Each returned context is a string that that would show up in a `context' +statement in an `.srt' file. + +Some useful context values used by the provided srecode templates are: + \"file\" - Templates that for a file (such as an empty file.) + \"empty\" - The file is empty + \"declaration\" - Top-level declarations in a file. + \"include\" - In or near include statements + \"package\" - In or near provide statements + \"function\" - In or near function statements + \"NAME\" - Near functions within NAME namespace or class + \"variable\" - In or near variable statements. + \"type\" - In or near type declarations. + \"comment\" - In a comment + \"classdecl\" - Declarations within a class/struct/etc. + \"variable\" - In or near class fields + \"function\" - In or near methods/functions + \"virtual\" - Nearby items are virtual + \"pure\" - and those virtual items are pure virtual + \"type\" - In or near type declarations. + \"comment\" - In a comment in a block of code + -- these items show up at the end of the context list. -- + \"public\", \"protected\", \"private\" - + In or near a section of public/pritected/private entries. + \"code\" - In a block of code. + \"string\" - In a string in a block of code + \"comment\" - In a comment in a block of code + + ... More later." + ) + +(defun srecode-calculate-nearby-things () + ;; NOTE: May need to add bounes to this FCN + "Calculate the CONTEXT type items nearby the current point. +Assume that what we want to insert next is based on what is just +before point. If there is nothing, then assume it is whatever is +after point." + ;; @todo - ADD BOUNDS TO THE PREV/NEXT TAG SEARCH + ;; thus classdecl "near" stuff cannot be + ;; outside the bounds of the type in question. + (let ((near (semantic-find-tag-by-overlay-prev)) + (prot nil) + (ans nil)) + (if (not near) + (setq near (semantic-find-tag-by-overlay-next))) + (when near + ;; Calculate the type of thing we are near. + (if (not (semantic-tag-of-class-p near 'function)) + (setq ans (cons (symbol-name (semantic-tag-class near)) ans)) + ;; if the symbol NEAR has a parent, + (let ((p (semantic-tag-function-parent near))) + (setq ans (cons (symbol-name (semantic-tag-class near)) ans)) + (cond ((semantic-tag-p p) + (setq ans (cons (semantic-tag-name p) ans))) + ((stringp p) + (setq ans (cons p ans))) + (t nil))) + ;; Was it virtual? + (when (semantic-tag-get-attribute near :virtual) + (setq ans (cons "virtual" ans))) + ;; Was it pure? + (when (semantic-tag-get-attribute near :pure-virtual-flag) + (setq ans (cons "pure" ans))) + ) + ;; Calculate the protection + (setq prot (semantic-tag-protection near)) + (when (and prot (not (eq prot 'unknown))) + (setq ans (cons (symbol-name prot) ans))) + ) + (nreverse ans))) + +(defun srecode-calculate-context-font-lock () + "Calculate an srecode context by using font-lock." + (let ((face (get-text-property (point) 'face)) + ) + (cond ((member face '(font-lock-string-face + font-lock-doc-face)) + (list "string")) + ((member face '(font-lock-comment-face + font-lock-comment-delimiter-face)) + (list "comment")) + ) + )) + +(defun srecode-calculate-context-default () + "Generic method for calculating a context for srecode." + (if (= (point-min) (point-max)) + (list "file" "empty") + + (semantic-fetch-tags) + (let ((ct (semantic-find-tag-by-overlay)) + ) + (cond ((or (not ct) + ;; Ok, below is a bit C specific. + (and (eq (semantic-tag-class (car ct)) 'type) + (string= (semantic-tag-type (car ct)) "namespace"))) + (cons "declaration" + (or (srecode-calculate-context-font-lock) + (srecode-calculate-nearby-things) + )) + ) + ((eq (semantic-tag-class (car ct)) 'function) + (cons "code" (srecode-calculate-context-font-lock)) + ) + ((eq (semantic-tag-class (car ct)) 'type) ; We know not namespace + (cons "classdecl" + (or (srecode-calculate-context-font-lock) + (srecode-calculate-nearby-things))) + ) + ((and (car (cdr ct)) + (eq (semantic-tag-class (car (cdr ct))) 'type)) + (list "classdecl" + (symbol-name (semantic-tag-class (car ct)))) + ) + ) + ))) + + +;;; HANDLERS +;; +;; The calculated context is one thing, but more info is often available. +;; The context handlers can add info into the active dictionary that is +;; based on the context, such as a method parent name, protection scheme, +;; or other feature. + +(defun srecode-semantic-handle-:ctxt (dict &optional template) + "Add macros into the dictionary DICT based on the current Emacs Lisp file. +Argument TEMPLATE is the template object adding context dictionary +entries. +This might add the following: + VIRTUAL - show a section if a function is virtual + PURE - show a section if a function is pure virtual. + PARENT - The name of a parent type for functions. + PROTECTION - Show a protection section, and what the protection is." + (require 'srecode/dictionary) + (when template + + (let ((name (oref template object-name)) + (cc (if (boundp 'srecode-insertion-start-context) + srecode-insertion-start-context)) + ;(context (oref template context)) + ) + +; (when (and cc +; (null (string= (car cc) context)) +; ) +; ;; No current context, or the base is different, then +; ;; this is the section where we need to recalculate +; ;; the context based on user choice, if possible. +; ;; +; ;; The recalculation is complex, as there are many possibilities +; ;; that need to be divined. Set "cc" to the new context +; ;; at the end. +; ;; +; ;; @todo - +; +; ) + + ;; The various context all have different features. + (let ((ct (nth 0 cc)) + (it (nth 1 cc)) + (last (last cc)) + (parent nil) + ) + (cond ((string= it "function") + (setq parent (nth 2 cc)) + (when parent + (cond ((string= parent "virtual") + (srecode-dictionary-show-section dict "VIRTUAL") + (when (nth 3 cc) + (srecode-dictionary-show-section dict "PURE")) + ) + (t + (srecode-dictionary-set-value dict "PARENT" parent)))) + ) + ((and (string= it "type") + (or (string= name "function") (string= name "method"))) + ;; If we have a type, but we insert a fcn, then use that type + ;; as the function parent. + (let ((near (semantic-find-tag-by-overlay-prev))) + (when (and near (semantic-tag-of-class-p near 'type)) + (srecode-dictionary-set-value + dict "PARENT" (semantic-tag-name near)))) + ) + ((string= ct "code") + ;;(let ((analyzer (semantic-analyze-current-context))) + ;; @todo - Use the analyze to setup things like local + ;; variables we might use or something. + nil + ;;) + ) + (t + nil)) + (when (member last '("public" "private" "protected")) + ;; Hey, fancy that, we can do both. + (srecode-dictionary-set-value dict "PROTECTION" parent) + (srecode-dictionary-show-section dict "PROTECTION")) + )) + )) + + +(provide 'srecode/ctxt) + +;;; srecode/ctxt.el ends here diff --git a/lisp/cedet/srecode/dictionary.el b/lisp/cedet/srecode/dictionary.el new file mode 100644 index 00000000000..c637f1f2a5f --- /dev/null +++ b/lisp/cedet/srecode/dictionary.el @@ -0,0 +1,565 @@ +;;; srecode-dictionary.el --- Dictionary code for the semantic recoder. + +;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Dictionaries contain lists of names and their assocaited values. +;; These dictionaries are used to fill in macros from recoder templates. + +;;; Code: + +;;; CLASSES + +(require 'eieio) +(require 'srecode) +(require 'srecode/table) +(eval-when-compile (require 'semantic)) + +(declare-function srecode-compile-parse-inserter "srecode/compile") +(declare-function srecode-dump-code-list "srecode/compile") +(declare-function srecode-load-tables-for-mode "srecode/find") +(declare-function srecode-insert-code-stream "srecode/insert") +(declare-function data-debug-new-buffer "data-debug") +(declare-function data-debug-insert-object-slots "eieio-datadebug") +(declare-function srecode-field "srecode/fields") + +(defclass srecode-dictionary () + ((namehash :initarg :namehash + :documentation + "Hash table containing the names of all the templates.") + (buffer :initarg :buffer + :documentation + "The buffer this dictionary was initialized with.") + (parent :initarg :parent + :type (or null srecode-dictionary) + :documentation + "The parent dictionary. +Symbols not appearing in this dictionary will be checked against the +parent dictionary.") + (origin :initarg :origin + :type string + :documentation + "A string representing the origin of this dictionary. +Useful only while debugging.") + ) + "Dictionary of symbols and what they mean. +Dictionaries are used to look up named symbols from +templates to decide what to do with those symbols.") + +(defclass srecode-dictionary-compound-value () + () + "A compound dictionary value. +Values stored in a dictionary must be a STRING, +a dictionary for showing sections, or an instance of a subclass +of this class. + +Compound dictionary values derive from this class, and must +provide a sequence of method implementations to convert into +a string." + :abstract t) + +(defclass srecode-dictionary-compound-variable + (srecode-dictionary-compound-value) + ((value :initarg :value + :documentation + "The value of this template variable. +Variables in template files are usually a single string +which can be inserted into a dictionary directly. + +Some variables may be more complex and involve dictionary +lookups, strings, concatenation, or the like. + +The format of VALUE is determined by current template +formatting rules.") + (compiled :initarg :compiled + :type list + :documentation + "The compiled version of VALUE.") + ) + "A compound dictionary value for template file variables. +You can declare a variable in a template like this: + +set NAME \"str\" macro \"OTHERNAME\" + +with appending various parts together in a list.") + +(defmethod initialize-instance ((this srecode-dictionary-compound-variable) + &optional fields) + "Initialize the compound variable THIS. +Makes sure that :value is compiled." + (let ((newfields nil) + (state nil)) + (while fields + ;; Strip out :state + (if (eq (car fields) :state) + (setq state (car (cdr fields))) + (setq newfields (cons (car (cdr fields)) + (cons (car fields) newfields)))) + (setq fields (cdr (cdr fields)))) + + (when (not state) + (error "Cannot create compound variable without :state")) + + (call-next-method this (nreverse newfields)) + (when (not (slot-boundp this 'compiled)) + (let ((val (oref this :value)) + (comp nil)) + (while val + (let ((nval (car val)) + ) + (cond ((stringp nval) + (setq comp (cons nval comp))) + ((and (listp nval) + (equal (car nval) 'macro)) + (require 'srecode/compile) + (setq comp (cons + (srecode-compile-parse-inserter + (cdr nval) + state) + comp))) + (t + (error "Don't know how to handle variable value %S" nval))) + ) + (setq val (cdr val))) + (oset this :compiled (nreverse comp)))))) + +;;; DICTIONARY METHODS +;; + +(defun srecode-create-dictionary (&optional buffer-or-parent) + "Create a dictionary for BUFFER. +If BUFFER-OR-PARENT is not specified, assume a buffer, and +use the current buffer. +If BUFFER-OR-PARENT is another dictionary, then remember the +parent within the new dictionary, and assume that BUFFER +is the same as belongs to the parent dictionary. +The dictionary is initialized with variables setup for that +buffer's table. +If BUFFER-OR-PARENT is t, then this dictionary should not be +assocated with a buffer or parent." + (save-excursion + (let ((parent nil) + (buffer nil) + (origin nil) + (initfrombuff nil)) + (cond ((bufferp buffer-or-parent) + (set-buffer buffer-or-parent) + (setq buffer buffer-or-parent + origin (buffer-name buffer-or-parent) + initfrombuff t)) + ((srecode-dictionary-child-p buffer-or-parent) + (setq parent buffer-or-parent + buffer (oref buffer-or-parent buffer) + origin (concat (object-name buffer-or-parent) " in " + (if buffer (buffer-name buffer) + "no buffer"))) + (when buffer + (set-buffer buffer))) + ((eq buffer-or-parent t) + (setq buffer nil + origin "Unspecified Origin")) + (t + (setq buffer (current-buffer) + origin (concat "Unspecified. Assume " + (buffer-name buffer)) + initfrombuff t) + ) + ) + (let ((dict (srecode-dictionary + major-mode + :buffer buffer + :parent parent + :namehash (make-hash-table :test 'equal + :size 20) + :origin origin))) + ;; Only set up the default variables if we are being built + ;; directroy for a particular buffer. + (when initfrombuff + ;; Variables from the table we are inserting from. + ;; @todo - get a better tree of tables. + (let ((mt (srecode-get-mode-table major-mode)) + (def (srecode-get-mode-table 'default))) + ;; Each table has multiple template tables. + ;; Do DEF first so that MT can override any values. + (srecode-dictionary-add-template-table dict def) + (srecode-dictionary-add-template-table dict mt) + )) + dict)))) + +(defmethod srecode-dictionary-add-template-table ((dict srecode-dictionary) + tpl) + "Insert into DICT the variables found in table TPL. +TPL is an object representing a compiled template file." + (when tpl + (let ((tabs (oref tpl :tables))) + (while tabs + (let ((vars (oref (car tabs) variables))) + (while vars + (srecode-dictionary-set-value + dict (car (car vars)) (cdr (car vars))) + (setq vars (cdr vars)))) + (setq tabs (cdr tabs)))))) + + +(defmethod srecode-dictionary-set-value ((dict srecode-dictionary) + name value) + "In dictionary DICT, set NAME to have VALUE." + ;; Validate inputs + (if (not (stringp name)) + (signal 'wrong-type-argument (list name 'stringp))) + ;; Add the value. + (with-slots (namehash) dict + (puthash name value namehash)) + ) + +(defmethod srecode-dictionary-add-section-dictionary ((dict srecode-dictionary) + name &optional show-only) + "In dictionary DICT, add a section dictionary for section macro NAME. +Return the new dictionary. + +You can add several dictionaries to the same section macro. +For each dictionary added to a macro, the block of codes in the +template will be repeated. + +If optional argument SHOW-ONLY is non-nil, then don't add a new dictionarly +if there is already one in place. Also, don't add FIRST/LAST entries. +These entries are not needed when we are just showing a section. + +Each dictionary added will automatically get values for positional macros +which will enable SECTIONS to be enabled. + + * FIRST - The first entry in the table. + * NOTFIRST - Not the first entry in the table. + * LAST - The last entry in the table + * NOTLAST - Not the last entry in the table. + +Adding a new dictionary will alter these values in previously +inserted dictionaries." + ;; Validate inputs + (if (not (stringp name)) + (signal 'wrong-type-argument (list name 'stringp))) + (let ((new (srecode-create-dictionary dict)) + (ov (srecode-dictionary-lookup-name dict name))) + + (when (not show-only) + ;; Setup the FIRST/NOTFIRST and LAST/NOTLAST entries. + (if (null ov) + (progn + (srecode-dictionary-show-section new "FIRST") + (srecode-dictionary-show-section new "LAST")) + ;; Not the very first one. Lets clean up CAR. + (let ((tail (car (last ov)))) + (srecode-dictionary-hide-section tail "LAST") + (srecode-dictionary-show-section tail "NOTLAST") + ) + (srecode-dictionary-show-section new "NOTFIRST") + (srecode-dictionary-show-section new "LAST")) + ) + + (when (or (not show-only) (null ov)) + (srecode-dictionary-set-value dict name (append ov (list new)))) + ;; Return the new sub-dictionary. + new)) + +(defmethod srecode-dictionary-show-section ((dict srecode-dictionary) name) + "In dictionary DICT, indicate that the section NAME should be exposed." + ;; Validate inputs + (if (not (stringp name)) + (signal 'wrong-type-argument (list name 'stringp))) + ;; Showing a section is just like making a section dictionary, but + ;; with no dictionary values to add. + (srecode-dictionary-add-section-dictionary dict name t) + nil) + +(defmethod srecode-dictionary-hide-section ((dict srecode-dictionary) name) + "In dictionary DICT, indicate that the section NAME should be hidden." + ;; We need to find the has value, and then delete it. + ;; Validate inputs + (if (not (stringp name)) + (signal 'wrong-type-argument (list name 'stringp))) + ;; Add the value. + (with-slots (namehash) dict + (remhash name namehash)) + nil) + +(defmethod srecode-dictionary-merge ((dict srecode-dictionary) otherdict) + "Merge into DICT the dictionary entries from OTHERDICT." + (when otherdict + (maphash + (lambda (key entry) + ;; Only merge in the new values if there was no old value. + ;; This protects applications from being whacked, and basically + ;; makes these new section dictionary entries act like + ;; "defaults" instead of overrides. + (when (not (srecode-dictionary-lookup-name dict key)) + (cond ((and (listp entry) (srecode-dictionary-p (car entry))) + ;; A list of section dictionaries. + ;; We need to merge them in. + (while entry + (let ((new-sub-dict + (srecode-dictionary-add-section-dictionary + dict key))) + (srecode-dictionary-merge new-sub-dict (car entry))) + (setq entry (cdr entry))) + ) + + (t + (srecode-dictionary-set-value dict key entry))) + )) + (oref otherdict namehash)))) + +(defmethod srecode-dictionary-lookup-name ((dict srecode-dictionary) + name) + "Return information about the current DICT's value for NAME." + (if (not (slot-boundp dict 'namehash)) + nil + ;; Get the value of this name from the dictionary + (or (with-slots (namehash) dict + (gethash name namehash)) + (and (not (member name '("FIRST" "LAST" "NOTFIRST" "NOTLAST"))) + (oref dict parent) + (srecode-dictionary-lookup-name (oref dict parent) name)) + ))) + +(defmethod srecode-root-dictionary ((dict srecode-dictionary)) + "For dictionary DICT, return the root dictionary. +The root dictionary is usually for a current or active insertion." + (let ((ans dict)) + (while (oref ans parent) + (setq ans (oref ans parent))) + ans)) + +;;; COMPOUND VALUE METHODS +;; +;; Compound values must provide at least the toStriong method +;; for use in converting the compound value into sometehing insertable. + +(defmethod srecode-compound-toString ((cp srecode-dictionary-compound-value) + function + dictionary) + "Convert the compound dictionary value CP to a string. +If FUNCTION is non-nil, then FUNCTION is somehow applied to an aspect +of the compound value. The FUNCTION could be a fraction +of some function symbol with a logical prefix excluded. + +If you subclass `srecode-dictionary-compound-value' then this +method could return nil, but if it does that, it must insert +the value itself using `princ', or by detecting if the current +standard out is a buffer, and using `insert'." + (object-name cp)) + +(defmethod srecode-dump ((cp srecode-dictionary-compound-value) + &optional indent) + "Display information about this compound value." + (princ (object-name cp)) + ) + +(defmethod srecode-compound-toString ((cp srecode-dictionary-compound-variable) + function + dictionary) + "Convert the compound dictionary variable value CP into a string. +FUNCTION and DICTIONARY are as for the baseclass." + (require 'srecode/insert) + (srecode-insert-code-stream (oref cp compiled) dictionary)) + + +(defmethod srecode-dump ((cp srecode-dictionary-compound-variable) + &optional indent) + "Display information about this compound value." + (require 'srecode/compile) + (princ "# Compound Variable #\n") + (let ((indent (+ 4 (or indent 0))) + (cmp (oref cp compiled)) + ) + (srecode-dump-code-list cmp (make-string indent ? )) + )) + +;;; FIELD EDITING COMPOUND VALUE +;; +;; This is an interface to using field-editing objects +;; instead of asking questions. This provides the basics +;; behind this compound value. + +(defclass srecode-field-value (srecode-dictionary-compound-value) + ((firstinserter :initarg :firstinserter + :documentation + "The inserter object for the first occurance of this field.") + (defaultvalue :initarg :defaultvalue + :documentation + "The default value for this inserter.") + ) + "When inserting values with editable field mode, a dictionary value. +Compound values allow a field to be stored in the dictionary for when +it is referenced a second time. This compound value can then be +inserted with a new editable field.") + +(defmethod srecode-compound-toString((cp srecode-field-value) + function + dictionary) + "Convert this field into an insertable string." + (require 'srecode/fields) + ;; If we are not in a buffer, then this is not supported. + (when (not (bufferp standard-output)) + (error "FIELDS invoked while inserting template to non-buffer.")) + + (if function + (error "@todo: Cannot mix field insertion with functions.") + + ;; No function. Perform a plain field insertion. + ;; We know we are in a buffer, so we can perform the insertion. + (let* ((dv (oref cp defaultvalue)) + (sti (oref cp firstinserter)) + (start (point)) + (name (oref sti :object-name))) + + (if (or (not dv) (string= dv "")) + (insert name) + (insert dv)) + + (srecode-field name :name name + :start start + :end (point) + :prompt (oref sti prompt) + :read-fcn (oref sti read-fcn) + ) + )) + ;; Returning nil is a signal that we have done the insertion ourselves. + nil) + + +;;; Higher level dictionary functions +;; +(defun srecode-create-section-dictionary (sectiondicts STATE) + "Create a dictionary with section entries for a template. +The format for SECTIONDICTS is what is emitted from the template parsers. +STATE is the current compiler state." + (when sectiondicts + (let ((new (srecode-create-dictionary t))) + ;; Loop over each section. The section is a macro w/in the + ;; template. + (while sectiondicts + (let* ((sect (car (car sectiondicts))) + (entries (cdr (car sectiondicts))) + (subdict (srecode-dictionary-add-section-dictionary new sect)) + ) + ;; Loop over each entry. This is one variable in the + ;; section dictionary. + (while entries + (let ((tname (semantic-tag-name (car entries))) + (val (semantic-tag-variable-default (car entries)))) + (if (eq val t) + (srecode-dictionary-show-section subdict tname) + (cond + ((and (stringp (car val)) + (= (length val) 1)) + (setq val (car val))) + (t + (setq val (srecode-dictionary-compound-variable + tname :value val :state STATE)))) + (srecode-dictionary-set-value + subdict tname val)) + (setq entries (cdr entries)))) + ) + (setq sectiondicts (cdr sectiondicts))) + new))) + +;;; DUMP DICTIONARY +;; +;; Make a dictionary, and dump it's contents. + +(defun srecode-adebug-dictionary () + "Run data-debug on this mode's dictionary." + (interactive) + (require 'eieio-datadebug) + (require 'semantic) + (require 'srecode/find) + (let* ((modesym major-mode) + (start (current-time)) + (junk (or (progn (srecode-load-tables-for-mode modesym) + (srecode-get-mode-table modesym)) + (error "No table found for mode %S" modesym))) + (dict (srecode-create-dictionary (current-buffer))) + (end (current-time)) + ) + (message "Creating a dictionary took %.2f seconds." + (semantic-elapsed-time start end)) + (data-debug-new-buffer "*SRECODE ADEBUG*") + (data-debug-insert-object-slots dict "*"))) + +(defun srecode-dictionary-dump () + "Dump a typical fabricated dictionary." + (interactive) + (require 'srecode/find) + (let ((modesym major-mode)) + ;; This load allows the dictionary access to inherited + ;; and stacked dictionary entries. + (srecode-load-tables-for-mode modesym) + (let ((tmp (srecode-get-mode-table modesym)) + ) + (if (not tmp) + (error "No table found for mode %S" modesym)) + ;; Now make the dictionary. + (let ((dict (srecode-create-dictionary (current-buffer)))) + (with-output-to-temp-buffer "*SRECODE DUMP*" + (princ "DICTIONARY FOR ") + (princ major-mode) + (princ "\n--------------------------------------------\n") + (srecode-dump dict)) + )))) + +(defmethod srecode-dump ((dict srecode-dictionary) &optional indent) + "Dump a dictionary." + (if (not indent) (setq indent 0)) + (maphash (lambda (key entry) + (princ (make-string indent ? )) + (princ " ") + (princ key) + (princ " ") + (cond ((and (listp entry) + (srecode-dictionary-p (car entry))) + (let ((newindent (if indent + (+ indent 4) + 4))) + (while entry + (princ " --> SUBDICTIONARY ") + (princ (object-name dict)) + (princ "\n") + (srecode-dump (car entry) newindent) + (setq entry (cdr entry)) + )) + (princ "\n") + ) + ((srecode-dictionary-compound-value-child-p entry) + (srecode-dump entry indent) + (princ "\n") + ) + (t + (prin1 entry) + ;(princ "\n") + )) + (terpri) + ) + (oref dict namehash)) + ) + +(provide 'srecode/dictionary) + +;;; srecode/dictionary.el ends here diff --git a/lisp/cedet/srecode/document.el b/lisp/cedet/srecode/document.el new file mode 100644 index 00000000000..fd35a1828e3 --- /dev/null +++ b/lisp/cedet/srecode/document.el @@ -0,0 +1,841 @@ +;;; srecode/document.el --- Documentation (comment) generation + +;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Routines for fabricating human readable text from function and +;; variable names as base-text for function comments. Document is not +;; meant to generate end-text for any function. It is merely meant to +;; provide some useful base words and text, and as a framework for +;; managing comments. +;; +;;; Origins: +;; +;; Document was first written w/ cparse, a custom regexp based c parser. +;; +;; Document was then ported to cedet/semantic using sformat (super +;; format) as the templating engine. +;; +;; Document has now been ported to srecode, using the semantic recoder +;; as the templating engine. + +;; This file combines srecode-document.el and srecode-document-vars.el +;; from the CEDET repository. + +(require 'srecode/args) +(require 'srecode/dictionary) +(require 'srecode/extract) +(require 'srecode/insert) +(require 'srecode/semantic) + +(require 'semantic) +(require 'semantic/tag) +(require 'semantic/doc) +(require 'pulse) + +;;; Code: + +(defgroup document nil + "File and tag browser frame." + :group 'texinfo + :group 'srecode) + +(defcustom srecode-document-autocomment-common-nouns-abbrevs + '( + ("sock\\(et\\)?" . "socket") + ("addr\\(ess\\)?" . "address") + ("buf\\(f\\(er\\)?\\)?" . "buffer") + ("cur\\(r\\(ent\\)?\\)?" . "current") + ("dev\\(ice\\)?" . "device") + ("doc" . "document") + ("i18n" . "internationalization") + ("file" . "file") + ("line" . "line") + ("l10n" . "localization") + ("msg\\|message" . "message") + ("name" . "name") + ("next\\|nxt" . "next") + ("num\\(ber\\)?" . "number") + ("port" . "port") + ("host" . "host") + ("obj\\|object" . "object") + ("previous\\|prev" . "previous") + ("str\\(ing\\)?" . "string") + ("use?r" . "user") + ("\\(^\\|\\s-\\)id\\($\\|\\s-\\)" . "Identifier") ;complex cause ;common syllable + ) + "List of common English abbreviations or full words. +These are nouns (as opposed to verbs) for use in creating expanded +versions of names.This is an alist with each element of the form: + (MATCH . RESULT) +MATCH is a regexp to match in the type field. +RESULT is a string." + :group 'document + :type '(repeat (cons (string :tag "Regexp") + (string :tag "Doc Text")))) + +(defcustom srecode-document-autocomment-function-alist + '( + ("abort" . "Aborts the") + ;; trick to get re-alloc and alloc to pair into one sentence. + ("realloc" . "moves or ") + ("alloc\\(ate\\)?" . "Allocates and initializes a new ") + ("clean" . "Cleans up the") + ("clobber" . "Removes") + ("close" . "Cleanly closes") + ("check" . "Checks the") + ("comp\\(are\\)?" . "Compares the") + ("create" . "Creates a new ") + ("find" . "Finds ") + ("free" . "Frees up space") + ("gen\\(erate\\)?" . "Generates a new ") + ("get\\|find" . "Looks for the given ") + ("gobble" . "Removes") + ("he?lp" . "Provides help for") + ("li?ste?n" . "Listens for ") + ("connect" . "Connects to ") + ("acc?e?pt" . "Accepts a ") + ("load" . "Loads in ") + ("match" . "Check that parameters match") + ("name" . "Provides a name which ") + ("new" . "Allocates a ") + ("parse" . "Parses the parameters and returns ") + ("print\\|display" . "Prints out") + ("read" . "Reads from") + ("reset" . "Resets the parameters and returns") + ("scan" . "Scans the ") + ("setup\\|init\\(iallize\\)?" . "Initializes the ") + ("select" . "Chooses the ") + ("send" . "Sends a") + ("re?c\\(v\\|ieves?\\)" . "Receives a ") + ("to" . "Converts ") + ("update" . "Updates the ") + ("wait" . "Waits for ") + ("write" . "Writes to") + ) + "List of names to string match against the function name. +This is an alist with each element of the form: + (MATCH . RESULT) +MATCH is a regexp to match in the type field. +RESULT is a string. + +Certain prefixes may always mean the same thing, and the same comment +can be used as a beginning for the description. Regexp should be +lower case since the string they are compared to is downcased. +A string may end in a space, in which case, last-alist is searched to +see how best to describe what can be returned. +Doesn't always work correctly, but that is just because English +doesn't always work correctly." + :group 'document + :type '(repeat (cons (string :tag "Regexp") + (string :tag "Doc Text")))) + +(defcustom srecode-document-autocomment-common-nouns-abbrevs + '( + ("sock\\(et\\)?" . "socket") + ("addr\\(ess\\)?" . "address") + ("buf\\(f\\(er\\)?\\)?" . "buffer") + ("cur\\(r\\(ent\\)?\\)?" . "current") + ("dev\\(ice\\)?" . "device") + ("file" . "file") + ("line" . "line") + ("msg\\|message" . "message") + ("name" . "name") + ("next\\|nxt" . "next") + ("port" . "port") + ("host" . "host") + ("obj\\|object" . "object") + ("previous\\|prev" . "previous") + ("str\\(ing\\)?" . "string") + ("use?r" . "user") + ("num\\(ber\\)?" . "number") + ("\\(^\\|\\s-\\)id\\($\\|\\s-\\)" . "Identifier") ;complex cause ;commen sylable + ) + "List of common English abbreviations or full words. +These are nouns (as opposed to verbs) for use in creating expanded +versions of names.This is an alist with each element of the form: + (MATCH . RESULT) +MATCH is a regexp to match in the type field. +RESULT is a string." + :group 'document + :type '(repeat (cons (string :tag "Regexp") + (string :tag "Doc Text")))) + +(defcustom srecode-document-autocomment-return-first-alist + '( + ;; Static must be first in the list to provide the intro to the sentence + ("static" . "Locally defined function which ") + ("Bool\\|BOOL" . "Status of ") + ) + "List of regexp matches for types. +They provide a little bit of text when typing information is +described. +This is an alist with each element of the form: + (MATCH . RESULT) +MATCH is a regexp to match in the type field. +RESULT is a string." + :group 'document + :type '(repeat (cons (string :tag "Regexp") + (string :tag "Doc Text")))) + +(defcustom srecode-document-autocomment-return-last-alist + '( + ("static[ \t\n]+struct \\([a-zA-Z0-9_]+\\)" . "%s") + ("struct \\([a-zA-Z0-9_]+\\)" . "%s") + ("static[ \t\n]+union \\([a-zA-Z0-9_]+\\)" . "%s") + ("union \\([a-zA-Z0-9_]+\\)" . "%s") + ("static[ \t\n]+enum \\([a-zA-Z0-9_]+\\)" . "%s") + ("enum \\([a-zA-Z0-9_]+\\)" . "%s") + ("static[ \t\n]+\\([a-zA-Z0-9_]+\\)" . "%s") + ("\\([a-zA-Z0-9_]+\\)" . "of type %s") + ) + "List of regexps which provide the type of the return value. +This is an alist with each element of the form: + (MATCH . RESULT) +MATCH is a regexp to match in the type field. +RESULT is a string, which can contain %s, whih is replaced with +`match-string' 1." + :group 'document + :type '(repeat (cons (string :tag "Regexp") + (string :tag "Doc Text")))) + +(defcustom srecode-document-autocomment-param-alist + '( ("[Cc]txt" . "Context") + ("[Ii]d" . "Identifier of") + ("[Tt]ype" . "Type of") + ("[Nn]ame" . "Name of") + ("argc" . "Number of arguments") + ("argv" . "Argument vector") + ("envp" . "Environment variable vector") + ) + "Alist of common variable names appearing as function parameters. +This is an alist with each element of the form: + (MATCH . RESULT) +MATCH is a regexp to match in the type field. +RESULT is a string of text to use to describe MATCH. +When one is encountered, document-insert-parameters will automatically +place this comment after the parameter name." + :group 'document + :type '(repeat (cons (string :tag "Regexp") + (string :tag "Doc Text")))) + +(defcustom srecode-document-autocomment-param-type-alist + '(("const" . "Constant") + ("void" . "Empty") + ("char[ ]*\\*" . "String ") + ("\\*\\*" . "Pointer to ") + ("\\*" . "Pointer ") + ("char[ ]*\\([^ \t*]\\|$\\)" . "Character") + ("int\\|long" . "Number of") + ("FILE" . "File of") + ("float\\|double" . "Value of") + ;; How about some X things? + ("Bool\\|BOOL" . "Flag") + ("Window" . "Window") + ("GC" . "Graphic Context") + ("Widget" . "Widget") + ) + "Alist of input parameter types and strings desribing them. +This is an alist with each element of the form: + (MATCH . RESULT) +MATCH is a regexp to match in the type field. +RESULT is a string." + :group 'document + :type '(repeat (cons (string :tag "Regexp") + (string :tag "Doc Text")))) + +;;;###autoload +(defun srecode-document-insert-comment () + "Insert some comments. +Whack any comments that may be in the way and replace them. +If the region is active, then insert group function comments. +If the cursor is in a comment, figure out what kind of comment it is + and replace it. +If the cursor is in a function, insert a function comment. +If the cursor is on a one line prototype, then insert post-fcn comments." + (interactive) + (semantic-fetch-tags) + (let ((ctxt (srecode-calculate-context))) + (if ;; Active region stuff. + (or srecode-handle-region-when-non-active-flag + (eq last-command 'mouse-drag-region) + (and transient-mark-mode mark-active)) + (if (> (point) (mark)) + (srecode-document-insert-group-comments (mark) (point)) + (srecode-document-insert-group-comments (point) (mark))) + ;; ELSE + + ;; A declaration comment. Find what it documents. + (when (equal ctxt '("declaration" "comment")) + + ;; If we are on a one line tag/comment, go to that fcn. + (if (save-excursion (back-to-indentation) + (semantic-current-tag)) + (back-to-indentation) + + ;; Else, do we have a fcn following us? + (let ((tag (semantic-find-tag-by-overlay-next))) + (when tag (semantic-go-to-tag tag)))) + ) + + ;; Now analyze the tag we may be on. + + (if (semantic-current-tag) + (cond + ;; A one-line variable + ((and (semantic-tag-of-class-p (semantic-current-tag) 'variable) + (srecode-document-one-line-tag-p (semantic-current-tag))) + (srecode-document-insert-variable-one-line-comment)) + ;; A plain function + ((semantic-tag-of-class-p (semantic-current-tag) 'function) + (srecode-document-insert-function-comment)) + ;; Don't know. + (t + (error "Not sure what to comment")) + ) + + ;; ELSE, no tag. Perhaps we should just insert a nice section + ;; header?? + + (let ((title (read-string "Section Title (RET to skip): "))) + + (when (and (stringp title) (not (= (length title) 0))) + (srecode-document-insert-section-comment title))) + + )))) + +(defun srecode-document-insert-section-comment (&optional title) + "Insert a section comment with TITLE." + (interactive "sSection Title: ") + + (srecode-load-tables-for-mode major-mode) + (srecode-load-tables-for-mode major-mode 'document) + + (if (not (srecode-table)) + (error "No template table found for mode %s" major-mode)) + + (let* ((dict (srecode-create-dictionary)) + (temp (srecode-template-get-table (srecode-table) + "section-comment" + "declaration" + 'document))) + (if (not temp) + (error "No templates for inserting section comments")) + + (when title + (srecode-dictionary-set-value + dict "TITLE" title)) + + (srecode-insert-fcn temp dict) + )) + + +(defun srecode-document-trim-whitespace (str) + "Strip stray whitespace from around STR." + (when (string-match "^\\(\\s-\\|\n\\)+" str) + (setq str (replace-match "" t t str))) + (when (string-match "\\(\\s-\\|\n\\)+$" str) + (setq str (replace-match "" t t str))) + str) + +;;;###autoload +(defun srecode-document-insert-function-comment (&optional fcn-in) + "Insert or replace a function comment. +FCN-IN is the Semantic tag of the function to add a comment too. +If FCN-IN is not provied, the current tag is used instead. +It is assumed that the comment occurs just in front of FCN-IN." + (interactive) + + (srecode-load-tables-for-mode major-mode) + (srecode-load-tables-for-mode major-mode 'document) + + (if (not (srecode-table)) + (error "No template table found for mode %s" major-mode)) + + (let* ((dict (srecode-create-dictionary)) + (temp (srecode-template-get-table (srecode-table) + "function-comment" + "declaration" + 'document))) + (if (not temp) + (error "No templates for inserting function comments")) + + ;; Try to figure out the tag we want to use. + (when (not fcn-in) + (semantic-fetch-tags) + (setq fcn-in (semantic-current-tag))) + + (when (or (not fcn-in) + (not (semantic-tag-of-class-p fcn-in 'function))) + (error "No tag of class 'function to insert comment for")) + + (if (not (eq (current-buffer) (semantic-tag-buffer fcn-in))) + (error "Only insert comments for tags in the current buffer")) + + ;; Find any existing doc strings. + (semantic-go-to-tag fcn-in) + (beginning-of-line) + (forward-char -1) + + (let ((lextok (semantic-documentation-comment-preceeding-tag fcn-in 'lex)) + (doctext + (srecode-document-function-name-comment fcn-in)) + ) + + (when lextok + (let* ((s (semantic-lex-token-start lextok)) + (e (semantic-lex-token-end lextok)) + (plaintext + (srecode-document-trim-whitespace + (save-excursion + (goto-char s) + (semantic-doc-snarf-comment-for-tag nil)))) + (extract (condition-case nil + (srecode-extract temp s e) + (error nil)) + ) + (distance (count-lines e (semantic-tag-start fcn-in))) + (belongelsewhere (save-excursion + (goto-char s) + (back-to-indentation) + (semantic-current-tag))) + ) + + (when (not belongelsewhere) + + (pulse-momentary-highlight-region s e) + + ;; There are many possible states that comment could be in. + ;; Take a guess about what the user would like to do, and ask + ;; the right kind of question. + (when (or (not (> distance 2)) + (y-or-n-p "Replace this comment? ")) + + (when (> distance 2) + (goto-char e) + (delete-horizontal-space) + (delete-blank-lines)) + + (cond + ((and plaintext (not extract)) + (if (y-or-n-p "Convert old-style comment to Template with old text? ") + (setq doctext plaintext)) + (delete-region s e) + (goto-char s)) + (extract + (when (y-or-n-p "Refresh pre-existing comment (recycle old doc)? ") + (delete-region s e) + (goto-char s) + (setq doctext + (srecode-document-trim-whitespace + (srecode-dictionary-lookup-name extract "DOC"))))) + )) + ))) + + (beginning-of-line) + + ;; Perform the insertion + (let ((srecode-semantic-selected-tag fcn-in) + (srecode-semantic-apply-tag-augment-hook + (lambda (tag dict) + (srecode-dictionary-set-value + dict "DOC" + (if (eq tag fcn-in) + doctext + (srecode-document-parameter-comment tag)) + ))) + ) + (srecode-insert-fcn temp dict) + )) + )) + +;;;###autoload +(defun srecode-document-insert-variable-one-line-comment (&optional var-in) + "Insert or replace a variable comment. +VAR-IN is the Semantic tag of the function to add a comment too. +If VAR-IN is not provied, the current tag is used instead. +It is assumed that the comment occurs just after VAR-IN." + (interactive) + + (srecode-load-tables-for-mode major-mode) + (srecode-load-tables-for-mode major-mode 'document) + + (if (not (srecode-table)) + (error "No template table found for mode %s" major-mode)) + + (let* ((dict (srecode-create-dictionary)) + (temp (srecode-template-get-table (srecode-table) + "variable-same-line-comment" + "declaration" + 'document))) + (if (not temp) + (error "No templates for inserting variable comments")) + + ;; Try to figure out the tag we want to use. + (when (not var-in) + (semantic-fetch-tags) + (setq var-in (semantic-current-tag))) + + (when (or (not var-in) + (not (semantic-tag-of-class-p var-in 'variable))) + (error "No tag of class 'variable to insert comment for")) + + (if (not (eq (current-buffer) (semantic-tag-buffer var-in))) + (error "Only insert comments for tags in the current buffer")) + + ;; Find any existing doc strings. + (goto-char (semantic-tag-end var-in)) + (skip-syntax-forward "-" (point-at-eol)) + (let ((lextok (semantic-doc-snarf-comment-for-tag 'lex)) + ) + + (when lextok + (let ((s (semantic-lex-token-start lextok)) + (e (semantic-lex-token-end lextok))) + + (pulse-momentary-highlight-region s e) + + (when (not (y-or-n-p "A comment already exists. Replace? ")) + (error "Quit")) + + ;; Extract text from the existing comment. + (srecode-extract temp s e) + + (delete-region s e) + (goto-char s) ;; To avoid adding a CR. + )) + ) + + ;; Clean up the end of the line and use handy comment-column. + (end-of-line) + (delete-horizontal-space) + (move-to-column comment-column t) + (when (< (point) (point-at-eol)) (end-of-line)) + + ;; Perform the insertion + (let ((srecode-semantic-selected-tag var-in) + (srecode-semantic-apply-tag-augment-hook + (lambda (tag dict) + (srecode-dictionary-set-value + dict "DOC" (srecode-document-parameter-comment + tag)))) + ) + (srecode-insert-fcn temp dict) + )) + ) + +;;;###autoload +(defun srecode-document-insert-group-comments (beg end) + "Insert group comments around the active between BEG and END. +If the region includes only parts of some tags, expand out +to the beginning and end of the tags on the region. +If there is only one tag in the region, complain." + (interactive "r") + (srecode-load-tables-for-mode major-mode) + (srecode-load-tables-for-mode major-mode 'document) + + (if (not (srecode-table)) + (error "No template table found for mode %s" major-mode)) + + (let* ((dict (srecode-create-dictionary)) + (context "declaration") + (temp-start nil) + (temp-end nil) + (tag-start (save-excursion + (goto-char beg) + (or (semantic-current-tag) + (semantic-find-tag-by-overlay-next)))) + (tag-end (save-excursion + (goto-char end) + (or (semantic-current-tag) + (semantic-find-tag-by-overlay-prev)))) + (parent-tag nil) + (first-pos beg) + (second-pos end) + ) + + ;; If beg/end wrapped nothing, then tag-start,end would actually + ;; point at some odd stuff that is out of order. + (when (or (not tag-start) (not tag-end) + (> (semantic-tag-end tag-start) + (semantic-tag-start tag-end))) + (setq tag-start nil + tag-end nil)) + + (when tag-start + ;; If tag-start and -end are the same, and it is a class or + ;; struct, try to find child tags inside the classdecl. + (cond + ((and (eq tag-start tag-end) + tag-start + (semantic-tag-of-class-p tag-start 'type)) + (setq parent-tag tag-start) + (setq tag-start (semantic-find-tag-by-overlay-next beg) + tag-end (semantic-find-tag-by-overlay-prev end)) + ) + ((eq (semantic-find-tag-parent-by-overlay tag-start) tag-end) + (setq parent-tag tag-end) + (setq tag-end (semantic-find-tag-by-overlay-prev end)) + ) + ((eq tag-start (semantic-find-tag-parent-by-overlay tag-end)) + (setq parent-tag tag-start) + (setq tag-start (semantic-find-tag-by-overlay-next beg)) + ) + ) + + (when parent-tag + ;; We are probably in a classdecl + ;; @todo -could I really use (srecode-calculate-context) ? + + (setq context "classdecl") + ) + + ;; Derive start and end locations based on the tags. + (setq first-pos (semantic-tag-start tag-start) + second-pos (semantic-tag-end tag-end)) + ) + ;; Now load the templates + (setq temp-start (srecode-template-get-table (srecode-table) + "group-comment-start" + context + 'document) + temp-end (srecode-template-get-table (srecode-table) + "group-comment-end" + context + 'document)) + + (when (or (not temp-start) (not temp-end)) + (error "No templates for inserting group comments")) + + ;; Setup the name of this group ahead of time. + + ;; @todo - guess at a name based on common strings + ;; of the tags in the group. + (srecode-dictionary-set-value + dict "GROUPNAME" + (read-string "Name of group: ")) + + ;; Perform the insertion + ;; Do the end first so we don't need to recalculate anything. + ;; + (goto-char second-pos) + (end-of-line) + (srecode-insert-fcn temp-end dict) + + (goto-char first-pos) + (beginning-of-line) + (srecode-insert-fcn temp-start dict) + + )) + + +;;; Document Generation Functions +;; +;; Routines for making up English style comments. + +(defun srecode-document-function-name-comment (tag) + "Create documentation for the function defined in TAG. +If we can identify a verb in the list followed by some +name part then check the return value to see if we can use that to +finish off the sentence. ie. any function with 'alloc' in it will be +allocating something based on its type." + (let ((al srecode-document-autocomment-return-first-alist) + (dropit nil) + (tailit nil) + (news "") + (fname (semantic-tag-name tag)) + (retval (or (semantic-tag-type tag) ""))) + (if (listp retval) + ;; convert a type list into a long string to analyze. + (setq retval (car retval))) + ;; check for modifiers like static + (while al + (if (string-match (car (car al)) (downcase retval)) + (progn + (setq news (concat news (cdr (car al)))) + (setq dropit t) + (setq al nil))) + (setq al (cdr al))) + ;; check for verb parts! + (setq al srecode-document-autocomment-function-alist) + (while al + (if (string-match (car (car al)) (downcase fname)) + (progn + (setq news + (concat news (if dropit (downcase (cdr (car al))) + (cdr (car al))))) + ;; if we end in a space, then we are expecting a potential + ;; return value. + (if (= ? (aref news (1- (length news)))) + (setq tailit t)) + (setq al nil))) + (setq al (cdr al))) + ;; check for noun parts! + (setq al srecode-document-autocomment-common-nouns-abbrevs) + (while al + (if (string-match (car (car al)) (downcase fname)) + (progn + (setq news + (concat news (if dropit (downcase (cdr (car al))) + (cdr (car al))))) + (setq al nil))) + (setq al (cdr al))) + ;; add tailers to names which are obviously returning something. + (if tailit + (progn + (setq al srecode-document-autocomment-return-last-alist) + (while al + (if (string-match (car (car al)) (downcase retval)) + (progn + (setq news + (concat news " " + ;; this one may use parts of the return value. + (format (cdr (car al)) + (srecode-document-programmer->english + (substring retval (match-beginning 1) + (match-end 1)))))) + (setq al nil))) + (setq al (cdr al))))) + news)) + +(defun srecode-document-parameter-comment (param &optional commentlist) + "Convert tag or string PARAM into a name,comment pair. +Optional COMMENTLIST is list of previously existing comments to +use instead in alist form. If the name doesn't appear in the list of +standard names, then englishify it instead." + (let ((cmt "") + (aso srecode-document-autocomment-param-alist) + (fnd nil) + (name (if (stringp param) param (semantic-tag-name param))) + (tt (if (stringp param) nil (semantic-tag-type param)))) + ;; Make sure the type is a string. + (if (listp tt) + (setq tt (semantic-tag-name tt))) + ;; Find name description parts. + (while aso + (if (string-match (car (car aso)) name) + (progn + (setq fnd t) + (setq cmt (concat cmt (cdr (car aso)))))) + (setq aso (cdr aso))) + (if (/= (length cmt) 0) + nil + ;; finally check for array parts + (if (and (not (stringp param)) (semantic-tag-modifiers param)) + (setq cmt (concat cmt "array of "))) + (setq aso srecode-document-autocomment-param-type-alist) + (while (and aso tt) + (if (string-match (car (car aso)) tt) + (setq cmt (concat cmt (cdr (car aso))))) + (setq aso (cdr aso)))) + ;; Convert from programmer to english. + (if (not fnd) + (setq cmt (concat cmt " " + (srecode-document-programmer->english name)))) + cmt)) + +(defun srecode-document-programmer->english (programmer) + "Take PROGRAMMER and convert it into English. +Works with the following rules: + 1) convert all _ into spaces. + 2) inserts spaces between CamelCasing word breaks. + 3) expands noun names based on common programmer nouns. + + This function is designed for variables, not functions. This does +not account for verb parts." + (if (string= "" programmer) + "" + (let ((ind 0) ;index in string + (llow nil) ;lower/upper case flag + (newstr nil) ;new string being generated + (al nil)) ;autocomment list + ;; + ;; 1) Convert underscores + ;; + (while (< ind (length programmer)) + (setq newstr (concat newstr + (if (= (aref programmer ind) ?_) + " " (char-to-string (aref programmer ind))))) + (setq ind (1+ ind))) + (setq programmer newstr + newstr nil + ind 0) + ;; + ;; 2) Find word breaks between case changes + ;; + (while (< ind (length programmer)) + (setq newstr + (concat newstr + (let ((tc (aref programmer ind))) + (if (and (>= tc ?a) (<= tc ?z)) + (progn + (setq llow t) + (char-to-string tc)) + (if llow + (progn + (setq llow nil) + (concat " " (char-to-string tc))) + (char-to-string tc)))))) + (setq ind (1+ ind))) + ;; + ;; 3) Expand the words if possible + ;; + (setq llow nil + ind 0 + programmer newstr + newstr nil) + (while (string-match (concat "^\\s-*\\([^ \t\n]+\\)") programmer) + (let ((ts (substring programmer (match-beginning 1) (match-end 1))) + (end (match-end 1))) + (setq al srecode-document-autocomment-common-nouns-abbrevs) + (setq llow nil) + (while al + (if (string-match (car (car al)) (downcase ts)) + (progn + (setq newstr (concat newstr (cdr (car al)))) + ;; don't terminate because we may actuall have 2 words + ;; next to eachother we didn't identify before + (setq llow t))) + (setq al (cdr al))) + (if (not llow) (setq newstr (concat newstr ts))) + (setq newstr (concat newstr " ")) + (setq programmer (substring programmer end)))) + newstr))) + +;;; UTILS +;; +(defun srecode-document-one-line-tag-p (tag) + "Does TAG fit on one line with space on the end?" + (save-excursion + (semantic-go-to-tag tag) + (and (<= (semantic-tag-end tag) (point-at-eol)) + (goto-char (semantic-tag-end tag)) + (< (current-column) 70)))) + +(provide 'srecode/document) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: srecode/loaddefs +;; generated-autoload-load-name: "srecode/document" +;; End: + +;;; srecode/document.el ends here diff --git a/lisp/cedet/srecode/el.el b/lisp/cedet/srecode/el.el new file mode 100644 index 00000000000..3df606a59c5 --- /dev/null +++ b/lisp/cedet/srecode/el.el @@ -0,0 +1,113 @@ +;;; srecode/el.el --- Emacs Lisp specific arguments + +;; Copyright (C) 2008 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Emacs Lisp specific handlers. To use these handlers in your +;; template, add the :name part to your template argument list. +;; +;; Error if not in a Emacs Lisp mode + +;;; Code: + +(require 'srecode) +(require 'srecode/semantic) + +(declare-function semanticdb-brute-find-tags-by-class "semantic/db-find") + +;;;###autoload +(defun srecode-semantic-handle-:el (dict) + "Add macros into the dictionary DICT based on the current Emacs Lisp file. +Adds the following: + PRENAME - The common name prefix of this file." + (let* ((names (append (semantic-find-tags-by-class 'function (current-buffer)) + (semantic-find-tags-by-class 'variable (current-buffer))) + ) + (common (try-completion "" names))) + + (srecode-dictionary-set-value dict "PRENAME" common) + )) + +;;;###autoload +(defun srecode-semantic-handle-:el-custom (dict) + "Add macros into the dictionary DICT based on the current Emacs Lisp file. +Adds the following: + GROUP - The 'defgroup' name we guess you want for variables. + FACEGROUP - The `defgroup' name you might want for faces." + (require 'semantic/db-find) + (let ((groups (semanticdb-strip-find-results + (semanticdb-brute-find-tags-by-class 'customgroup))) + (varg nil) + (faceg nil) + ) + + ;; Pick the best group + (while groups + (cond ((string-match "face" (semantic-tag-name (car groups))) + (setq faceg (car groups))) + ((not varg) + (setq varg (car groups))) + (t + ;; What about other groups? + )) + (setq groups (cdr groups))) + + ;; Double check the facegroup. + (setq faceg (or faceg varg)) + + ;; Setup some variables + (srecode-dictionary-set-value dict "GROUP" (semantic-tag-name varg)) + (srecode-dictionary-set-value dict "FACEGROUP" (semantic-tag-name faceg)) + + )) + +(define-mode-local-override srecode-semantic-apply-tag-to-dict + emacs-lisp-mode (tagobj dict) + "Apply Emacs Lisp specific features from TAGOBJ into DICT. +Calls `srecode-semantic-apply-tag-to-dict-default' first." + (srecode-semantic-apply-tag-to-dict-default tagobj dict) + + ;; Pull out the tag for the individual pieces. + (let* ((tag (oref tagobj :prime)) + (doc (semantic-tag-docstring tag))) + + ;; It is much more common to have doc on ELisp. + (srecode-dictionary-set-value dict "DOC" doc) + + (cond + ;; + ;; FUNCTION + ;; + ((eq (semantic-tag-class tag) 'function) + (if (semantic-tag-get-attribute tag :user-visible-flag) + (srecode-dictionary-set-value dict "INTERACTIVE" " (interactive)\n ") + (srecode-dictionary-set-value dict "INTERACTIVE" "")))))) + + +(provide 'srecode/el) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: srecode/loaddefs +;; generated-autoload-load-name: "srecode/el" +;; End: + +;;; srecode/el.el ends here diff --git a/lisp/cedet/srecode/expandproto.el b/lisp/cedet/srecode/expandproto.el new file mode 100644 index 00000000000..eb09ed260bd --- /dev/null +++ b/lisp/cedet/srecode/expandproto.el @@ -0,0 +1,132 @@ +;;; srecode/expandproto.el --- Expanding prototypes. + +;; Copyright (C) 2007 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Methods for expanding a prototype into an implementation. + +(require 'ring) +(require 'semantic) +(require 'semantic/analyze) +(require 'srecode/insert) +(require 'srecode/dictionary) + +(declare-function semantic-brute-find-tag-by-attribute-value "semantic/find") + +;;; Code: +(defcustom srecode-expandproto-template-file-alist + '( ( c++-mode . "srecode-expandproto-cpp.srt" ) + ) + ;; @todo - Make this variable auto-generated from the Makefile. + "Associate template files for expanding prototypes to a major mode." + :group 'srecode + :type '(repeat (cons (sexp :tag "Mode") + (sexp :tag "Filename")) + )) + +;;;###autoload +(defun srecode-insert-prototype-expansion () + "Insert get/set methods for the current class." + (interactive) + + (srecode-load-tables-for-mode major-mode) + (srecode-load-tables-for-mode major-mode + srecode-expandproto-template-file-alist) + + (if (not (srecode-table)) + (error "No template table found for mode %s" major-mode)) + + (let ((proto + ;; Step 1: Find the prototype, or prototype list to expand. + (srecode-find-prototype-for-expansion))) + + (if (not proto) + (error "Could not find prototype to expand")) + + ;; Step 2: Insert implementations of the prototypes. + + + )) + +(defun srecode-find-prototype-for-expansion () + "Find a prototype to use for expanding into an implementation." + ;; We may find a prototype tag in one of several places. + ;; Search in order of logical priority. + (let ((proto nil) + ) + + ;; 1) A class full of prototypes under point. + (let ((tag (semantic-current-tag))) + (when tag + (when (not (semantic-tag-of-class-p tag 'type)) + (setq tag (semantic-current-tag-parent)))) + (when (and tag (semantic-tag-of-class-p tag 'type)) + ;; If the current class has prototype members, then + ;; we will do the whole class! + (require 'semantic/find) + (if (semantic-brute-find-tag-by-attribute-value + :prototype t + (semantic-tag-type-members tag)) + (setq proto tag))) + ) + + ;; 2) A prototype under point. + (when (not proto) + (let ((tag (semantic-current-tag))) + (when (and tag + (and + (semantic-tag-of-class-p tag 'function) + (semantic-tag-get-attribute tag :prototype))) + (setq proto tag)))) + + ;; 3) A tag in the kill ring that is a prototype + (when (not proto) + (if (ring-empty-p senator-tag-ring) + nil ;; Not for us. + (let ((tag (ring-ref senator-tag-ring 0)) + ) + (when + (and tag + (or + (and + (semantic-tag-of-class-p tag 'function) + (semantic-tag-get-attribute tag :prototype)) + (and + (semantic-tag-of-class-p tag 'type) + (require 'semantic/find) + (semantic-brute-find-tag-by-attribute-value + :prototype t + (semantic-tag-type-members tag)))) + ) + (setq proto tag)) + ))) + + proto)) + +(provide 'srecode-expandproto) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: srecode/loaddefs +;; generated-autoload-load-name: "srecode/expandproto" +;; End: + +;;; srecode/expandproto.el ends here diff --git a/lisp/cedet/srecode/extract.el b/lisp/cedet/srecode/extract.el new file mode 100644 index 00000000000..c6de1e1faaa --- /dev/null +++ b/lisp/cedet/srecode/extract.el @@ -0,0 +1,242 @@ +;;; srecode/extract.el --- Extract content from previously inserted macro. + +;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Extract content from a previously inserted macro. +;; +;; The extraction routines can be handy if you want to extract users +;; added text from the middle of a template inserted block of text. +;; This code will not work for all templates. It will only work for +;; templates with unique static text between all the different insert +;; macros. +;; +;; That said, it will handle include and section templates, so complex +;; or deep template calls can be extracted. +;; +;; This code was specifically written for srecode-document, which +;; wants to extract user written text, and re-use it in a reformatted +;; comment. + +(require 'srecode) +(require 'srecode/compile) +(require 'srecode/insert) + +;;; Code: + +(defclass srecode-extract-state () + ((anchor :initform nil + :documentation + "The last known plain-text end location.") + (lastinserter :initform nil + :documentation + "The last inserter with 'later extraction type.") + (lastdict :initform nil + :documentation + "The dictionary associated with lastinserter.") + ) + "The current extraction state.") + +(defmethod srecode-extract-state-set ((st srecode-extract-state) ins dict) + "Set onto the extract state ST a new inserter INS and dictinary DICT." + (oset st lastinserter ins) + (oset st lastdict dict)) + +(defmethod srecode-extract-state-set-anchor ((st srecode-extract-state)) + "Reset the achor point on extract state ST." + (oset st anchor (point))) + +(defmethod srecode-extract-state-extract ((st srecode-extract-state) + endpoint) + "Perform an extraction on the extract state ST with ENDPOITNT. +If there was no waiting inserter, do nothing." + (when (oref st lastinserter) + (save-match-data + (srecode-inserter-extract (oref st lastinserter) + (oref st anchor) + endpoint + (oref st lastdict) + st)) + ;; Clear state. + (srecode-extract-state-set st nil nil))) + +;;; Extraction +;l +(defun srecode-extract (template start end) + "Extract TEMPLATE from between START and END in the current buffer. +Uses TEMPLATE's constant strings to break up the text and guess what +the dictionary entries were for that block of text." + (save-excursion + (save-restriction + (narrow-to-region start end) + (let ((dict (srecode-create-dictionary t)) + (state (srecode-extract-state "state")) + ) + (goto-char start) + (srecode-extract-method template dict state) + dict)))) + +(defmethod srecode-extract-method ((st srecode-template) dictionary + state) + "Extract template ST and store extracted text in DICTIONARY. +Optional STARTRETURN is a symbol in which the start of the first +plain-text match occured." + (srecode-extract-code-stream (oref st code) dictionary state)) + +(defun srecode-extract-code-stream (code dictionary state) + "Extract CODE from buffer text into DICTIONARY. +Uses string constants in CODE to split up the buffer. +Uses STATE to maintain the current extraction state." + (while code + (cond + + ;; constant strings need mark the end of old inserters that + ;; need to extract values, or are just there. + ((stringp (car code)) + (srecode-extract-state-set-anchor state) + ;; When we have a string, find it in the collection, then extract + ;; that start point as the end point of the inserter + (unless (re-search-forward (regexp-quote (car code)) + (point-max) t) + (error "Unable to extract all dictionary entries")) + + (srecode-extract-state-extract state (match-beginning 0)) + (goto-char (match-end 0)) + ) + + ;; Some inserters are simple, and need to be extracted after + ;; we find our next block of static text. + ((eq (srecode-inserter-do-extract-p (car code)) 'later) + (srecode-extract-state-set state (car code) dictionary) + ) + + ;; Some inserter want to start extraction now, such as sections. + ;; We can't predict the end point till we parse out the middle. + ((eq (srecode-inserter-do-extract-p (car code)) 'now) + (srecode-extract-state-set-anchor state) + (srecode-inserter-extract (car code) (point) nil dictionary state)) + ) + (setq code (cdr code)) + )) + +;;; Inserter Base Extractors +;; +(defmethod srecode-inserter-do-extract-p ((ins srecode-template-inserter)) + "Return non-nil if this inserter can extract values." + nil) + +(defmethod srecode-inserter-extract ((ins srecode-template-inserter) + start end dict state) + "Extract text from START/END and store in DICT. +Return nil as this inserter will extract nothing." + nil) + +;;; Variable extractor is simple and can extract later. +;; +(defmethod srecode-inserter-do-extract-p ((ins srecode-template-inserter-variable)) + "Return non-nil if this inserter can extract values." + 'later) + +(defmethod srecode-inserter-extract ((ins srecode-template-inserter-variable) + start end vdict state) + "Extract text from START/END and store in VDICT. +Return t if something was extracted. +Return nil if this inserter doesn't need to extract anything." + (srecode-dictionary-set-value vdict + (oref ins :object-name) + (buffer-substring-no-properties + start end) + ) + t) + +;;; Section Inserter +;; +(defmethod srecode-inserter-do-extract-p ((ins srecode-template-inserter-section-start)) + "Return non-nil if this inserter can extract values." + 'now) + +(defmethod srecode-inserter-extract ((ins srecode-template-inserter-section-start) + start end indict state) + "Extract text from START/END and store in INDICT. +Return the starting location of the first plain-text match. +Return nil if nothing was extracted." + (let ((name (oref ins :object-name)) + (subdict (srecode-create-dictionary indict)) + (allsubdict nil) + ) + + ;; Keep extracting till we can extract no more. + (while (condition-case nil + (progn + (srecode-extract-method + (oref ins template) subdict state) + t) + (error nil)) + + ;; Success means keep this subdict, and also make a new one for + ;; the next iteration. + (setq allsubdict (cons subdict allsubdict)) + (setq subdict (srecode-create-dictionary indict)) + ) + + (srecode-dictionary-set-value indict name (nreverse allsubdict)) + + nil)) + +;;; Include Extractor must extract now. +;; +(defmethod srecode-inserter-do-extract-p ((ins srecode-template-inserter-include)) + "Return non-nil if this inserter can extract values." + 'now) + +(defmethod srecode-inserter-extract ((ins srecode-template-inserter-include) + start end dict state) + "Extract text from START/END and store in DICT. +Return the starting location of the first plain-text match. +Return nil if nothing was extracted." + (goto-char start) + (srecode-insert-include-lookup ins dict) + ;; There are two modes for includes. One is with no dict, + ;; so it is inserted straight. If the dict has a name, then + ;; we need to run once per dictionary occurance. + (if (not (string= (oref ins :object-name) "")) + ;; With a name, do the insertion. + (let ((subdict (srecode-dictionary-add-section-dictionary + dict (oref ins :object-name)))) + (error "Need to implement include w/ name extractor.") + ;; Recurse into the new template while no errors. + (while (condition-case nil + (progn + (srecode-extract-method + (oref ins includedtemplate) subdict + state) + t) + (error nil)))) + + ;; No stream, do the extraction into the current dictionary. + (srecode-extract-method (oref ins includedtemplate) dict + state)) + ) + + +(provide 'srecode/extract) + +;;; srecode/extract.el ends here diff --git a/lisp/cedet/srecode/fields.el b/lisp/cedet/srecode/fields.el new file mode 100644 index 00000000000..f335b0fef79 --- /dev/null +++ b/lisp/cedet/srecode/fields.el @@ -0,0 +1,438 @@ +;;; srecode/fields.el --- Handling type-in fields in a buffer. +;; +;; Copyright (C) 2009 Free Software Foundation, Inc. +;; +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Idea courtesy of yasnippets. +;; +;; If someone prefers not to type unknown dictionary entries into +;; mini-buffer prompts, it could instead use in-buffer fields. +;; +;; A template-region specifies an area in which the fields exist. If +;; the cursor exits the region, all fields are cleared. +;; +;; Each field is independent, but some are linked together by name. +;; Typing in one will cause the matching ones to change in step. +;; +;; Each field has 2 overlays. The second overlay allows control in +;; the character just after the field, but does not highlight it. + +;; Keep this library independent of SRecode proper. +(require 'eieio) + +;;; Code: +(defvar srecode-field-archive nil + "While inserting a set of fields, collect in this variable. +Once an insertion set is done, these fields will be activated.") + +(defface srecode-field-face + '((((class color) (background dark)) + (:underline "green")) + (((class color) (background light)) + (:underline "green4"))) + "*Face used to specify editable fields from a template." + :group 'semantic-faces) + +;;; BASECLASS +;; +;; Fields and the template region share some basic overlay features. + +(defclass srecode-overlaid () + ((overlay :documentation + "Overlay representing this field. +The overlay will crossreference this object.") + ) + "An object that gets automatically bound to an overlay. +Has virtual :start and :end initializers.") + +(defmethod initialize-instance ((olaid srecode-overlaid) &optional args) + "Initialize OLAID, being sure it archived." + ;; Extract :start and :end from the olaid list. + (let ((newargs nil) + (olay nil) + start end + ) + + (while args + (cond ((eq (car args) :start) + (setq args (cdr args)) + (setq start (car args)) + (setq args (cdr args)) + ) + ((eq (car args) :end) + (setq args (cdr args)) + (setq end (car args)) + (setq args (cdr args)) + ) + (t + (push (car args) newargs) + (setq args (cdr args)) + (push (car args) newargs) + (setq args (cdr args))) + )) + + ;; Create a temporary overlay now. We have to use an overlay and + ;; not a marker becaues of the in-front insertion rules. The rules + ;; are backward from what is wanted while typing. + (setq olay (make-overlay start end (current-buffer) t nil)) + (overlay-put olay 'srecode-init-only t) + + (oset olaid overlay olay) + (call-next-method olaid (nreverse newargs)) + + )) + +(defmethod srecode-overlaid-activate ((olaid srecode-overlaid)) + "Activate the overlaid area." + (let* ((ola (oref olaid overlay)) + (start (overlay-start ola)) + (end (overlay-end ola)) + ;; Create a new overlay here. + (ol (make-overlay start end (current-buffer) nil t))) + + ;; Remove the old one. + (delete-overlay ola) + + (overlay-put ol 'srecode olaid) + + (oset olaid overlay ol) + + )) + +(defmethod srecode-delete ((olaid srecode-overlaid)) + "Delete the overlay from OLAID." + (delete-overlay (oref olaid overlay)) + (slot-makeunbound olaid 'overlay) + ) + +(defmethod srecode-empty-region-p ((olaid srecode-overlaid)) + "Return non-nil if the region covered by OLAID is of length 0." + (= 0 (srecode-region-size olaid))) + +(defmethod srecode-region-size ((olaid srecode-overlaid)) + "Return the length of region covered by OLAID." + (let ((start (overlay-start (oref olaid overlay))) + (end (overlay-end (oref olaid overlay)))) + (- end start))) + +(defmethod srecode-point-in-region-p ((olaid srecode-overlaid)) + "Return non-nil if point is in the region of OLAID." + (let ((start (overlay-start (oref olaid overlay))) + (end (overlay-end (oref olaid overlay)))) + (and (>= (point) start) (<= (point) end)))) + +(defun srecode-overlaid-at-point (class) + "Return a list of overlaid fields of type CLASS at point." + (let ((ol (overlays-at (point))) + (ret nil)) + (while ol + (let ((tmp (overlay-get (car ol) 'srecode))) + (when (and tmp (object-of-class-p tmp class)) + (setq ret (cons tmp ret)))) + (setq ol (cdr ol))) + (car (nreverse ret)))) + +(defmethod srecode-overlaid-text ((olaid srecode-overlaid) &optional set-to) + "Return the text under OLAID. +If SET-TO is a string, then replace the text of OLAID wit SET-TO." + (let* ((ol (oref olaid overlay)) + (start (overlay-start ol))) + (if (not (stringp set-to)) + ;; Just return it. + (buffer-substring-no-properties start (overlay-end ol)) + ;; Replace it. + (save-excursion + (delete-region start (overlay-end ol)) + (goto-char start) + (insert set-to) + (move-overlay ol start (+ start (length set-to)))) + nil))) + +;;; INSERTED REGION +;; +;; Managing point-exit, and flushing fields. + +(defclass srecode-template-inserted-region (srecode-overlaid) + ((fields :documentation + "A list of field overlays in this region.") + (active-region :allocation :class + :initform nil + :documentation + "The template region currently being handled.") + ) + "Manage a buffer region in which fields exist.") + +(defmethod initialize-instance ((ir srecode-template-inserted-region) + &rest args) + "Initialize IR, capturing the active fields, and creating the overlay." + ;; Fill in the fields + (oset ir fields srecode-field-archive) + (setq srecode-field-archive nil) + + ;; Initailize myself first. + (call-next-method) + ) + +(defmethod srecode-overlaid-activate ((ir srecode-template-inserted-region)) + "Activate the template area for IR." + ;; Activate all our fields + + (dolist (F (oref ir fields)) + (srecode-overlaid-activate F)) + + ;; Activate our overlay. + (call-next-method) + + ;; Position the cursor at the first field + (let ((first (car (oref ir fields)))) + (goto-char (overlay-start (oref first overlay)))) + + ;; Set ourselves up as 'active' + (oset ir active-region ir) + + ;; Setup the post command hook. + (add-hook 'post-command-hook 'srecode-field-post-command t t) + ) + +(defmethod srecode-delete ((ir srecode-template-inserted-region)) + "Call into our base, but also clear out the fields." + ;; Clear us out of the baseclass. + (oset ir active-region nil) + ;; Clear our fields. + (mapc 'srecode-delete (oref ir fields)) + ;; Call to our base + (call-next-method) + ;; Clear our hook. + (remove-hook 'post-command-hook 'srecode-field-post-command t) + ) + +(defsubst srecode-active-template-region () + "Return the active region for template fields." + (oref srecode-template-inserted-region active-region)) + +(defun srecode-field-post-command () + "Srecode field handler in the post command hook." + (let ((ar (srecode-active-template-region)) + ) + (if (not ar) + ;; Find a bug and fix it. + (remove-hook 'post-command-hook 'srecode-field-post-command t) + (if (srecode-point-in-region-p ar) + nil ;; Keep going + ;; We moved out of the temlate. Cancel the edits. + (srecode-delete ar))) + )) + +;;; FIELDS + +(defclass srecode-field (srecode-overlaid) + ((tail :documentation + "Overlay used on character just after this field. +Used to provide useful keybindings there.") + (name :initarg :name + :documentation + "The name of this field. +Usually initialized from the dictionary entry name that +the users needs to edit.") + (prompt :initarg :prompt + :documentation + "A prompt string to use if this were in the minibuffer. +Display when the cursor enters this field.") + (read-fcn :initarg :read-fcn + :documentation + "A function that would be used to read a string. +Try to use this to provide useful completion when available.") + ) + "Representation of one field.") + +(defvar srecode-field-keymap + (let ((km (make-sparse-keymap))) + (define-key km "\C-i" 'srecode-field-next) + (define-key km "\M-\C-i" 'srecode-field-prev) + (define-key km "\C-e" 'srecode-field-end) + (define-key km "\C-a" 'srecode-field-start) + (define-key km "\M-m" 'srecode-field-start) + (define-key km "\C-c\C-c" 'srecode-field-exit-ask) + km) + "Keymap applied to field overlays.") + +(defmethod initialize-instance ((field srecode-field) &optional args) + "Initialize FIELD, being sure it archived." + (add-to-list 'srecode-field-archive field t) + (call-next-method) + ) + +(defmethod srecode-overlaid-activate ((field srecode-field)) + "Activate the FIELD area." + (call-next-method) + + (let* ((ol (oref field overlay)) + (end nil) + (tail nil)) + (overlay-put ol 'face 'srecode-field-face) + (overlay-put ol 'keymap srecode-field-keymap) + (overlay-put ol 'modification-hooks '(srecode-field-mod-hook)) + (overlay-put ol 'insert-behind-hooks '(srecode-field-behind-hook)) + (overlay-put ol 'insert-in-front-hooks '(srecode-field-mod-hook)) + + (setq end (overlay-end ol)) + (setq tail (make-overlay end (+ end 1) (current-buffer))) + + (overlay-put tail 'srecode field) + (overlay-put tail 'keymap srecode-field-keymap) + (overlay-put tail 'face 'srecode-field-face) + (oset field tail tail) + ) + ) + +(defmethod srecode-delete ((olaid srecode-field)) + "Delete our secondary overlay." + ;; Remove our spare overlay + (delete-overlay (oref olaid tail)) + (slot-makeunbound olaid 'tail) + ;; Do our baseclass work. + (call-next-method) + ) + +(defvar srecode-field-replication-max-size 100 + "Maximum size of a field before cancelling replication.") + +(defun srecode-field-mod-hook (ol after start end &optional pre-len) + "Modification hook for the field overlay. +OL is the overlay. +AFTER is non-nil if it is called after the change. +START and END are the bounds of the change. +PRE-LEN is used in the after mode for the length of the changed text." + (when (and after (not undo-in-progress)) + (let* ((field (overlay-get ol 'srecode)) + (inhibit-point-motion-hooks t) + (inhibit-modification-hooks t) + ) + ;; Sometimes a field is deleted, but we might still get a stray + ;; event. Lets just ignore those events. + (when (slot-boundp field 'overlay) + ;; First, fixup the two overlays, in case they got confused. + (let ((main (oref field overlay)) + (tail (oref field tail))) + (move-overlay main + (overlay-start main) + (1- (overlay-end tail))) + (move-overlay tail + (1- (overlay-end tail)) + (overlay-end tail))) + ;; Now capture text from the main overlay, and propagate it. + (let* ((new-text (srecode-overlaid-text field)) + (region (srecode-active-template-region)) + (allfields (when region (oref region fields))) + (name (oref field name))) + (dolist (F allfields) + (when (and (not (eq F field)) + (string= name (oref F name))) + (if (> (length new-text) srecode-field-replication-max-size) + (message "Field size too large for replication.") + ;; If we find other fields with the same name, then keep + ;; then all together. Disable change hooks to make sure + ;; we don't get a recursive edit. + (srecode-overlaid-text F new-text) + )))) + )))) + +(defun srecode-field-behind-hook (ol after start end &optional pre-len) + "Modification hook for the field overlay. +OL is the overlay. +AFTER is non-nil if it is called after the change. +START and END are the bounds of the change. +PRE-LEN is used in the after mode for the length of the changed text." + (when after + (let* ((field (overlay-get ol 'srecode)) + ) + (move-overlay ol (overlay-start ol) end) + (srecode-field-mod-hook ol after start end pre-len)) + )) + +(defmethod srecode-field-goto ((field srecode-field)) + "Goto the FIELD." + (goto-char (overlay-start (oref field overlay)))) + +(defun srecode-field-next () + "Move to the next field." + (interactive) + (let* ((f (srecode-overlaid-at-point 'srecode-field)) + (tr (srecode-overlaid-at-point 'srecode-template-inserted-region)) + ) + (when (not f) (error "Not in a field")) + (when (not tr) (error "Not in a template region")) + + (let ((fields (oref tr fields))) + (while fields + ;; Loop over fields till we match. Then move to the next one. + (when (eq f (car fields)) + (if (cdr fields) + (srecode-field-goto (car (cdr fields))) + (srecode-field-goto (car (oref tr fields)))) + (setq fields nil) + ) + (setq fields (cdr fields)))) + )) + +(defun srecode-field-prev () + "Move to the prev field." + (interactive) + (let* ((f (srecode-overlaid-at-point 'srecode-field)) + (tr (srecode-overlaid-at-point 'srecode-template-inserted-region)) + ) + (when (not f) (error "Not in a field")) + (when (not tr) (error "Not in a template region")) + + (let ((fields (reverse (oref tr fields)))) + (while fields + ;; Loop over fields till we match. Then move to the next one. + (when (eq f (car fields)) + (if (cdr fields) + (srecode-field-goto (car (cdr fields))) + (srecode-field-goto (car (oref tr fields)))) + (setq fields nil) + ) + (setq fields (cdr fields)))) + )) + +(defun srecode-field-end () + "Move to the end of this field." + (interactive) + (let* ((f (srecode-overlaid-at-point 'srecode-field))) + (goto-char (overlay-end (oref f overlay))))) + +(defun srecode-field-start () + "Move to the end of this field." + (interactive) + (let* ((f (srecode-overlaid-at-point 'srecode-field))) + (goto-char (overlay-start (oref f overlay))))) + +(defun srecode-field-exit-ask () + "Ask if the user wants to exit field-editing mini-mode." + (interactive) + (when (y-or-n-p "Exit field-editing mode? ") + (srecode-delete (srecode-active-template-region)))) + + +(provide 'srecode/fields) + +;;; srecode/fields.el ends here diff --git a/lisp/cedet/srecode/filters.el b/lisp/cedet/srecode/filters.el new file mode 100644 index 00000000000..1e3582f46fb --- /dev/null +++ b/lisp/cedet/srecode/filters.el @@ -0,0 +1,56 @@ +;;; srecode/filters.el --- Filters for use in template variables. + +;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Various useful srecoder template functions. + +;;; Code: + +(require 'newcomment) +(require 'srecode/table) +(require 'srecode/insert) + +(defun srecode-comment-prefix (str) + "Prefix each line of STR with the comment prefix characters." + (let* ((dict srecode-inserter-variable-current-dictionary) + ;; Derive the comment characters to put in front of each line. + (cs (or (and dict + (srecode-dictionary-lookup-name dict "comment_prefix")) + (and comment-multi-line comment-continue) + (and (not comment-multi-line) comment-start))) + (strs (split-string str "\n")) + (newstr "") + ) + (while strs + (cond ((and (not comment-multi-line) (string= (car strs) "")) + ; (setq newstr (concat newstr "\n"))) + ) + (t + (setq newstr (concat newstr cs " " (car strs))))) + (setq strs (cdr strs)) + (when strs (setq newstr (concat newstr "\n")))) + newstr)) + +(provide 'srecode/filters) + +;;; srecode/filters.el ends here + diff --git a/lisp/cedet/srecode/find.el b/lisp/cedet/srecode/find.el new file mode 100644 index 00000000000..aecba0a2ec3 --- /dev/null +++ b/lisp/cedet/srecode/find.el @@ -0,0 +1,261 @@ +;;;; srecode/find.el --- Tools for finding templates in the database. + +;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Various routines that search through various template tables +;; in search of the right template. + +(require 'srecode/ctxt) +(require 'srecode/table) +(require 'srecode/map) + +(declare-function srecode-compile-file "srecode/compile") + +;;; Code: + +(defun srecode-table (&optional mode) + "Return the currently active Semantic Recoder table for this buffer. +Optional argument MODE specifies the mode table to use." + (let* ((modeq (or mode major-mode)) + (table (srecode-get-mode-table modeq))) + + ;; If there isn't one, keep searching backwards for a table. + (while (and (not table) (setq modeq (get-mode-local-parent modeq))) + (setq table (srecode-get-mode-table modeq))) + + ;; Last ditch effort. + (when (not table) + (setq table (srecode-get-mode-table 'default))) + + table)) + +;;; TRACKER +;; +;; Template file tracker for between sessions. +;; +(defun srecode-load-tables-for-mode (mmode &optional appname) + "Load all the template files for MMODE. +Templates are found in the SRecode Template Map. +See `srecode-get-maps' for more. +APPNAME is the name of an application. In this case, +all template files for that application will be loaded." + (require 'srecode/compile) + (let ((files + (if appname + (apply 'append + (mapcar + (lambda (map) + (srecode-map-entries-for-app-and-mode map appname mmode)) + (srecode-get-maps))) + (apply 'append + (mapcar + (lambda (map) + (srecode-map-entries-for-mode map mmode)) + (srecode-get-maps))))) + ) + ;; Don't recurse if we are already the 'default state. + (when (not (eq mmode 'default)) + ;; Are we a derived mode? If so, get the parent mode's + ;; templates loaded too. + (if (get-mode-local-parent mmode) + (srecode-load-tables-for-mode (get-mode-local-parent mmode) + appname) + ;; No parent mode, all templates depend on the defaults being + ;; loaded in, so get that in instead. + (srecode-load-tables-for-mode 'default appname))) + + ;; Load in templates for our major mode. + (dolist (f files) + (let ((mt (srecode-get-mode-table mmode)) + ) + (when (or (not mt) (not (srecode-mode-table-find mt (car f)))) + (srecode-compile-file (car f))) + )) + )) + +;;; SEARCH +;; +;; Find a given template based on name, and features of the current +;; buffer. +(defmethod srecode-template-get-table ((tab srecode-template-table) + template-name &optional + context application) + "Find in the template in table TAB, the template with TEMPLATE-NAME. +Optional argument CONTEXT specifies that the template should part +of a particular context. +The APPLICATION argument is unused." + (if context + ;; If a context is specified, then look it up there. + (let ((ctxth (gethash context (oref tab contexthash)))) + (when ctxth + (gethash template-name ctxth))) + ;; No context, perhaps a merged name? + (gethash template-name (oref tab namehash)))) + +(defmethod srecode-template-get-table ((tab srecode-mode-table) + template-name &optional + context application) + "Find in the template in mode table TAB, the template with TEMPLATE-NAME. +Optional argument CONTEXT specifies a context a particular template +would belong to. +Optional argument APPLICATION restricts searches to only template tables +belonging to a specific application. If APPLICATION is nil, then only +tables that do not belong to an application will be searched." + (let* ((mt tab) + (tabs (oref mt :tables)) + (ans nil)) + (while (and (not ans) tabs) + (let ((app (oref (car tabs) :application))) + (when (or (and (not application) (null app)) + (and application (eq app application))) + (setq ans (srecode-template-get-table (car tabs) template-name + context))) + (setq tabs (cdr tabs)))) + (or ans + ;; Recurse to the default. + (when (not (equal (oref tab :major-mode) 'default)) + (srecode-template-get-table (srecode-get-mode-table 'default) + template-name context application))))) + +;; +;; Find a given template based on a key binding. +;; +(defmethod srecode-template-get-table-for-binding + ((tab srecode-template-table) binding &optional context) + "Find in the template name in table TAB, the template with BINDING. +Optional argument CONTEXT specifies that the template should part +of a particular context." + (let* ((keyout nil) + (hashfcn (lambda (key value) + (when (and (slot-boundp value 'binding) + (oref value binding) + (= (aref (oref value binding) 0) binding)) + (setq keyout key)))) + (contextstr (cond ((listp context) + (car-safe context)) + ((stringp context) + context) + (t nil))) + ) + (if context + (let ((ctxth (gethash contextstr (oref tab contexthash)))) + (when ctxth + ;; If a context is specified, then look it up there. + (maphash hashfcn ctxth) + ;; Context hashes EXCLUDE the context prefix which + ;; we need to include, so concat it here + (when keyout + (setq keyout (concat contextstr ":" keyout))) + ))) + (when (not keyout) + ;; No context, or binding in context. Try full hash. + (maphash hashfcn (oref tab namehash))) + keyout)) + +(defmethod srecode-template-get-table-for-binding + ((tab srecode-mode-table) binding &optional context application) + "Find in the template name in mode table TAB, the template with BINDING. +Optional argument CONTEXT specifies a context a particular template +would belong to. +Optional argument APPLICATION restricts searches to only template tables +belonging to a specific application. If APPLICATION is nil, then only +tables that do not belong to an application will be searched." + (let* ((mt tab) + (tabs (oref mt :tables)) + (ans nil)) + (while (and (not ans) tabs) + (let ((app (oref (car tabs) :application))) + (when (or (and (not application) (null app)) + (and application (eq app application))) + (setq ans (srecode-template-get-table-for-binding + (car tabs) binding context))) + (setq tabs (cdr tabs)))) + (or ans + ;; Recurse to the default. + (when (not (equal (oref tab :major-mode) 'default)) + (srecode-template-get-table-for-binding + (srecode-get-mode-table 'default) binding context))))) +;;; Interactive +;; +;; Interactive queries into the template data. +;; +(defvar srecode-read-template-name-history nil + "History for completing reads for template names.") + +(defun srecode-all-template-hash (&optional mode hash) + "Create a hash table of all the currently available templates. +Optional argument MODE is the major mode to look for. +Optional argument HASH is the hash table to fill in." + (let* ((mhash (or hash (make-hash-table :test 'equal))) + (mmode (or mode major-mode)) + (mp (get-mode-local-parent mmode)) + ) + ;; Get the parent hash table filled into our current hash. + (when (not (eq mode 'default)) + (if mp + (srecode-all-template-hash mp mhash) + (srecode-all-template-hash 'default mhash))) + ;; Load up the hash table for our current mode. + (let* ((mt (srecode-get-mode-table mmode)) + (tabs (when mt (oref mt :tables))) + ) + (while tabs + ;; Exclude templates for a perticular application. + (when (not (oref (car tabs) :application)) + (maphash (lambda (key temp) + (puthash key temp mhash) + ) + (oref (car tabs) namehash))) + (setq tabs (cdr tabs))) + mhash))) + +(defun srecode-calculate-default-template-string (hash) + "Calculate the name of the template to use as a DEFAULT. +Templates are read from HASH. +Context into which the template is inserted is calculated +with `srecode-calculate-context'." + (let* ((ctxt (srecode-calculate-context)) + (ans (concat (nth 0 ctxt) ":" (nth 1 ctxt)))) + (if (gethash ans hash) + ans + ;; No hash at the specifics, at least offer + ;; the prefix for the completing read + (concat (nth 0 ctxt) ":")))) + +(defun srecode-read-template-name (prompt &optional initial hist default) + "Completing read for Semantic Recoder template names. +PROMPT is used to query for the name of the template desired. +INITIAL is the initial string to use. +HIST is a history variable to use. +DEFAULT is what to use if the user presses RET." + (srecode-load-tables-for-mode major-mode) + (let* ((hash (srecode-all-template-hash)) + (def (or initial + (srecode-calculate-default-template-string hash)))) + (completing-read prompt hash + nil t def + (or hist + 'srecode-read-template-name-history)))) + +(provide 'srecode/find) + +;;; srecode/find.el ends here diff --git a/lisp/cedet/srecode/getset.el b/lisp/cedet/srecode/getset.el new file mode 100644 index 00000000000..b9ff6af2003 --- /dev/null +++ b/lisp/cedet/srecode/getset.el @@ -0,0 +1,366 @@ +;;; srecode/getset.el --- Package for inserting new get/set methods. + +;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; SRecoder application for inserting new get/set methods into a class. + +(require 'semantic) +(require 'semantic/analyze) +(require 'semantic/find) +(require 'srecode/insert) +(require 'srecode/dictionary) + +;;; Code: +(defvar srecode-insert-getset-fully-automatic-flag nil + "Non-nil means accept choices srecode comes up with without asking.") + +;;;###autoload +(defun srecode-insert-getset (&optional class-in field-in) + "Insert get/set methods for the current class. +CLASS-IN is the semantic tag of the class to update. +FIELD-IN is the semantic tag, or string name, of the field to add. +If you do not specify CLASS-IN or FIELD-IN then a class and field +will be derived." + (interactive) + + (srecode-load-tables-for-mode major-mode) + (srecode-load-tables-for-mode major-mode 'getset) + + (if (not (srecode-table)) + (error "No template table found for mode %s" major-mode)) + + (if (not (srecode-template-get-table (srecode-table) + "getset-in-class" + "declaration" + 'getset)) + (error "No templates for inserting get/set")) + + ;; Step 1: Try to derive the tag for the class we will use + (let* ((class (or class-in (srecode-auto-choose-class (point)))) + (tagstart (semantic-tag-start class)) + (inclass (eq (semantic-current-tag-of-class 'type) class)) + (field nil) + ) + + (when (not class) + (error "Move point to a class and try again")) + + ;; Step 2: Select a name for the field we will use. + (when field-in + (setq field field-in)) + + (when (and inclass (not field)) + (setq field (srecode-auto-choose-field (point)))) + + (when (not field) + (setq field (srecode-query-for-field class))) + + ;; Step 3: Insert a new field if needed + (when (stringp field) + + (goto-char (point)) + (srecode-position-new-field class inclass) + + (let* ((dict (srecode-create-dictionary)) + (temp (srecode-template-get-table (srecode-table) + "getset-field" + "declaration" + 'getset)) + ) + (when (not temp) + (error "Getset templates for %s not loaded!" major-mode)) + (srecode-resolve-arguments temp dict) + (srecode-dictionary-set-value dict "NAME" field) + (when srecode-insert-getset-fully-automatic-flag + (srecode-dictionary-set-value dict "TYPE" "int")) + (srecode-insert-fcn temp dict) + + (semantic-fetch-tags) + (save-excursion + (goto-char tagstart) + ;; Refresh our class tag. + (setq class (srecode-auto-choose-class (point))) + ) + + (let ((tmptag (semantic-deep-find-tags-by-name-regexp + field (current-buffer)))) + (setq tmptag (semantic-find-tags-by-class 'variable tmptag)) + + (if tmptag + (setq field (car tmptag)) + (error "Could not find new field %s" field))) + ) + + ;; Step 3.5: Insert an initializer if needed. + ;; ... + + + ;; Set up for the rest. + ) + + (if (not (semantic-tag-p field)) + (error "Must specify field for get/set. (parts may not be impl'd yet.)")) + + ;; Set 4: Position for insertion of methods + (srecode-position-new-methods class field) + + ;; Step 5: Insert the get/set methods + (if (not (eq (semantic-current-tag) class)) + ;; We are positioned on top of something else. + ;; insert a /n + (insert "\n")) + + (let* ((dict (srecode-create-dictionary)) + (srecode-semantic-selected-tag field) + (temp (srecode-template-get-table (srecode-table) + "getset-in-class" + "declaration" + 'getset)) + ) + (if (not temp) + (error "Getset templates for %s not loaded!" major-mode)) + (srecode-resolve-arguments temp dict) + (srecode-dictionary-set-value dict "GROUPNAME" + (concat (semantic-tag-name field) + " Accessors")) + (srecode-dictionary-set-value dict "NICENAME" + (srecode-strip-fieldname + (semantic-tag-name field))) + (srecode-insert-fcn temp dict) + ))) + +(defun srecode-strip-fieldname (name) + "Strip the fieldname NAME of polish notation things." + (cond ((string-match "[a-z]\\([A-Z]\\w+\\)" name) + (substring name (match-beginning 1))) + ;; Add more rules here. + (t + name))) + +(defun srecode-position-new-methods (class field) + "Position the cursor in CLASS where new getset methods should go. +FIELD is the field for the get sets. +INCLASS specifies if the cursor is already in CLASS or not." + (semantic-go-to-tag field) + + (let ((prev (semantic-find-tag-by-overlay-prev)) + (next (semantic-find-tag-by-overlay-next)) + (setname nil) + (aftertag nil) + ) + (cond + ((and prev (semantic-tag-of-class-p prev 'variable)) + (setq setname + (concat "set" + (srecode-strip-fieldname (semantic-tag-name prev)))) + ) + ((and next (semantic-tag-of-class-p next 'variable)) + (setq setname + (concat "set" + (srecode-strip-fieldname (semantic-tag-name prev))))) + (t nil)) + + (setq aftertag (semantic-find-first-tag-by-name + setname (semantic-tag-type-members class))) + + (when (not aftertag) + (setq aftertag (car-safe + (semantic--find-tags-by-macro + (semantic-tag-get-attribute (car tags) :destructor-flag) + (semantic-tag-type-members class)))) + ;; Make sure the tag is public + (when (not (eq (semantic-tag-protection aftertag class) 'public)) + (setq aftertag nil)) + ) + + (if (not aftertag) + (setq aftertag (car-safe + (semantic--find-tags-by-macro + (semantic-tag-get-attribute (car tags) :constructor-flag) + (semantic-tag-type-members class)))) + ;; Make sure the tag is public + (when (not (eq (semantic-tag-protection aftertag class) 'public)) + (setq aftertag nil)) + ) + + (when (not aftertag) + (setq aftertag (semantic-find-first-tag-by-name + "public" (semantic-tag-type-members class)))) + + (when (not aftertag) + (setq aftertag (car (semantic-tag-type-members class)))) + + (if aftertag + (let ((te (semantic-tag-end aftertag))) + (when (not te) + (message "Unknown location for tag-end in %s:" (semantic-tag-name aftertag))) + (goto-char te) + ;; If there is a comment immediatly after aftertag, skip over it. + (when (looking-at (concat "\\s-*\n?\\s-*" semantic-lex-comment-regex)) + (let ((pos (point)) + (rnext (semantic-find-tag-by-overlay-next (point)))) + (forward-comment 1) + ;; Make sure the comment we skipped didn't say anything about + ;; the rnext tag. + (when (and rnext + (re-search-backward + (regexp-quote (semantic-tag-name rnext)) pos t)) + ;; It did mention rnext, so go back to our starting position. + (goto-char pos) + ) + )) + ) + + ;; At the very beginning of the class. + (goto-char (semantic-tag-end class)) + (forward-sexp -1) + (forward-char 1) + + ) + + (end-of-line) + (forward-char 1) + )) + +(defun srecode-position-new-field (class inclass) + "Select a position for a new field for CLASS. +If INCLASS is non-nil, then the cursor is already in the class +and should not be moved during point selection." + + ;; If we aren't in the class, get the cursor there, pronto! + (when (not inclass) + + (error "You must position the cursor where to insert the new field") + + (let ((kids (semantic-find-tags-by-class + 'variable (semantic-tag-type-members class)))) + (cond (kids + (semantic-go-to-tag (car kids) class)) + (t + (semantic-go-to-tag class))) + ) + + (switch-to-buffer (current-buffer)) + + ;; Once the cursor is in our class, ask the user to position + ;; the cursor to keep going. + ) + + (if (or srecode-insert-getset-fully-automatic-flag + (y-or-n-p "Insert new field here? ")) + nil + (error "You must position the cursor where to insert the new field first")) + ) + + + +(defun srecode-auto-choose-field (point) + "Choose a field for the get/set methods. +Base selection on the field related to POINT." + (save-excursion + (when point + (goto-char point)) + + (let ((field (semantic-current-tag-of-class 'variable))) + + ;; If we get a field, make sure the user gets a chance to choose. + (when field + (if srecode-insert-getset-fully-automatic-flag + nil + (when (not (y-or-n-p + (format "Use field %s? " (semantic-tag-name field)))) + (setq field nil)) + )) + field))) + +(defun srecode-query-for-field (class) + "Query for a field in CLASS." + (let* ((kids (semantic-find-tags-by-class + 'variable (semantic-tag-type-members class))) + (sel (completing-read "Use Field: " kids)) + ) + + (or (semantic-find-tags-by-name sel kids) + sel) + )) + +(defun srecode-auto-choose-class (point) + "Choose a class based on locatin of POINT." + (save-excursion + (when point + (goto-char point)) + + (let ((tag (semantic-current-tag-of-class 'type))) + + (when (or (not tag) + (not (string= (semantic-tag-type tag) "class"))) + ;; The current tag is not a class. Are we in a fcn + ;; that is a method? + (setq tag (semantic-current-tag-of-class 'function)) + + (when (and tag + (semantic-tag-function-parent tag)) + (let ((p (semantic-tag-function-parent tag))) + ;; @TODO : Copied below out of semantic-analyze + ;; Turn into a routine. + + (let* ((searchname (cond ((stringp p) p) + ((semantic-tag-p p) + (semantic-tag-name p)) + ((and (listp p) (stringp (car p))) + (car p)))) + (ptag (semantic-analyze-find-tag searchname + 'type nil))) + (when ptag (setq tag ptag )) + )))) + + (when (or (not tag) + (not (semantic-tag-of-class-p tag 'type)) + (not (string= (semantic-tag-type tag) "class"))) + ;; We are not in a class that needs a get/set method. + ;; Analyze the current context, and derive a class name. + (let* ((ctxt (semantic-analyze-current-context)) + (pfix nil) + (ans nil)) + (when ctxt + (setq pfix (reverse (oref ctxt prefix))) + (while (and (not ans) pfix) + ;; Start at the end and back up to the first class. + (when (and (semantic-tag-p (car pfix)) + (semantic-tag-of-class-p (car pfix) 'type) + (string= (semantic-tag-type (car pfix)) + "class")) + (setq ans (car pfix))) + (setq pfix (cdr pfix)))) + (setq tag ans))) + + tag))) + +(provide 'srecode/getset) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: srecode/loaddefs +;; generated-autoload-load-name: "srecode/getset" +;; End: + +;;; srecode/getset.el ends here diff --git a/lisp/cedet/srecode/insert.el b/lisp/cedet/srecode/insert.el new file mode 100644 index 00000000000..743c8e8e652 --- /dev/null +++ b/lisp/cedet/srecode/insert.el @@ -0,0 +1,983 @@ +;;; srecode/insert --- Insert srecode templates to an output stream. + +;;; Copyright (C) 2005, 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Define and implements specific inserter objects. +;; +;; Manage the insertion process for a template. +;; + +(require 'srecode/compile) +(require 'srecode/find) +(require 'srecode/dictionary) + +(defvar srecode-template-inserter-point) +(declare-function srecode-overlaid-activate "srecode/fields") +(declare-function srecode-template-inserted-region "srecode/fields") + +;;; Code: + +(defcustom srecode-insert-ask-variable-method 'ask + "Determine how to ask for a dictionary value when inserting a template. +Only the ASK style inserter will query the user for a value. +Dictionary value references that ask begin with the ? character. +Possible values are: + 'ask - Prompt in the minibuffer as the value is inserted. + 'field - Use the dictionary macro name as the inserted value, + and place a field there. Matched fields change together. + +NOTE: The field feature does not yet work with XEmacs." + :group 'srecode + :type '(choice (const :tag "Ask" ask) + (cons :tag "Field" field))) + +(defvar srecode-insert-with-fields-in-progress nil + "Non-nil means that we are actively inserting a template with fields.") + +;;; INSERTION COMMANDS +;; +;; User level commands for inserting stuff. +(defvar srecode-insertion-start-context nil + "The context that was at point at the beginning of the template insertion.") + +(defun srecode-insert-again () + "Insert the previously inserted template (by name) again." + (interactive) + (let ((prev (car srecode-read-template-name-history))) + (if prev + (srecode-insert prev) + (call-interactively 'srecode-insert)))) + +;;;###autoload +(defun srecode-insert (template-name &rest dict-entries) + "Inesrt the template TEMPLATE-NAME into the current buffer at point. +DICT-ENTRIES are additional dictionary values to add." + (interactive (list (srecode-read-template-name "Template Name: "))) + (if (not (srecode-table)) + (error "No template table found for mode %s" major-mode)) + (let ((newdict (srecode-create-dictionary)) + (temp (srecode-template-get-table (srecode-table) template-name)) + (srecode-insertion-start-context (srecode-calculate-context)) + ) + (if (not temp) + (error "No Template named %s" template-name)) + (while dict-entries + (srecode-dictionary-set-value newdict + (car dict-entries) + (car (cdr dict-entries))) + (setq dict-entries (cdr (cdr dict-entries)))) + ;;(srecode-resolve-arguments temp newdict) + (srecode-insert-fcn temp newdict) + ;; Don't put code here. We need to return the end-mark + ;; for this insertion step. + )) + +(defun srecode-insert-fcn (template dictionary &optional stream skipresolver) + "Insert TEMPLATE using DICTIONARY into STREAM. +Optional SKIPRESOLVER means to avoid refreshing the tag list, +or resolving any template arguments. It is assumed the caller +has set everything up already." + ;; Perform the insertion. + (let ((standard-output (or stream (current-buffer))) + (end-mark nil)) + (unless skipresolver + ;; Make sure the semantic tags are up to date. + (semantic-fetch-tags) + ;; Resolve the arguments + (srecode-resolve-arguments template dictionary)) + ;; Insert + (if (bufferp standard-output) + ;; If there is a buffer, turn off various hooks. This will cause + ;; the mod hooks to be buffered up during the insert, but + ;; prevent tools like font-lock from fontifying mid-template. + ;; Especialy important during insertion of complex comments that + ;; cause the new font-lock to comment-color stuff after the inserted + ;; comment. + ;; + ;; I'm not sure about the motion hooks. It seems like a good + ;; idea though. + ;; + ;; Borrowed these concepts out of font-lock. + ;; + ;; I tried `combine-after-change-calls', but it did not have + ;; the effect I wanted. + (let ((start (point))) + (let ((inhibit-point-motion-hooks t) + (inhibit-modification-hooks t) + ) + (srecode--insert-into-buffer template dictionary) + ) + ;; Now call those after change functions. + (run-hook-with-args 'after-change-functions + start (point) 0) + ) + (srecode-insert-method template dictionary)) + ;; Handle specialization of the POINT inserter. + (when (and (bufferp standard-output) + (slot-boundp 'srecode-template-inserter-point 'point) + ) + (set-buffer standard-output) + (setq end-mark (point-marker)) + (goto-char (oref srecode-template-inserter-point point))) + (oset-default 'srecode-template-inserter-point point eieio-unbound) + + ;; Return the end-mark. + (or end-mark (point))) + ) + +(defun srecode--insert-into-buffer (template dictionary) + "Insert a TEMPLATE with DICTIONARY into a buffer. +Do not call this function yourself. Instead use: + `srecode-insert' - Inserts by name. + `srecode-insert-fcn' - Insert with objects. +This function handles the case from one of the above functions when +the template is inserted into a buffer. It looks +at `srecode-insert-ask-variable-method' to decide if unbound dictionary +entries ask questions or insert editable fields. + +Buffer based features related to change hooks is handled one level up." + ;; This line prevents the field archive from being let bound + ;; while the field insert tool is loaded via autoloads during + ;; the insert. + (when (eq srecode-insert-ask-variable-method 'field) + (require 'srecode-fields)) + + (let ((srecode-field-archive nil) ; Prevent field leaks during insert + (start (point)) ; Beginning of the region. + ) + ;; This sub-let scopes the 'in-progress' piece so we know + ;; when to setup the end-template. + (let ((srecode-insert-with-fields-in-progress + (if (eq srecode-insert-ask-variable-method 'field) t nil)) + ) + (srecode-insert-method template dictionary) + ) + ;; If we are not in-progress, and we insert fields, then + ;; create the end-template with fields editable area. + (when (and (not srecode-insert-with-fields-in-progress) + (eq srecode-insert-ask-variable-method 'field) ; Only if user asked + srecode-field-archive ; Only if there were fields created + ) + (let ((reg + ;; Create the field-driven editable area. + (srecode-template-inserted-region + "TEMPLATE" :start start :end (point)))) + (srecode-overlaid-activate reg)) + ) + ;; We return with 'point being the end of the template insertion + ;; area. Return value is not important. + )) + +;;; TEMPLATE ARGUMENTS +;; +;; Some templates have arguments. Each argument is assocaited with +;; a function that can resolve the inputs needed. +(defun srecode-resolve-arguments (temp dict) + "Resolve all the arguments needed by the template TEMP. +Apply anything learned to the dictionary DICT." + (srecode-resolve-argument-list (oref temp args) dict temp)) + +(defun srecode-resolve-argument-list (args dict &optional temp) + "Resolve arguments in the argument list ARGS. +ARGS is a list of symbols, such as :blank, or :file. +Apply values to DICT. +Optional argument TEMP is the template that is getting it's arguments resolved." + (let ((fcn nil)) + (while args + (setq fcn (intern-soft (concat "srecode-semantic-handle-" + (symbol-name (car args))))) + (if (not fcn) + (error "Error resolving template argument %S" (car args))) + (if temp + (condition-case nil + ;; Allow some to accept a 2nd argument optionally. + ;; They throw an error if not available, so try again. + (funcall fcn dict temp) + (wrong-number-of-arguments (funcall fcn dict))) + (funcall fcn dict)) + (setq args (cdr args))) + )) + +;;; INSERTION STACK & METHOD +;; +;; Code managing the top-level insert method and the current +;; insertion stack. +;; +(defmethod srecode-push ((st srecode-template)) + "Push the srecoder template ST onto the active stack." + (oset st active (cons st (oref st active)))) + +(defmethod srecode-pop :STATIC ((st srecode-template)) + "Pop the srecoder template ST onto the active stack. +ST can be a class, or an object." + (oset st active (cdr (oref st active)))) + +(defmethod srecode-peek :STATIC ((st srecode-template)) + "Fetch the topmost active template record. ST can be a class." + (car (oref st active))) + +(defmethod srecode-insert-method ((st srecode-template) dictionary) + "Insert the srecoder template ST." + ;; Merge any template entries into the input dictionary. + (when (slot-boundp st 'dictionary) + (srecode-dictionary-merge dictionary (oref st dictionary))) + ;; Do an insertion. + (unwind-protect + (let ((c (oref st code))) + (srecode-push st) + (srecode-insert-code-stream c dictionary)) + ;; Poping the stack is protected + (srecode-pop st))) + +(defun srecode-insert-code-stream (code dictionary) + "Insert the CODE from a template into `standard-output'. +Use DICTIONARY to resolve any macros." + (while code + (cond ((stringp (car code)) + (princ (car code))) + (t + (srecode-insert-method (car code) dictionary))) + (setq code (cdr code)))) + +;;; INSERTERS +;; +;; Specific srecode inserters. +;; The base class is from srecode-compile. +;; +;; Each inserter handles various macro codes from the temlate. +;; The `code' slot specifies a character used to identify which +;; inserter is to be created. +;; +(defclass srecode-template-inserter-newline (srecode-template-inserter) + ((key :initform "\n" + :allocation :class + :documentation + "The character code used to identify inserters of this style.") + (hard :initform nil + :initarg :hard + :documentation + "Is this a hard newline (always inserted) or optional? +Optional newlines don't insert themselves if they are on a blank line +by themselves.") + ) + "Insert a newline, and possibly do indenting. +Specify the :indent argument to enable automatic indentation when newlines +occur in your template.") + +(defmethod srecode-insert-method ((sti srecode-template-inserter-newline) + dictionary) + "Insert the STI inserter." + ;; To be safe, indent the previous line since the template will + ;; change what is there to indent + (let ((i (srecode-dictionary-lookup-name dictionary "INDENT")) + (inbuff (bufferp standard-output)) + (doit t) + (pm (point-marker))) + (when (and inbuff (not (oref sti hard))) + ;; If this is not a hard newline, we need do the calculation + ;; and set "doit" to nil. + (beginning-of-line) + (save-restriction + (narrow-to-region (point) pm) + (when (looking-at "\\s-*$") + (setq doit nil))) + (goto-char pm) + ) + ;; Do indentation reguardless of the newline. + (when (and (eq i t) inbuff) + (indent-according-to-mode) + (goto-char pm)) + + (when doit + (princ "\n") + ;; Indent after the newline, particularly for numeric indents. + (cond ((and (eq i t) (bufferp standard-output)) + ;; WARNING - indent according to mode requires that standard-output + ;; is a buffer! + ;; @todo - how to indent in a string??? + (setq pm (point-marker)) + (indent-according-to-mode) + (goto-char pm)) + ((numberp i) + (princ (make-string i " "))) + ((stringp i) + (princ i)))))) + +(defmethod srecode-dump ((ins srecode-template-inserter-newline) indent) + "Dump the state of the SRecode template inserter INS." + (call-next-method) + (when (oref ins hard) + (princ " : hard") + )) + +(defclass srecode-template-inserter-blank (srecode-template-inserter) + ((key :initform "\r" + :allocation :class + :documentation + "The character represeinting this inserter style. +Can't be blank, or it might be used by regular variable insertion.") + (where :initform 'begin + :initarg :where + :documentation + "This should be 'begin or 'end, indicating where to insrt a CR. +When set to 'begin, it will insert a CR if we are not at 'bol'. +When set to 'end it will insert a CR if we are not at 'eol'") + ;; @TODO - Add slot and control for the number of blank + ;; lines before and after point. + ) + "Insert a newline before and after a template, and possibly do indenting. +Specify the :blank argument to enable this inserter.") + +(defmethod srecode-insert-method ((sti srecode-template-inserter-blank) + dictionary) + "Make sure there is no text before or after point." + (let ((i (srecode-dictionary-lookup-name dictionary "INDENT")) + (inbuff (bufferp standard-output)) + (pm (point-marker))) + (when (and inbuff + ;; Don't do this if we are not the active template. + (= (length (oref srecode-template active)) 1)) + + (when (and (eq i t) inbuff (not (eq (oref sti where) 'begin))) + (indent-according-to-mode) + (goto-char pm)) + + (cond ((and (eq (oref sti where) 'begin) (not (bolp))) + (princ "\n")) + ((eq (oref sti where) 'end) + ;; If there is whitespace after pnt, then clear it out. + (when (looking-at "\\s-*$") + (delete-region (point) (point-at-eol))) + (when (not (eolp)) + (princ "\n"))) + ) + (setq pm (point-marker)) + (when (and (eq i t) inbuff (not (eq (oref sti where) 'end))) + (indent-according-to-mode) + (goto-char pm)) + ))) + +(defclass srecode-template-inserter-comment (srecode-template-inserter) + ((key :initform ?! + :allocation :class + :documentation + "The character code used to identify inserters of this style.") + ) + "Allow comments within template coding. This inserts nothing.") + +(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-comment) + escape-start escape-end) + "Insert an example using inserter INS. +Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use." + (princ " ") + (princ escape-start) + (princ "! Miscellaneous text commenting in your template. ") + (princ escape-end) + (terpri) + ) + +(defmethod srecode-insert-method ((sti srecode-template-inserter-comment) + dictionary) + "Don't insert anything for comment macros in STI." + nil) + + +(defclass srecode-template-inserter-variable (srecode-template-inserter) + ((key :initform nil + :allocation :class + :documentation + "The character code used to identify inserters of this style.")) + "Insert the value of a dictionary entry +If there is no entry, insert nothing.") + +(defvar srecode-inserter-variable-current-dictionary nil + "The active dictionary when calling a variable filter.") + +(defmethod srecode-insert-variable-secondname-handler + ((sti srecode-template-inserter-variable) dictionary value secondname) + "For VALUE handle SECONDNAME behaviors for this variable inserter. +Return the result as a string. +By default, treat as a function name. +If SECONDNAME is nil, return VALUE." + (if secondname + (let ((fcnpart (read secondname))) + (if (fboundp fcnpart) + (let ((srecode-inserter-variable-current-dictionary dictionary)) + (funcall fcnpart value)) + ;; Else, warn. + (error "Variable insertion second arg %s is not a function." + secondname))) + value)) + +(defmethod srecode-insert-method ((sti srecode-template-inserter-variable) + dictionary) + "Insert the STI inserter." + ;; Convert the name into a name/fcn pair + (let* ((name (oref sti :object-name)) + (fcnpart (oref sti :secondname)) + (val (srecode-dictionary-lookup-name + dictionary name)) + (do-princ t) + ) + ;; Alert if a macro wasn't found. + (when (not val) + (message "Warning: macro %S was not found in the dictionary." name) + (setq val "")) + ;; If there was a functional part, call that function. + (cond ;; Strings + ((stringp val) + (setq val (srecode-insert-variable-secondname-handler + sti dictionary val fcnpart))) + ;; Compound data value + ((srecode-dictionary-compound-value-child-p val) + ;; Force FCN to be a symbol + (when fcnpart (setq fcnpart (read fcnpart))) + ;; Convert compound value to a string with the fcn. + (setq val (srecode-compound-toString val fcnpart dictionary)) + ;; If the value returned is nil, then it may be a special + ;; field inserter that requires us to set do-princ to nil. + (when (not val) + (setq do-princ nil) + ) + ) + ;; Dictionaries... not allowed in this style + ((srecode-dictionary-child-p val) + (error "Macro %s cannot insert a dictionary. Use section macros instead." + name)) + ;; Other stuff... convert + (t + (error "Macro %s cannot insert arbitrary data." name) + ;;(if (and val (not (stringp val))) + ;; (setq val (format "%S" val)))) + )) + ;; Output the dumb thing unless the type of thing specifically + ;; did the inserting forus. + (when do-princ + (princ val)))) + +(defclass srecode-template-inserter-ask (srecode-template-inserter-variable) + ((key :initform ?? + :allocation :class + :documentation + "The character code used to identify inserters of this style.") + (prompt :initarg :prompt + :initform nil + :documentation + "The prompt used to query for this dictionary value.") + (defaultfcn :initarg :defaultfcn + :initform nil + :documentation + "The function which can calculate a default value.") + (read-fcn :initarg :read-fcn + :initform 'read-string + :documentation + "The function used to read in the text for this prompt.") + ) + "Insert the value of a dictionary entry +If there is no entry, prompt the user for the value to use. +The prompt text used is derived from the previous PROMPT command in the +template file.") + +(defmethod srecode-inserter-apply-state ((ins srecode-template-inserter-ask) STATE) + "For the template inserter INS, apply information from STATE. +Loop over the prompts to see if we have a match." + (let ((prompts (oref STATE prompts)) + ) + (while prompts + (when (string= (semantic-tag-name (car prompts)) + (oref ins :object-name)) + (oset ins :prompt + (semantic-tag-get-attribute (car prompts) :text)) + (oset ins :defaultfcn + (semantic-tag-get-attribute (car prompts) :default)) + (oset ins :read-fcn + (or (semantic-tag-get-attribute (car prompts) :read) + 'read-string)) + ) + (setq prompts (cdr prompts))) + )) + +(defmethod srecode-insert-method ((sti srecode-template-inserter-ask) + dictionary) + "Insert the STI inserter." + (let ((val (srecode-dictionary-lookup-name + dictionary (oref sti :object-name)))) + (if val + ;; Does some extra work. Oh well. + (call-next-method) + + ;; How is our -ask value determined? + (if srecode-insert-with-fields-in-progress + ;; Setup editable fields. + (setq val (srecode-insert-method-field sti dictionary)) + ;; Ask the question... + (setq val (srecode-insert-method-ask sti dictionary))) + + ;; After asking, save in the dictionary so that + ;; the user can use the same name again later. + (srecode-dictionary-set-value + (srecode-root-dictionary dictionary) + (oref sti :object-name) val) + + ;; Now that this value is safely stowed in the dictionary, + ;; we can do what regular inserters do. + (call-next-method)))) + +(defmethod srecode-insert-ask-default ((sti srecode-template-inserter-ask) + dictionary) + "Derive the default value for an askable inserter STI. +DICTIONARY is used to derive some values." + (let ((defaultfcn (oref sti :defaultfcn))) + (cond ((stringp defaultfcn) + defaultfcn) + ((functionp defaultfcn) + (funcall defaultfcn)) + ((and (listp defaultfcn) + (eq (car defaultfcn) 'macro)) + (srecode-dictionary-lookup-name + dictionary (cdr defaultfcn))) + ((null defaultfcn) + "") + (t + (error "Unknown default for prompt: %S" + defaultfcn))))) + +(defmethod srecode-insert-method-ask ((sti srecode-template-inserter-ask) + dictionary) + "Do the \"asking\" for the template inserter STI. +Use DICTIONARY to resolve values." + (let* ((prompt (oref sti prompt)) + (default (srecode-insert-ask-default sti dictionary)) + (reader (oref sti :read-fcn)) + (val nil) + ) + (cond ((eq reader 'y-or-n-p) + (if (y-or-n-p (or prompt + (format "%s? " + (oref sti :object-name)))) + (setq val default) + (setq val ""))) + ((eq reader 'read-char) + (setq val (format + "%c" + (read-char (or prompt + (format "Char for %s: " + (oref sti :object-name)))))) + ) + (t + (save-excursion + (setq val (funcall reader + (or prompt + (format "Specify %s: " + (oref sti :object-name))) + default + ))))) + ;; Return our derived value. + val) + ) + +(defmethod srecode-insert-method-field ((sti srecode-template-inserter-ask) + dictionary) + "Create an editable field for the template inserter STI. +Use DICTIONARY to resolve values." + (let* ((default (srecode-insert-ask-default sti dictionary)) + (compound-value + (srecode-field-value (oref sti :object-name) + :firstinserter sti + :defaultvalue default)) + ) + ;; Return this special compound value as the thing to insert. + ;; This special compound value will repeat our asked question + ;; across multiple locations. + compound-value)) + +(defmethod srecode-dump ((ins srecode-template-inserter-ask) indent) + "Dump the state of the SRecode template inserter INS." + (call-next-method) + (princ " : \"") + (princ (oref ins prompt)) + (princ "\"") + ) + +(defclass srecode-template-inserter-width (srecode-template-inserter-variable) + ((key :initform ?| + :allocation :class + :documentation + "The character code used to identify inserters of this style.") + ) + "Inserts the value of a dictionary variable with a specific width. +The second argument specifies the width, and a pad, seperated by a colon. +thus a specification of `10:left' will insert the value of A +to 10 characters, with spaces added to the left. Use `right' for adding +spaces to the right.") + +(defmethod srecode-insert-variable-secondname-handler + ((sti srecode-template-inserter-width) dictionary value width) + "For VALUE handle WIDTH behaviors for this variable inserter. +Return the result as a string. +By default, treat as a function name." + (if width + ;; Trim or pad to new length + (let* ((split (split-string width ":")) + (width (string-to-number (nth 0 split))) + (second (nth 1 split)) + (pad (cond ((or (null second) (string= "right" second)) + 'right) + ((string= "left" second) + 'left) + (t + (error "Unknown pad type %s" second))))) + (if (>= (length value) width) + ;; Simple case - too long. + (substring value 0 width) + ;; We need to pad on one side or the other. + (let ((padchars (make-string (- width (length value)) ? ))) + (if (eq pad 'left) + (concat padchars value) + (concat value padchars))))) + (error "Width not specified for variable/width inserter."))) + +(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-width) + escape-start escape-end) + "Insert an example using inserter INS. +Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use." + (princ " ") + (princ escape-start) + (princ "|A:10:right") + (princ escape-end) + (terpri) + ) + +(defvar srecode-template-inserter-point-override nil + "When non-nil, the point inserter will do this functin instead.") + +(defclass srecode-template-inserter-point (srecode-template-inserter) + ((key :initform ?^ + :allocation :class + :documentation + "The character code used to identify inserters of this style.") + (point :type (or null marker) + :allocation :class + :documentation + "Record the value of (point) in this class slot. +It is the responsibility of the inserter algorithm to clear this +after a successful insertion.")) + "Record the value of (point) when inserted. +The cursor is placed at the ^ macro after insertion. +Some inserter macros, such as `srecode-template-inserter-include-wrap' +will place text at the ^ macro from the included macro.") + +(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-point) + escape-start escape-end) + "Insert an example using inserter INS. +Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use." + (princ " ") + (princ escape-start) + (princ "^") + (princ escape-end) + (terpri) + ) + +(defmethod srecode-insert-method ((sti srecode-template-inserter-point) + dictionary) + "Insert the STI inserter. +Save point in the class allocated 'point' slot. +If `srecode-template-inserter-point-override' then this generalized +marker will do something else. See `srecode-template-inserter-include-wrap' +as an example." + (if srecode-template-inserter-point-override + ;; Disable the old override while we do this. + (let ((over srecode-template-inserter-point-override) + (srecode-template-inserter-point-override nil)) + (funcall over dictionary) + ) + (oset sti point (point-marker)) + )) + +(defclass srecode-template-inserter-subtemplate (srecode-template-inserter) + () + "Wrap a section of a template under the control of a macro." + :abstract t) + +(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-subtemplate) + escape-start escape-end) + "Insert an example using inserter INS. +Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use." + (call-next-method) + (princ " Template Text to control") + (terpri) + (princ " ") + (princ escape-start) + (princ "/VARNAME") + (princ escape-end) + (terpri) + ) + +(defmethod srecode-insert-subtemplate ((sti srecode-template-inserter-subtemplate) + dict slot) + "Insert a subtemplate for the inserter STI with dictionary DICT." + ;; make sure that only dictionaries are used. + (when (not (srecode-dictionary-child-p dict)) + (error "Only section dictionaries allowed for %s" + (object-name-string sti))) + ;; Output the code from the sub-template. + (srecode-insert-method (slot-value sti slot) dict) + ) + +(defmethod srecode-insert-method-helper ((sti srecode-template-inserter-subtemplate) + dictionary slot) + "Do the work for inserting the STI inserter. +Loops over the embedded CODE which was saved here during compilation. +The template to insert is stored in SLOT." + (let ((dicts (srecode-dictionary-lookup-name + dictionary (oref sti :object-name)))) + ;; If there is no section dictionary, then don't output anything + ;; from this section. + (while dicts + (srecode-insert-subtemplate sti (car dicts) slot) + (setq dicts (cdr dicts))))) + +(defmethod srecode-insert-method ((sti srecode-template-inserter-subtemplate) + dictionary) + "Insert the STI inserter. +Calls back to `srecode-insert-method-helper' for this class." + (srecode-insert-method-helper sti dictionary 'template)) + + +(defclass srecode-template-inserter-section-start (srecode-template-inserter-subtemplate) + ((key :initform ?# + :allocation :class + :documentation + "The character code used to identify inserters of this style.") + (template :initarg :template + :documentation + "A Template used to frame the codes from this inserter.") + ) + "Apply values from a sub-dictionary to a template section. +The dictionary saved at the named dictionary entry will be +applied to the text between the section start and the +`srecode-template-inserter-section-end' macro.") + +(defmethod srecode-parse-input ((ins srecode-template-inserter-section-start) + tag input STATE) + "For the section inserter INS, parse INPUT. +Shorten input until the END token is found. +Return the remains of INPUT." + (let* ((out (srecode-compile-split-code tag input STATE + (oref ins :object-name)))) + (oset ins template (srecode-template + (object-name-string ins) + :context nil + :args nil + :code (cdr out))) + (car out))) + +(defmethod srecode-dump ((ins srecode-template-inserter-section-start) indent) + "Dump the state of the SRecode template inserter INS." + (call-next-method) + (princ "\n") + (srecode-dump-code-list (oref (oref ins template) code) + (concat indent " ")) + ) + +(defclass srecode-template-inserter-section-end (srecode-template-inserter) + ((key :initform ?/ + :allocation :class + :documentation + "The character code used to identify inserters of this style.") + ) + "All template segments between the secion-start and section-end +are treated specially.") + +(defmethod srecode-insert-method ((sti srecode-template-inserter-section-end) + dictionary) + "Insert the STI inserter." + ) + +(defmethod srecode-match-end ((ins srecode-template-inserter-section-end) name) + + "For the template inserter INS, do I end a section called NAME?" + (string= name (oref ins :object-name))) + +(defclass srecode-template-inserter-include (srecode-template-inserter-subtemplate) + ((key :initform ?> + :allocation :class + :documentation + "The character code used to identify inserters of this style.") + (includedtemplate + :initarg :includedtemplate + :documentation + "The template included for this inserter.")) + "Include a different template into this one. +The included template will have additional dictionary entries from the subdictionary +stored specified by this macro.") + +(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-include) + escape-start escape-end) + "Insert an example using inserter INS. +Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use." + (princ " ") + (princ escape-start) + (princ ">DICTNAME:contextname:templatename") + (princ escape-end) + (terpri) + ) + +(defmethod srecode-insert-include-lookup ((sti srecode-template-inserter-include) + dictionary) + "For the template inserter STI, lookup the template to include. +Finds the template with this macro function part and stores it in +this template instance." + (let* ((templatenamepart (oref sti :secondname)) + ) + ;; If there was no template name, throw an error + (if (not templatenamepart) + (error "Include macro %s needs a template name." (oref sti :object-name))) + ;; Find the template by name, and save it. + (if (or (not (slot-boundp sti 'includedtemplate)) + (not (oref sti includedtemplate))) + (let ((tmpl (srecode-template-get-table (srecode-table) + templatenamepart)) + (active (oref srecode-template active)) + ctxt) + (when (not tmpl) + ;; If it isn't just available, scan back through + ;; the active template stack, searching for a matching + ;; context. + (while (and (not tmpl) active) + (setq ctxt (oref (car active) context)) + (setq tmpl (srecode-template-get-table (srecode-table) + templatenamepart + ctxt)) + (when (not tmpl) + (when (slot-boundp (car active) 'table) + (let ((app (oref (oref (car active) table) application))) + (when app + (setq tmpl (srecode-template-get-table + (srecode-table) + templatenamepart + ctxt app))) + ))) + (setq active (cdr active))) + (when (not tmpl) + ;; If it wasn't in this context, look to see if it + ;; defines it's own context + (setq tmpl (srecode-template-get-table (srecode-table) + templatenamepart))) + ) + (oset sti :includedtemplate tmpl))) + + (if (not (oref sti includedtemplate)) + ;; @todo - Call into a debugger to help find the template in question. + (error "No template \"%s\" found for include macro `%s'" + templatenamepart (oref sti :object-name))) + )) + +(defmethod srecode-insert-method ((sti srecode-template-inserter-include) + dictionary) + "Insert the STI inserter. +Finds the template with this macro function part, and inserts it +with the dictionaries found in the dictinary." + (srecode-insert-include-lookup sti dictionary) + ;; Insert the template. + ;; Our baseclass has a simple way to do this. + (if (srecode-dictionary-lookup-name dictionary (oref sti :object-name)) + ;; If we have a value, then call the next method + (srecode-insert-method-helper sti dictionary 'includedtemplate) + ;; If we don't have a special dictitonary, then just insert with the + ;; current dictionary. + (srecode-insert-subtemplate sti dictionary 'includedtemplate)) + ) + +;; +;; This template combines the include template and the sectional template. +;; It will first insert the included template, then insert the embedded +;; template wherever the $^$ in the included template was. +;; +;; Since it uses dual inheretance, it will magically get the end-matching +;; behavior of #, with the including feature of >. +;; +(defclass srecode-template-inserter-include-wrap (srecode-template-inserter-include srecode-template-inserter-section-start) + ((key :initform ?< + :allocation :class + :documentation + "The character code used to identify inserters of this style.") + ) + "Include a different template into this one, and add text at the ^ macro. +The included template will have additional dictionary entries from the subdictionary +stored specified by this macro. If the included macro includes a ^ macro, +then the text between this macro and the end macro will be inserted at +the ^ macro.") + +(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-include-wrap) + escape-start escape-end) + "Insert an example using inserter INS. +Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use." + (princ " ") + (princ escape-start) + (princ "<DICTNAME:contextname:templatename") + (princ escape-end) + (terpri) + (princ " Template Text to insert at ^ macro") + (terpri) + (princ " ") + (princ escape-start) + (princ "/DICTNAME") + (princ escape-end) + (terpri) + ) + +(defmethod srecode-insert-method ((sti srecode-template-inserter-include-wrap) + dictionary) + "Insert the template STI. +This will first insert the include part via inheritance, then +insert the section it wraps into the location in the included +template where a ^ inserter occurs." + ;; Step 1: Look up the included inserter + (srecode-insert-include-lookup sti dictionary) + ;; Step 2: Temporarilly override the point inserter. + (let* ((vaguely-unique-name sti) + (srecode-template-inserter-point-override + (lambda (dict2) + (if (srecode-dictionary-lookup-name + dict2 (oref vaguely-unique-name :object-name)) + ;; Insert our sectional part with looping. + (srecode-insert-method-helper + vaguely-unique-name dict2 'template) + ;; Insert our sectional part just once. + (srecode-insert-subtemplate vaguely-unique-name + dict2 'template)) + ))) + ;; Do a regular insertion for an include, but with our override in + ;; place. + (call-next-method) + )) + +(provide 'srecode/insert) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: srecode/loaddefs +;; generated-autoload-load-name: "srecode/insert" +;; End: + +;;; srecode/insert.el ends here diff --git a/lisp/cedet/srecode/java.el b/lisp/cedet/srecode/java.el new file mode 100644 index 00000000000..325cf215ee8 --- /dev/null +++ b/lisp/cedet/srecode/java.el @@ -0,0 +1,62 @@ +;;; srecode-java.el --- Srecode Java support + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Special support for the Java language. + +;;; Code: + +(require 'srecode/dictionary) + +;;;###autoload +(defun srecode-semantic-handle-:java (dict) + "Add macros into the dictionary DICT based on the current java file. +Adds the following: +FILENAME_AS_PACKAGE - file/dir converted into a java package name. +FILENAME_AS_CLASS - file converted to a Java class name." + ;; A symbol representing + (let* ((fsym (file-name-nondirectory (buffer-file-name))) + (fnox (file-name-sans-extension fsym)) + (dir (file-name-directory (buffer-file-name))) + (fpak fsym) + ) + (while (string-match "\\.\\| " fpak) + (setq fpak (replace-match "_" t t fpak))) + (if (string-match "src/" dir) + (setq dir (substring dir (match-end 0))) + (setq dir (file-name-nondirectory (directory-file-name dir)))) + (while (string-match "/" dir) + (setq dir (replace-match "_" t t dir))) + (srecode-dictionary-set-value dict "FILENAME_AS_PACKAGE" + (concat dir "." fpak)) + (srecode-dictionary-set-value dict "FILENAME_AS_CLASS" fnox) + )) + +(provide 'srecode/java) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: srecode/loaddefs +;; generated-autoload-load-name: "srecode/java" +;; End: + +;;; srecode/java.el ends here diff --git a/lisp/cedet/srecode/map.el b/lisp/cedet/srecode/map.el new file mode 100644 index 00000000000..e36b19b80e2 --- /dev/null +++ b/lisp/cedet/srecode/map.el @@ -0,0 +1,415 @@ +;;; srecode/map.el --- Manage a template file map + +;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Read template files, and build a map of where they can be found. +;; Save the map to disk, and refer to it when bootstrapping a new +;; Emacs session with srecode. + +(require 'semantic) +(require 'eieio-base) +(require 'srecode) + +;;; Code: + +;; The defcustom is given at the end of the file. +(defvar srecode-map-load-path) + +(defun srecode-map-base-template-dir () + "Find the base template directory for SRecode." + (let* ((lib (locate-library "srecode.el")) + (dir (file-name-directory lib))) + (expand-file-name "templates/" dir) + )) + +;;; Current MAP +;; + +(defvar srecode-current-map nil + "The current map for global SRecode templtes.") + +(defcustom srecode-map-save-file (expand-file-name "~/.srecode/srecode-map") + "The save location for SRecode's map file. +If the save file is nil, then the MAP is not saved between sessions." + :group 'srecode + :type 'file) + +(defclass srecode-map (eieio-persistent) + ((fileheaderline :initform ";; SRECODE TEMPLATE MAP") + (files :initarg :files + :initform nil + :type list + :documentation + "An alist of files and the major-mode that they cover.") + (apps :initarg :apps + :initform nil + :type list + :documentation + "An alist of applications. +Each app keys to an alist of files and modes (as above.)") + ) + "A map of srecode templates.") + +(defmethod srecode-map-entry-for-file ((map srecode-map) file) + "Return the entry in MAP for FILE." + (assoc file (oref map files))) + +(defmethod srecode-map-entries-for-mode ((map srecode-map) mode) + "Return the entries in MAP for major MODE." + (let ((ans nil)) + (dolist (f (oref map files)) + (when (mode-local-use-bindings-p mode (cdr f)) + (setq ans (cons f ans)))) + ans)) + +(defmethod srecode-map-entry-for-app ((map srecode-map) app) + "Return the entry in MAP for APP'lication." + (assoc app (oref map apps)) + ) + +(defmethod srecode-map-entries-for-app-and-mode ((map srecode-map) app mode) + "Return the entries in MAP for major MODE." + (let ((ans nil) + (appentry (srecode-map-entry-for-app map app))) + (dolist (f (cdr appentry)) + (when (eq (cdr f) mode) + (setq ans (cons f ans)))) + ans)) + +(defmethod srecode-map-entry-for-file-anywhere ((map srecode-map) file) + "Search in all entry points in MAP for FILE. +Return a list ( APP . FILE-ASSOC ) where APP is nil +in the global map." + (or + ;; Look in the global entry + (let ((globalentry (srecode-map-entry-for-file map file))) + (when globalentry + (cons nil globalentry))) + ;; Look in each app. + (let ((match nil)) + (dolist (app (oref map apps)) + (let ((appmatch (assoc file (cdr app)))) + (when appmatch + (setq match (cons app appmatch))))) + match) + ;; Other? + )) + +(defmethod srecode-map-delete-file-entry ((map srecode-map) file) + "Update MAP to exclude FILE from the file list." + (let ((entry (srecode-map-entry-for-file map file))) + (when entry + (object-remove-from-list map 'files entry)))) + +(defmethod srecode-map-update-file-entry ((map srecode-map) file mode) + "Update a MAP entry for FILE to be used with MODE. +Return non-nil if the MAP was changed." + (let ((entry (srecode-map-entry-for-file map file)) + (dirty t)) + (cond + ;; It is already a match.. do nothing. + ((and entry (eq (cdr entry) mode)) + (setq dirty nil)) + ;; We have a non-matching entry. Change the cdr. + (entry + (setcdr entry mode)) + ;; No entry, just add it to the list. + (t + (object-add-to-list map 'files (cons file mode)) + )) + dirty)) + +(defmethod srecode-map-delete-file-entry-from-app ((map srecode-map) file app) + "Delete from MAP the FILE entry within the APP'lication." + (let* ((appe (srecode-map-entry-for-app map app)) + (fentry (assoc file (cdr appe)))) + (setcdr appe (delete fentry (cdr appe)))) + ) + +(defmethod srecode-map-update-app-file-entry ((map srecode-map) file mode app) + "Update the MAP entry for FILE to be used with MODE within APP. +Return non-nil if the map was changed." + (let* ((appentry (srecode-map-entry-for-app map app)) + (appfileentry (assoc file (cdr appentry))) + (dirty t) + ) + (cond + ;; Option 1 - We have this file in this application already + ;; with the correct mode. + ((and appfileentry (eq (cdr appfileentry) mode)) + (setq dirty nil) + ) + ;; Option 2 - We have a non-matching entry. Change Cdr. + (appfileentry + (setcdr appfileentry mode)) + (t + ;; For option 3 & 4 - remove the entry from any other lists + ;; we can find. + (let ((any (srecode-map-entry-for-file-anywhere map file))) + (when any + (if (null (car any)) + ;; Global map entry + (srecode-map-delete-file-entry map file) + ;; Some app + (let ((appentry (srecode-map-entry-for-app map app))) + (setcdr appentry (delete (cdr any) (cdr appentry)))) + ))) + ;; Now do option 3 and 4 + (cond + ;; Option 3 - No entry for app. Add to the list. + (appentry + (setcdr appentry (cons (cons file mode) (cdr appentry))) + ) + ;; Option 4 - No app entry. Add app to list with this file. + (t + (object-add-to-list map 'apps (list app (cons file mode))) + ))) + ) + dirty)) + + +;;; MAP Updating +;; +;;;###autoload +(defun srecode-get-maps (&optional reset) + "Get a list of maps relevant to the current buffer. +Optional argument RESET forces a reset of the current map." + (interactive "P") + ;; Always update the map, but only do a full reset if + ;; the user asks for one. + (srecode-map-update-map (not reset)) + + (if (interactive-p) + ;; Dump this map. + (with-output-to-temp-buffer "*SRECODE MAP*" + (princ " -- SRecode Global map --\n") + (srecode-maps-dump-file-list (oref srecode-current-map files)) + (princ "\n -- Application Maps --\n") + (dolist (ap (oref srecode-current-map apps)) + (let ((app (car ap)) + (files (cdr ap))) + (princ app) + (princ " :\n") + (srecode-maps-dump-file-list files)) + (princ "\n")) + (princ "\nUse:\n\n M-x customize-variable RET srecode-map-load-path RET") + (princ "\n To change the path where SRecode loads templates from.") + ) + ;; Eventually, I want to return many maps to search through. + (list srecode-current-map))) + +(eval-when-compile (require 'data-debug)) + +(defun srecode-adebug-maps () + "Run ADEBUG on the output of `srecode-get-maps'." + (interactive) + (require 'data-debug) + (let ((start (current-time)) + (p (srecode-get-maps t)) ;; Time the reset. + (end (current-time)) + ) + (message "Updating the map took %.2f seconds." + (semantic-elapsed-time start end)) + (data-debug-new-buffer "*SRECODE ADEBUG*") + (data-debug-insert-stuff-list p "*"))) + +(defun srecode-maps-dump-file-list (flist) + "Dump a file list FLIST to `standard-output'." + (princ "Mode\t\t\tFilename\n") + (princ "------\t\t\t------------------\n") + (dolist (fe flist) + (prin1 (cdr fe)) + (princ "\t") + (when (> (* 2 8) (length (symbol-name (cdr fe)))) + (princ "\t")) + (when (> 8 (length (symbol-name (cdr fe)))) + (princ "\t")) + (princ (car fe)) + (princ "\n") + )) + +(defun srecode-map-file-still-valid-p (filename map) + "Return t if FILENAME should be in MAP still." + (let ((valid nil)) + (and (file-exists-p filename) + (progn + (dolist (p srecode-map-load-path) + (when (and (< (length p) (length filename)) + (string= p (substring filename 0 (length p)))) + (setq valid t)) + ) + valid)) + )) + +(defun srecode-map-update-map (&optional fast) + "Update the current map from `srecode-map-load-path'. +Scans all the files on the path, and makes sure we have entries +for them. +If option FAST is non-nil, then only parse a file for the mode-string +if that file is NEW, otherwise assume the mode has not changed." + (interactive) + + ;; When no map file, we are configured to not use a save file. + (if (not srecode-map-save-file) + ;; 0) Create a MAP when in no save file mode. + (when (not srecode-current-map) + (setq srecode-current-map (srecode-map "SRecode Map")) + (message "SRecode map created in non-save mode.") + ) + + ;; 1) Do we even have a MAP or save file? + (when (and (not srecode-current-map) + (not (file-exists-p srecode-map-save-file))) + (when (not (file-exists-p (file-name-directory srecode-map-save-file))) + ;; Only bother with this interactively, not during a build + ;; or test. + (when (not noninteractive) + ;; No map, make the dir? + (if (y-or-n-p (format "Create dir %s? " + (file-name-directory srecode-map-save-file))) + (make-directory (file-name-directory srecode-map-save-file)) + ;; No make, change save file + (customize-variable 'srecode-map-save-file) + (error "Change your SRecode map file")))) + ;; Have a dir. Make the object. + (setq srecode-current-map + (srecode-map "SRecode Map" + :file srecode-map-save-file))) + + ;; 2) Do we not have a current map? If so load. + (when (not srecode-current-map) + (setq srecode-current-map + (eieio-persistent-read srecode-map-save-file)) + ) + + ) + + ;; + ;; We better have a MAP object now. + ;; + (let ((dirty nil)) + ;; 3) - Purge dead files from the file list. + (dolist (entry (copy-sequence (oref srecode-current-map files))) + (when (not (srecode-map-file-still-valid-p + (car entry) srecode-current-map)) + (srecode-map-delete-file-entry srecode-current-map (car entry)) + (setq dirty t) + )) + (dolist (app (copy-sequence (oref srecode-current-map apps))) + (dolist (entry (copy-sequence (cdr app))) + (when (not (srecode-map-file-still-valid-p + (car entry) srecode-current-map)) + (srecode-map-delete-file-entry-from-app + srecode-current-map (car entry) (car app)) + (setq dirty t) + ))) + ;; 4) - Find new files and add them to the map. + (dolist (dir srecode-map-load-path) + (when (file-exists-p dir) + (dolist (f (directory-files dir t "\\.srt$")) + (when (and (not (backup-file-name-p f)) + (not (auto-save-file-name-p f)) + (file-readable-p f)) + (let ((fdirty (srecode-map-validate-file-for-mode f fast))) + (setq dirty (or dirty fdirty)))) + ))) + ;; Only do the save if we are dirty, or if we are in an interactive + ;; Emacs. + (when (and dirty (not noninteractive) + (slot-boundp srecode-current-map :file)) + (eieio-persistent-save srecode-current-map)) + )) + +(defun srecode-map-validate-file-for-mode (file fast) + "Read and validate FILE via the parser. Return the mode. +Argument FAST implies that the file should not be reparsed if there +is already an entry for it. +Return non-nil if the map changed." + (when (or (not fast) + (not (srecode-map-entry-for-file-anywhere srecode-current-map file))) + (let ((buff-orig (get-file-buffer file)) + (dirty nil)) + (save-excursion + (if buff-orig + (set-buffer buff-orig) + (set-buffer (get-buffer-create " *srecode-map-tmp*")) + (insert-file-contents file nil nil nil t) + ;; Force it to be ready to parse. + (srecode-template-mode) + (let ((semantic-init-hooks nil)) + (semantic-new-buffer-fcn)) + ) + + (semantic-fetch-tags) + (let* ((mode-tag + (semantic-find-first-tag-by-name "mode" (current-buffer))) + (val nil) + (app-tag + (semantic-find-first-tag-by-name "application" (current-buffer))) + (app nil)) + (if mode-tag + (setq val (car (semantic-tag-variable-default mode-tag))) + (error "There should be a mode declaration in %s" file)) + (when app-tag + (setq app (car (semantic-tag-variable-default app-tag)))) + + (setq dirty + (if app + (srecode-map-update-app-file-entry srecode-current-map + file + (read val) + (read app)) + (srecode-map-update-file-entry srecode-current-map + file + (read val)))) + ) + ) + dirty))) + + +;;; THE PATH +;; +;; We need to do this last since the setter needs the above code. + +(defun srecode-map-load-path-set (sym val) + "Set SYM to the new VAL, then update the srecode map." + (set-default sym val) + (srecode-map-update-map t)) + +(defcustom srecode-map-load-path + (list (srecode-map-base-template-dir) + (expand-file-name "~/.srecode/") + ) + "*Global load path for SRecode template files." + :group 'srecode + :type '(repeat file) + :set 'srecode-map-load-path-set) + +(provide 'srecode/map) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: srecode/loaddefs +;; generated-autoload-load-name: "srecode/map" +;; End: + +;;; srecode/map.el ends here diff --git a/lisp/cedet/srecode/mode.el b/lisp/cedet/srecode/mode.el new file mode 100644 index 00000000000..3100a392cf2 --- /dev/null +++ b/lisp/cedet/srecode/mode.el @@ -0,0 +1,420 @@ +;;; srecode/mode.el --- Minor mode for managing and using SRecode templates + +;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Minor mode for working with SRecode template files. +;; +;; Depends on Semantic for minor-mode convenience functions. + +(require 'mode-local) +(require 'srecode) +(require 'srecode/insert) +(require 'srecode/find) +(require 'srecode/map) +;; (require 'senator) +(require 'semantic/decorate) +(require 'semantic/wisent) + +(eval-when-compile (require 'semantic/find)) + +;;; Code: + +(defcustom global-srecode-minor-mode nil + "Non-nil in buffers with Semantic Recoder macro keybindings." + :group 'srecode + :type 'boolean + :require 'srecode-mode + :initialize 'custom-initialize-default + :set (lambda (sym val) + (global-srecode-minor-mode (if val 1 -1)))) + +(defvar srecode-minor-mode nil + "Non-nil in buffers with Semantic Recoder macro keybindings.") +(make-variable-buffer-local 'srecode-minor-mode) + +(defcustom srecode-minor-mode-hook nil + "Hook run at the end of the function `srecode-minor-mode'." + :group 'srecode + :type 'hook) + +;; We don't want to waste space. There is a menu after all. +;;(add-to-list 'minor-mode-alist '(srecode-minor-mode "")) + +(defvar srecode-prefix-key [(control ?c) ?/] + "The common prefix key in srecode minor mode.") + +(defvar srecode-prefix-map + (let ((km (make-sparse-keymap))) + ;; Basic template codes + (define-key km "/" 'srecode-insert) + (define-key km [insert] 'srecode-insert) + (define-key km "." 'srecode-insert-again) + (define-key km "E" 'srecode-edit) + ;; Template indirect binding + (let ((k ?a)) + (while (<= k ?z) + (define-key km (format "%c" k) 'srecode-bind-insert) + (setq k (1+ k)))) + km) + "Keymap used behind the srecode prefix key in in srecode minor mode.") + +(defvar srecode-menu-bar + (list + "SRecoder" + (senator-menu-item + ["Insert Template" + srecode-insert + :active t + :help "Insert a template by name." + ]) + (senator-menu-item + ["Insert Template Again" + srecode-insert-again + :active t + :help "Run the same template as last time again." + ]) + (senator-menu-item + ["Edit Template" + srecode-edit + :active t + :help "Edit a template for this language by name." + ]) + "---" + '( "Insert ..." :filter srecode-minor-mode-templates-menu ) + `( "Generate ..." :filter srecode-minor-mode-generate-menu ) + "---" + (senator-menu-item + ["Customize..." + (customize-group "srecode") + :active t + :help "Customize SRecode options" + ]) + (list + "Debugging Tools..." + (senator-menu-item + ["Dump Template MAP" + srecode-get-maps + :active t + :help "Calculate (if needed) and display the current template file map." + ]) + (senator-menu-item + ["Dump Tables" + srecode-dump-templates + :active t + :help "Dump the current template table." + ]) + (senator-menu-item + ["Dump Dictionary" + srecode-dictionary-dump + :active t + :help "Calculate a dump a dictionary for point." + ]) + ) + ) + "Menu for srecode minor mode.") + +(defvar srecode-minor-menu nil + "Menu keymap build from `srecode-menu-bar'.") + +(defcustom srecode-takeover-INS-key nil + "Use the insert key for inserting templates." + :group 'srecode + :type 'boolean) + +(defvar srecode-mode-map + (let ((km (make-sparse-keymap))) + (define-key km srecode-prefix-key srecode-prefix-map) + (easy-menu-define srecode-minor-menu km "Srecode Minor Mode Menu" + srecode-menu-bar) + (when srecode-takeover-INS-key + (define-key km [insert] srecode-prefix-map)) + km) + "Keymap for srecode minor mode.") + +;;;###autoload +(defun srecode-minor-mode (&optional arg) + "Toggle srecode minor mode. +With prefix argument ARG, turn on if positive, otherwise off. The +minor mode can be turned on only if semantic feature is available and +the current buffer was set up for parsing. Return non-nil if the +minor mode is enabled. + +\\{srecode-mode-map}" + (interactive + (list (or current-prefix-arg + (if srecode-minor-mode 0 1)))) + ;; Flip the bits. + (setq srecode-minor-mode + (if arg + (> + (prefix-numeric-value arg) + 0) + (not srecode-minor-mode))) + ;; If we are turning things on, make sure we have templates for + ;; this mode first. + (when srecode-minor-mode + (when (not (apply + 'append + (mapcar (lambda (map) + (srecode-map-entries-for-mode map major-mode)) + (srecode-get-maps)))) + (setq srecode-minor-mode nil)) + ) + ;; Run hooks if we are turning this on. + (when srecode-minor-mode + (run-hooks 'srecode-minor-mode-hook)) + srecode-minor-mode) + +;;;###autoload +(defun global-srecode-minor-mode (&optional arg) + "Toggle global use of srecode minor mode. +If ARG is positive, enable, if it is negative, disable. +If ARG is nil, then toggle." + (interactive "P") + (setq global-srecode-minor-mode + (semantic-toggle-minor-mode-globally + 'srecode-minor-mode arg))) + +;; Use the semantic minor mode magic stuff. +(semantic-add-minor-mode 'srecode-minor-mode "" srecode-mode-map) + +;;; Menu Filters +;; +(defun srecode-minor-mode-templates-menu (menu-def) + "Create a menu item of cascading filters active for this mode. +MENU-DEF is the menu to bind this into." + ;; Doing this SEGVs Emacs on windows. + ;;(srecode-load-tables-for-mode major-mode) + + (let* ((modetable (srecode-get-mode-table major-mode)) + (subtab (when modetable (oref modetable :tables))) + (context nil) + (active nil) + (ltab nil) + (temp nil) + (alltabs nil) + ) + (if (not subtab) + ;; No tables, show a "load the tables" option. + (list (vector "Load Mode Tables..." + (lambda () + (interactive) + (srecode-load-tables-for-mode major-mode)) + )) + ;; Build something + (setq context (car-safe (srecode-calculate-context))) + + (while subtab + (setq ltab (oref (car subtab) templates)) + (while ltab + (setq temp (car ltab)) + + ;; Do something with this template. + + (let* ((ctxt (oref temp context)) + (ctxtcons (assoc ctxt alltabs)) + (bind (if (slot-boundp temp 'binding) + (oref temp binding))) + (name (object-name-string temp))) + + (when (not ctxtcons) + (if (string= context ctxt) + ;; If this context is not in the current list of contexts + ;; is equal to the current context, then manage the + ;; active list instead + (setq active + (setq ctxtcons (or active (cons ctxt nil)))) + ;; This is not an active context, add it to alltabs. + (setq ctxtcons (cons ctxt nil)) + (setq alltabs (cons ctxtcons alltabs)))) + + (let ((new (vector + (if bind + (concat name " (" bind ")") + name) + `(lambda () (interactive) + (srecode-insert (concat ,ctxt ":" ,name))) + t))) + + (setcdr ctxtcons (cons + new + (cdr ctxtcons))))) + + (setq ltab (cdr ltab))) + (setq subtab (cdr subtab))) + + ;; Now create the menu + (easy-menu-filter-return + (easy-menu-create-menu + "Semantic Recoder Filters" + (append (cdr active) + alltabs) + )) + ))) + +(defvar srecode-minor-mode-generators nil + "List of code generators to be displayed in the srecoder menu.") + +(defun srecode-minor-mode-generate-menu (menu-def) + "Create a menu item of cascading filters active for this mode. +MENU-DEF is the menu to bind this into." + ;; Doing this SEGVs Emacs on windows. + ;;(srecode-load-tables-for-mode major-mode) + (let ((allgeneratorapps nil)) + + (dolist (gen srecode-minor-mode-generators) + (setq allgeneratorapps + (cons (vector (cdr gen) (car gen)) + allgeneratorapps)) + (message "Adding %S to srecode menu" (car gen)) + ) + + (easy-menu-filter-return + (easy-menu-create-menu + "Semantic Recoder Generate Filters" + allgeneratorapps))) + ) + +;;; Minor Mode commands +;; +(defun srecode-bind-insert () + "Bound insert for Srecode macros. +This command will insert whichever srecode template has a binding +to the current key." + (interactive) + (let* ((k last-command-event) + (ctxt (srecode-calculate-context)) + ;; Find the template with the binding K + (template (srecode-template-get-table-for-binding + (srecode-table) k ctxt))) + ;; test it. + (when (not template) + (error "No template bound to %c" k)) + ;; insert + (srecode-insert template) + )) + +(defun srecode-edit (template-name) + "Switch to the template buffer for TEMPLATE-NAME. +Template is chosen based on the mode of the starting buffer." + ;; @todo - Get a template stack from the last run template, and show + ;; those too! + (interactive (list (srecode-read-template-name + "Template Name: " + (car srecode-read-template-name-history)))) + (if (not (srecode-table)) + (error "No template table found for mode %s" major-mode)) + (let ((temp (srecode-template-get-table (srecode-table) template-name))) + (if (not temp) + (error "No Template named %s" template-name)) + ;; We need a template specific table, since tables chain. + (let ((tab (oref temp :table)) + (names nil) + ) + (find-file (oref tab :file)) + (setq names (semantic-find-tags-by-name (oref temp :object-name) + (current-buffer))) + (cond ((= (length names) 1) + (semantic-go-to-tag (car names)) + (semantic-momentary-highlight-tag (car names))) + ((> (length names) 1) + (let* ((ctxt (semantic-find-tags-by-name (oref temp :context) + (current-buffer))) + (cls (semantic-find-tags-by-class 'context ctxt)) + ) + (while (and names + (< (semantic-tag-start (car names)) + (semantic-tag-start (car cls)))) + (setq names (cdr names))) + (if names + (progn + (semantic-go-to-tag (car names)) + (semantic-momentary-highlight-tag (car names))) + (error "Can't find template %s" template-name)) + )) + (t (error "Can't find template %s" template-name))) + ))) + +(defun srecode-add-code-generator (function name &optional binding) + "Add the srecoder code generator FUNCTION with NAME to the menu. +Optional BINDING specifies the keybinding to use in the srecoder map. +BINDING should be a capital letter. Lower case letters are reserved +for individual templates. +Optional MODE specifies a major mode this function applies to. +Do not specify a mode if this function could be applied to most +programming modes." + ;; Update the menu generating part. + (let ((remloop nil)) + (while (setq remloop (assoc function srecode-minor-mode-generators)) + (setq srecode-minor-mode-generators + (remove remloop srecode-minor-mode-generators)))) + + (add-to-list 'srecode-minor-mode-generators + (cons function name)) + + ;; Remove this function from any old bindings. + (when binding + (let ((oldkey (where-is-internal function + (list srecode-prefix-map) + t t t))) + (if (or (not oldkey) + (and (= (length oldkey) 1) + (= (length binding) 1) + (= (aref oldkey 0) (aref binding 0)))) + ;; Its the same. + nil + ;; Remove the old binding + (define-key srecode-prefix-map oldkey nil) + ))) + + ;; Update Keybings + (let ((oldbinding (lookup-key srecode-prefix-map binding))) + + ;; During development, allow overrides. + (when (and oldbinding + (not (eq oldbinding function)) + (or (eq this-command 'eval-defun) (eq this-command 'checkdoc-eval-defun)) + (y-or-n-p (format "Override old binding %s? " oldbinding))) + (setq oldbinding nil)) + + (if (not oldbinding) + (define-key srecode-prefix-map binding function) + (if (eq function oldbinding) + nil + ;; Not the same. + (message "Conflict binding %S binding to srecode map." + binding)))) + ) + +;; Add default code generators: +(srecode-add-code-generator 'srecode-document-insert-comment "Comments" "C") +(srecode-add-code-generator 'srecode-insert-getset "Get/Set" "G") + +(provide 'srecode/mode) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: srecode/loaddefs +;; generated-autoload-load-name: "srecode/mode" +;; End: + +;;; srecode/mode.el ends here diff --git a/lisp/cedet/srecode/semantic.el b/lisp/cedet/srecode/semantic.el new file mode 100644 index 00000000000..178ec44a8de --- /dev/null +++ b/lisp/cedet/srecode/semantic.el @@ -0,0 +1,431 @@ +;;; srecode/semantic.el --- Semantic specific extensions to SRecode. + +;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Semantic specific extensions to the Semantic Recoder. +;; +;; I realize it is the "Semantic Recoder", but most of srecode +;; is a template library and set of user interfaces unrelated to +;; semantic in the specific. +;; +;; This file defines the following: +;; - :tag argument handling. +;; - <more goes here> + +;;; Code: + +(require 'srecode/insert) +(require 'srecode/dictionary) +(require 'semantic/find) +(require 'semantic/format) +(require 'ring) +;;(require 'senator) + + +;;; The SEMANTIC TAG inserter +;; +;; Put a tag into the dictionary that can be used w/ arbitrary +;; lisp expressions. + +(defclass srecode-semantic-tag (srecode-dictionary-compound-value) + ((prime :initarg :prime + :type semantic-tag + :documentation + "This is the primary insertion tag.") + ) + "Wrap up a collection of semantic tag information. +This class will be used to derive dictionary values.") + +(defmethod srecode-compound-toString((cp srecode-semantic-tag) + function + dictionary) + "Convert the compound dictionary value CP to a string. +If FUNCTION is non-nil, then FUNCTION is somehow applied to an +aspect of the compound value." + (if (not function) + ;; Just format it in some handy dandy way. + (semantic-format-tag-prototype (oref cp :prime)) + ;; Otherwise, apply the function to the tag itself. + (funcall function (oref cp :prime)) + )) + + +;;; Managing the `current' tag +;; + +(defvar srecode-semantic-selected-tag nil + "The tag selected by a :tag template argument. +If this is nil, then `senator-tag-ring' is used.") + +(defun srecode-semantic-tag-from-kill-ring () + "Create an `srecode-semantic-tag' from the senator kill ring." + (if (ring-empty-p senator-tag-ring) + (error "You must use `senator-copy-tag' to provide a tag to this template")) + (ring-ref senator-tag-ring 0)) + + +;;; TAG in a DICTIONARY +;; +(defvar srecode-semantic-apply-tag-augment-hook nil + "A function called for each tag added to a dictionary. +The hook is called with two arguments, the TAG and DICT +to be augmented.") + +(define-overload srecode-semantic-apply-tag-to-dict (tagobj dict) + "Insert fewatures of TAGOBJ into the dictionary DICT. +TAGOBJ is an object of class `srecode-semantic-tag'. This class +is a compound inserter value. +DICT is a dictionary object. +At a minimum, this function will create dictionary macro for NAME. +It is also likely to create macros for TYPE (data type), function arguments, +variable default values, and other things." + ) + +(defun srecode-semantic-apply-tag-to-dict-default (tagobj dict) + "Insert features of TAGOBJ into dictionary DICT." + ;; Store the sst into the dictionary. + (srecode-dictionary-set-value dict "TAG" tagobj) + + ;; Pull out the tag for the individual pieces. + (let ((tag (oref tagobj :prime))) + + (srecode-dictionary-set-value dict "NAME" (semantic-tag-name tag)) + (srecode-dictionary-set-value dict "TYPE" (semantic-format-tag-type tag nil)) + + (run-hook-with-args 'srecode-semantic-apply-tag-augment-hook tag dict) + + (cond + ;; + ;; FUNCTION + ;; + ((eq (semantic-tag-class tag) 'function) + ;; FCN ARGS + (let ((args (semantic-tag-function-arguments tag))) + (while args + (let ((larg (car args)) + (subdict (srecode-dictionary-add-section-dictionary + dict "ARGS"))) + ;; Clean up elements in the arg list. + (if (stringp larg) + (setq larg (semantic-tag-new-variable + larg nil nil))) + ;; Apply the sub-argument to the subdictionary. + (srecode-semantic-apply-tag-to-dict + (srecode-semantic-tag (semantic-tag-name larg) + :prime larg) + subdict) + ) + ;; Next! + (setq args (cdr args)))) + ;; PARENTS + (let ((p (semantic-tag-function-parent tag))) + (when p + (srecode-dictionary-set-value dict "PARENT" p) + )) + ;; EXCEPTIONS (java/c++) + (let ((exceptions (semantic-tag-get-attribute tag :throws))) + (while exceptions + (let ((subdict (srecode-dictionary-add-section-dictionary + dict "THROWS"))) + (srecode-dictionary-set-value subdict "NAME" (car exceptions)) + ) + (setq exceptions (cdr exceptions))) + ) + ) + ;; + ;; VARIABLE + ;; + ((eq (semantic-tag-class tag) 'variable) + (when (semantic-tag-variable-default tag) + (let ((subdict (srecode-dictionary-add-section-dictionary + dict "HAVEDEFAULT"))) + (srecode-dictionary-set-value + subdict "VALUE" (semantic-tag-variable-default tag)))) + ) + ;; + ;; TYPE + ;; + ((eq (semantic-tag-class tag) 'type) + (dolist (p (semantic-tag-type-superclasses tag)) + (let ((sd (srecode-dictionary-add-section-dictionary + dict "PARENTS"))) + (srecode-dictionary-set-value sd "NAME" p) + )) + (dolist (i (semantic-tag-type-interfaces tag)) + (let ((sd (srecode-dictionary-add-section-dictionary + dict "INTERFACES"))) + (srecode-dictionary-set-value sd "NAME" i) + )) +; NOTE : The members are too complicated to do via a template. +; do it via the insert-tag solution instead. +; +; (dolist (mem (semantic-tag-type-members tag)) +; (let ((subdict (srecode-dictionary-add-section-dictionary +; dict "MEMBERS"))) +; (when (stringp mem) +; (setq mem (semantic-tag-new-variable mem nil nil))) +; (srecode-semantic-apply-tag-to-dict +; (srecode-semantic-tag (semantic-tag-name mem) +; :prime mem) +; subdict))) + )))) + + +;;; ARGUMENT HANDLERS + +;;; :tag ARGUMENT HANDLING +;; +;; When a :tag argument is required, identify the current :tag, +;; and apply it's parts into the dictionary. +(defun srecode-semantic-handle-:tag (dict) + "Add macroes into the dictionary DICT based on the current :tag." + ;; We have a tag, start adding "stuff" into the dictionary. + (let ((tag (or srecode-semantic-selected-tag + (srecode-semantic-tag-from-kill-ring)))) + (when (not tag) + "No tag for current template. Use the semantic kill-ring.") + (srecode-semantic-apply-tag-to-dict + (srecode-semantic-tag (semantic-tag-name tag) + :prime tag) + dict))) + +;;; :tagtype ARGUMENT HANDLING +;; +;; When a :tagtype argument is required, identify the current tag, of +;; cf class 'type. Apply those parameters to the dictionary. + +(defun srecode-semantic-handle-:tagtype (dict) + "Add macroes into the dictionary DICT based on a tag of class type at point. +Assumes the cursor is in a tag of class type. If not, throw an error." + (let ((typetag (or srecode-semantic-selected-tag + (semantic-current-tag-of-class 'type)))) + (when (not typetag) + (error "Cursor is not in a TAG of class 'type")) + (srecode-semantic-apply-tag-to-dict + typetag + dict))) + + +;;; INSERT A TAG API +;; +;; Routines that take a tag, and insert into a buffer. +(define-overload srecode-semantic-find-template (class prototype ctxt) + "Find a template for a tag of class CLASS based on context. +PROTOTYPE is non-nil if we want a prototype template instead." + ) + +(defun srecode-semantic-find-template-default (class prototype ctxt) + "Find a template for tag CLASS based on context. +PROTOTYPE is non-nil if we need a prototype. +CTXT is the pre-calculated context." + (let* ((top (car ctxt)) + (tname (if (stringp class) + class + (symbol-name class))) + (temp nil) + ) + ;; Try to find a template. + (setq temp (or + (when prototype + (srecode-template-get-table (srecode-table) + (concat tname "-tag-prototype") + top)) + (when prototype + (srecode-template-get-table (srecode-table) + (concat tname "-prototype") + top)) + (srecode-template-get-table (srecode-table) + (concat tname "-tag") + top) + (srecode-template-get-table (srecode-table) + tname + top) + (when (and (not (string= top "declaration")) + prototype) + (srecode-template-get-table (srecode-table) + (concat tname "-prototype") + "declaration")) + (when (and (not (string= top "declaration")) + prototype) + (srecode-template-get-table (srecode-table) + (concat tname "-tag-prototype") + "declaration")) + (when (not (string= top "declaration")) + (srecode-template-get-table (srecode-table) + (concat tname "-tag") + "declaration")) + (when (not (string= top "declaration")) + (srecode-template-get-table (srecode-table) + tname + "declaration")) + )) + temp)) + +(defun srecode-semantic-insert-tag (tag &optional style-option + point-insert-fcn + &rest dict-entries) + "Insert TAG into a buffer useing srecode templates at point. + +Optional STYLE-OPTION is a list of minor configuration of styles, +such as the symbol 'prototype for prototype functions, or +'system for system includes, and 'doxygen, for a doxygen style +comment. + +Optional third argument POINT-INSERT-FCN is a hook that is run after +TAG is inserted that allows an opportunity to fill in the body of +some thing. This hook function is called with one argument, the TAG +being inserted. + +The rest of the arguments are DICT-ENTRIES. DICT-ENTRIES +is of the form ( NAME1 VALUE1 NAME2 VALUE2 ... NAMEn VALUEn). + +The exact template used is based on the current context. +The template used is found within the toplevel context as calculated +by `srecode-calculate-context', such as `declaration', `classdecl', +or `code'. + +For various conditions, this function looks for a template with +the name CLASS-tag, where CLASS is the tag class. If it cannot +find that, it will look for that template in the +`declaration'context (if the current context was not `declaration'). + +If PROTOTYPE is specified, it will first look for templates with +the name CLASS-tag-prototype, or CLASS-prototype as above. + +See `srecode-semantic-apply-tag-to-dict' for details on what is in +the dictionary when the templates are called. + +This function returns to location in the buffer where the +inserted tag ENDS, and will leave point inside the inserted +text based on any occurance of a point-inserter. Templates such +as `function' will leave point where code might be inserted." + (srecode-load-tables-for-mode major-mode) + (let* ((ctxt (srecode-calculate-context)) + (top (car ctxt)) + (tname (symbol-name (semantic-tag-class tag))) + (dict (srecode-create-dictionary)) + (temp nil) + (errtype tname) + (prototype (memq 'prototype style-option)) + ) + ;; Try some special cases. + (cond ((and (semantic-tag-of-class-p tag 'function) + (semantic-tag-get-attribute tag :constructor-flag)) + (setq temp (srecode-semantic-find-template + "constructor" prototype ctxt)) + ) + + ((and (semantic-tag-of-class-p tag 'function) + (semantic-tag-get-attribute tag :destructor-flag)) + (setq temp (srecode-semantic-find-template + "destructor" prototype ctxt)) + ) + + ((and (semantic-tag-of-class-p tag 'function) + (semantic-tag-function-parent tag)) + (setq temp (srecode-semantic-find-template + "method" prototype ctxt)) + ) + + ((and (semantic-tag-of-class-p tag 'variable) + (semantic-tag-get-attribute tag :constant-flag)) + (setq temp (srecode-semantic-find-template + "variable-const" prototype ctxt)) + ) + ) + + (when (not temp) + ;; Try the basics + (setq temp (srecode-semantic-find-template + tname prototype ctxt))) + + ;; Try some backup template names. + (when (not temp) + (cond + ;; Types might split things up based on the type's type. + ((and (eq (semantic-tag-class tag) 'type) + (semantic-tag-type tag)) + (setq temp (srecode-semantic-find-template + (semantic-tag-type tag) prototype ctxt)) + (setq errtype (concat errtype " or " (semantic-tag-type tag))) + ) + ;; A function might be an externally declared method. + ((and (eq (semantic-tag-class tag) 'function) + (semantic-tag-function-parent tag)) + (setq temp (srecode-semantic-find-template + "method" prototype ctxt))) + (t + nil) + )) + + ;; Can't find one? Drat! + (when (not temp) + (error "Cannot find template %s in %s for inserting tag %S" + errtype top (semantic-format-tag-summarize tag))) + + ;; Resolve Arguments + (let ((srecode-semantic-selected-tag tag)) + (srecode-resolve-arguments temp dict)) + + ;; Resolve TAG into the dictionary. We may have a :tag arg + ;; from the macro such that we don't need to do this. + (when (not (srecode-dictionary-lookup-name dict "TAG")) + (let ((tagobj (srecode-semantic-tag (semantic-tag-name tag) :prime tag)) + ) + (srecode-semantic-apply-tag-to-dict tagobj dict))) + + ;; Insert dict-entries into the dictionary LAST so that previous + ;; items can be overriden. + (let ((entries dict-entries)) + (while entries + (srecode-dictionary-set-value dict + (car entries) + (car (cdr entries))) + (setq entries (cdr (cdr entries))))) + + ;; Insert the template. + (let ((endpt (srecode-insert-fcn temp dict nil t))) + + (run-hook-with-args 'point-insert-fcn tag) + ;;(sit-for 1) + + (cond + ((semantic-tag-of-class-p tag 'type) + ;; Insert all the members at the current insertion point. + (dolist (m (semantic-tag-type-members tag)) + + (when (stringp m) + (setq m (semantic-tag-new-variable m nil nil))) + + ;; We do prototypes w/in the class decl? + (let ((me (srecode-semantic-insert-tag m '(prototype)))) + (goto-char me)) + + )) + ) + + endpt) + )) + +(provide 'srecode/semantic) + +;;; srecode/semantic.el ends here diff --git a/lisp/cedet/srecode/srt-mode.el b/lisp/cedet/srecode/srt-mode.el new file mode 100644 index 00000000000..004e4a86848 --- /dev/null +++ b/lisp/cedet/srecode/srt-mode.el @@ -0,0 +1,775 @@ +;;; srecode/srt-mode.el --- Major mode for writing screcode macros + +;; Copyright (C) 2005, 2007, 2008, 2009 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Originally named srecode-template-mode.el in the CEDET repository. + +(require 'srecode/compile) +(require 'srecode/ctxt) +(require 'srecode/template) + +(require 'semantic) +(require 'semantic/analyze) +(require 'semantic/wisent) +(eval-when-compile + (require 'semantic/find)) + +(declare-function srecode-create-dictionary "srecode/dictionary") +(declare-function srecode-resolve-argument-list "srecode/insert") + +;;; Code: +(defvar srecode-template-mode-syntax-table + (let ((table (make-syntax-table (standard-syntax-table)))) + (modify-syntax-entry ?\; ". 12" table) ;; SEMI, Comment start ;; + (modify-syntax-entry ?\n ">" table) ;; Comment end + (modify-syntax-entry ?$ "." table) ;; Punctuation + (modify-syntax-entry ?: "." table) ;; Punctuation + (modify-syntax-entry ?< "." table) ;; Punctuation + (modify-syntax-entry ?> "." table) ;; Punctuation + (modify-syntax-entry ?# "." table) ;; Punctuation + (modify-syntax-entry ?! "." table) ;; Punctuation + (modify-syntax-entry ?? "." table) ;; Punctuation + (modify-syntax-entry ?\" "\"" table) ;; String + (modify-syntax-entry ?\- "_" table) ;; Symbol + (modify-syntax-entry ?\\ "\\" table) ;; Quote + (modify-syntax-entry ?\` "'" table) ;; Prefix ` (backquote) + (modify-syntax-entry ?\' "'" table) ;; Prefix ' (quote) + (modify-syntax-entry ?\, "'" table) ;; Prefix , (comma) + + table) + "Syntax table used in semantic recoder macro buffers.") + +(defface srecode-separator-face + '((t (:weight bold :strike-through t))) + "Face used for decorating separators in srecode template mode." + :group 'srecode) + +(defvar srecode-font-lock-keywords + '( + ;; Template + ("^\\(template\\)\\s-+\\(\\w*\\)\\(\\( \\(:\\w+\\)\\|\\)+\\)$" + (1 font-lock-keyword-face) + (2 font-lock-function-name-face) + (3 font-lock-builtin-face )) + ("^\\(sectiondictionary\\)\\s-+\"" + (1 font-lock-keyword-face)) + ("^\\(bind\\)\\s-+\"" + (1 font-lock-keyword-face)) + ;; Variable type setting + ("^\\(set\\)\\s-+\\(\\w+\\)\\s-+" + (1 font-lock-keyword-face) + (2 font-lock-variable-name-face)) + ("^\\(show\\)\\s-+\\(\\w+\\)\\s-*$" + (1 font-lock-keyword-face) + (2 font-lock-variable-name-face)) + ("\\<\\(macro\\)\\s-+\"" + (1 font-lock-keyword-face)) + ;; Context type setting + ("^\\(context\\)\\s-+\\(\\w+\\)" + (1 font-lock-keyword-face) + (2 font-lock-builtin-face)) + ;; Prompting setting + ("^\\(prompt\\)\\s-+\\(\\w+\\)" + (1 font-lock-keyword-face) + (2 font-lock-variable-name-face)) + ("\\(default\\(macro\\)?\\)\\s-+\\(\\(\\w\\|\\s_\\)+\\)" + (1 font-lock-keyword-face) + (3 font-lock-type-face)) + ("\\<\\(default\\(macro\\)?\\)\\>" (1 font-lock-keyword-face)) + ("\\<\\(read\\)\\s-+\\(\\(\\w\\|\\s_\\)+\\)" + (1 font-lock-keyword-face) + (2 font-lock-type-face)) + + ;; Macro separators + ("^----\n" 0 'srecode-separator-face) + + ;; Macro Matching + (srecode-template-mode-macro-escape-match 1 font-lock-string-face) + ((lambda (limit) + (srecode-template-mode-font-lock-macro-helper + limit "\\(\\??\\w+\\)[^ \t\n{}$#@&*()]*")) + 1 font-lock-variable-name-face) + ((lambda (limit) + (srecode-template-mode-font-lock-macro-helper + limit "\\([#/]\\w+\\)[^ \t\n{}$#@&*()]*")) + 1 font-lock-keyword-face) + ((lambda (limit) + (srecode-template-mode-font-lock-macro-helper + limit "\\([<>]\\w*\\):\\(\\w+\\):\\(\\w+\\)")) + (1 font-lock-keyword-face) + (2 font-lock-builtin-face) + (3 font-lock-type-face)) + ((lambda (limit) + (srecode-template-mode-font-lock-macro-helper + limit "\\([<>?]?\\w*\\):\\(\\w+\\)")) + (1 font-lock-keyword-face) + (2 font-lock-type-face)) + ((lambda (limit) + (srecode-template-mode-font-lock-macro-helper + limit "!\\([^{}$]*\\)")) + 1 font-lock-comment-face) + + ) + "Keywords for use with srecode macros and font-lock.") + +(defun srecode-template-mode-font-lock-macro-helper (limit expression) + "Match against escape characters. +Don't scan past LIMIT. Match with EXPRESSION." + (let* ((done nil) + (md nil) + (es (regexp-quote (srecode-template-get-escape-start))) + (ee (regexp-quote (srecode-template-get-escape-end))) + (regex (concat es expression ee)) + ) + (while (not done) + (save-match-data + (if (re-search-forward regex limit t) + (when (equal (car (srecode-calculate-context)) "code") + (setq md (match-data) + done t)) + (setq done t)))) + (set-match-data md) + ;; (when md (message "Found a match!")) + (when md t))) + +(defun srecode-template-mode-macro-escape-match (limit) + "Match against escape characters. +Don't scan past LIMIT." + (let* ((done nil) + (md nil) + (es (regexp-quote (srecode-template-get-escape-start))) + (ee (regexp-quote (srecode-template-get-escape-end))) + (regex (concat "\\(" es "\\|" ee "\\)")) + ) + (while (not done) + (save-match-data + (if (re-search-forward regex limit t) + (when (equal (car (srecode-calculate-context)) "code") + (setq md (match-data) + done t)) + (setq done t)))) + (set-match-data md) + ;;(when md (message "Found a match!")) + (when md t))) + +(defvar srecode-font-lock-macro-keywords nil + "Dynamically generated `font-lock' keywords for srecode templates. +Once the escape_start, and escape_end sequences are known, then +we can tell font lock about them.") + +(defvar srecode-template-mode-map + (let ((km (make-sparse-keymap))) + (define-key km "\C-c\C-c" 'srecode-compile-templates) + (define-key km "\C-c\C-m" 'srecode-macro-help) + (define-key km "/" 'srecode-self-insert-complete-end-macro) + km) + "Keymap used in srecode mode.") + +;;;###autoload +(defun srecode-template-mode () + "Major-mode for writing srecode macros." + (interactive) + (kill-all-local-variables) + (setq major-mode 'srecode-template-mode + mode-name "SRecoder" + comment-start ";;" + comment-end "") + (set (make-local-variable 'parse-sexp-ignore-comments) t) + (set (make-local-variable 'comment-start-skip) + "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") + (set-syntax-table srecode-template-mode-syntax-table) + (use-local-map srecode-template-mode-map) + (set (make-local-variable 'font-lock-defaults) + '(srecode-font-lock-keywords + nil ;; perform string/comment fontification + nil ;; keywords are case sensitive. + ;; This puts _ & - as a word constituant, + ;; simplifying our keywords significantly + ((?_ . "w") (?- . "w")))) + (run-hooks 'srecode-template-mode-hook)) + +;;;###autoload +(defalias 'srt-mode 'srecode-template-mode) + +;;; Template Commands +;; +(defun srecode-self-insert-complete-end-macro () + "Self insert the current key, then autocomplete the end macro." + (interactive) + (call-interactively 'self-insert-command) + (when (and (semantic-current-tag) + (semantic-tag-of-class-p (semantic-current-tag) 'function) + ) + (let* ((es (srecode-template-get-escape-start)) + (ee (srecode-template-get-escape-end)) + (name (save-excursion + (forward-char (- (length es))) + (forward-char -1) + (if (looking-at (regexp-quote es)) + (srecode-up-context-get-name (point) t)))) + ) + (when name + (insert name) + (insert ee)))) + ) + + +(defun srecode-macro-help () + "Provide help for working with macros in a tempalte." + (interactive) + (let* ((root 'srecode-template-inserter) + (chl (aref (class-v root) class-children)) + (ess (srecode-template-get-escape-start)) + (ees (srecode-template-get-escape-end)) + ) + (with-output-to-temp-buffer "*SRecode Macros*" + (princ "Description of known SRecode Template Macros.") + (terpri) + (terpri) + (while chl + (let* ((C (car chl)) + (name (symbol-name C)) + (key (when (slot-exists-p C 'key) + (oref C key))) + (showexample t) + ) + (setq chl (cdr chl)) + (setq chl (append (aref (class-v C) class-children) chl)) + + (catch 'skip + (when (eq C 'srecode-template-inserter-section-end) + (throw 'skip nil)) + + (when (class-abstract-p C) + (throw 'skip nil)) + + (princ "`") + (princ name) + (princ "'") + (when (slot-exists-p C 'key) + (when key + (princ " - Character Key: ") + (if (stringp key) + (progn + (setq showexample nil) + (cond ((string= key "\n") + (princ "\"\\n\"") + ) + (t + (prin1 key) + ))) + (prin1 (format "%c" key)) + ))) + (terpri) + (princ (documentation-property C 'variable-documentation)) + (terpri) + (when showexample + (princ "Example:") + (terpri) + (srecode-inserter-prin-example C ess ees) + ) + + (terpri) + + ) ;; catch + );; let* + )))) + + +;;; Misc Language Overrides +;; +(define-mode-local-override semantic-ia-insert-tag + srecode-template-mode (tag) + "Insert the SRecode TAG into the current buffer." + (insert (semantic-tag-name tag))) + + +;;; Local Context Parsing. + +(defun srecode-in-macro-p (&optional point) + "Non-nil if POINT is inside a macro bounds. +If the ESCAPE_START and END are different sequences, +a simple search is used. If ESCAPE_START and END are the same +characteres, start at the beginning of the line, and find out +how many occur." + (let ((tag (semantic-current-tag)) + (es (regexp-quote (srecode-template-get-escape-start))) + (ee (regexp-quote (srecode-template-get-escape-end))) + (start (or point (point))) + ) + (when (and tag (semantic-tag-of-class-p tag 'function)) + (if (string= es ee) + (save-excursion + (beginning-of-line) + (while (re-search-forward es start t 2)) + (if (re-search-forward es start t) + ;; If there is a single, the the answer is yes. + t + ;; If there wasn't another, then the answer is no. + nil) + ) + ;; ES And EE are not the same. + (save-excursion + (and (re-search-backward es (semantic-tag-start tag) t) + (>= (or (re-search-forward ee (semantic-tag-end tag) t) + ;; No end match means an incomplete macro. + start) + start))) + )))) + +(defun srecode-up-context-get-name (&optional point find-unmatched) + "Move up one context as for `semantic-up-context', and return the name. +Moves point to the opening characters of the section macro text. +If there is no upper context, return nil. +Starts at POINT if provided. +If FIND-UNMATCHED is specified as non-nil, then we are looking for an unmatched +section." + (when point (goto-char (point))) + (let* ((tag (semantic-current-tag)) + (es (regexp-quote (srecode-template-get-escape-start))) + (start (concat es "[#<]\\(\\w+\\)")) + (orig (point)) + (name nil) + (res nil)) + (when (semantic-tag-of-class-p tag 'function) + (while (and (not res) + (re-search-backward start (semantic-tag-start tag) t)) + (when (save-excursion + (setq name (match-string 1)) + (let ((endr (concat es "/" name))) + (if (re-search-forward endr (semantic-tag-end tag) t) + (< orig (point)) + (if (not find-unmatched) + (error "Unmatched Section Template") + ;; We found what we want. + t)))) + (setq res (point))) + ) + ;; Restore in no result found. + (goto-char (or res orig)) + name))) + +(define-mode-local-override semantic-up-context + srecode-template-mode (&optional point) + "Move up one context in the current code. +Moves out one named section." + (not (srecode-up-context-get-name point))) + +(define-mode-local-override semantic-beginning-of-context + srecode-template-mode (&optional point) + "Move to the beginning of the current context. +Moves the the beginning of one named section." + (if (semantic-up-context point) + t + (let ((es (regexp-quote (srecode-template-get-escape-start))) + (ee (regexp-quote (srecode-template-get-escape-end)))) + (re-search-forward es) ;; move over the start chars. + (re-search-forward ee) ;; Move after the end chars. + nil))) + +(define-mode-local-override semantic-end-of-context + srecode-template-mode (&optional point) + "Move to the beginning of the current context. +Moves the the beginning of one named section." + (let ((name (srecode-up-context-get-name point)) + (tag (semantic-current-tag)) + (es (regexp-quote (srecode-template-get-escape-start)))) + (if (not name) + t + (unless (re-search-forward (concat es "/" name) (semantic-tag-end tag) t) + (error "Section %s has no end" name)) + (goto-char (match-beginning 0)) + nil))) + +(define-mode-local-override semantic-get-local-variables + srecode-template-mode (&optional point) + "Get local variables from an SRecode template." + (save-excursion + (when point (goto-char (point))) + (let* ((tag (semantic-current-tag)) + (name (save-excursion + (srecode-up-context-get-name (point)))) + (subdicts (semantic-tag-get-attribute tag :dictionaries)) + (global nil) + ) + (dolist (D subdicts) + (setq global (cons (semantic-tag-new-variable (car D) nil) + global))) + (if name + ;; Lookup any subdictionaries in TAG. + (let ((res nil)) + + (while (and (not res) subdicts) + ;; Find the subdictionary with the same name. Those variables + ;; are now local to this section. + (when (string= (car (car subdicts)) name) + (setq res (cdr (car subdicts)))) + (setq subdicts (cdr subdicts))) + ;; Pre-pend our global vars. + (append global res)) + ;; If we aren't in a subsection, just do the global variables + global + )))) + +(define-mode-local-override semantic-get-local-arguments + srecode-template-mode (&optional point) + "Get local arguments from an SRecode template." + (require 'srecode/insert) + (save-excursion + (when point (goto-char (point))) + (let* ((tag (semantic-current-tag)) + (args (semantic-tag-function-arguments tag)) + (argsym (mapcar 'intern args)) + (argvars nil) + ;; Create a temporary dictionary in which the + ;; arguments can be resolved so we can extract + ;; the results. + (dict (srecode-create-dictionary t)) + ) + ;; Resolve args into our temp dictionary + (srecode-resolve-argument-list argsym dict) + + (maphash + (lambda (key entry) + (setq argvars + (cons (semantic-tag-new-variable key nil entry) + argvars))) + (oref dict namehash)) + + argvars))) + +(define-mode-local-override semantic-ctxt-current-symbol + srecode-template-mode (&optional point) + "Return the current symbol under POINT. +Return nil if point is not on/in a template macro." + (let ((macro (srecode-parse-this-macro point))) + (cdr macro)) + ) + +(defun srecode-parse-this-macro (&optional point) + "Return the current symbol under POINT. +Return nil if point is not on/in a template macro. +The first element is the key for the current macro, such as # for a +section or ? for an ask variable." + (save-excursion + (if point (goto-char point)) + (let ((tag (semantic-current-tag)) + (es (regexp-quote (srecode-template-get-escape-start))) + (ee (regexp-quote (srecode-template-get-escape-end))) + (start (point)) + (macrostart nil) + (raw nil) + ) + (when (and tag (semantic-tag-of-class-p tag 'function) + (srecode-in-macro-p point) + (re-search-backward es (semantic-tag-start tag) t)) + (setq macrostart (match-end 0)) + (goto-char macrostart) + ;; We have a match + (when (not (re-search-forward ee (semantic-tag-end tag) t)) + (goto-char start) ;; Pretend we are ok for completion + (set-match-data (list start start)) + ) + + (if (> start (point)) + ;; If our starting point is after the found point, that + ;; means we are not inside the macro. Retur nil. + nil + ;; We are inside the macro, extract the text so far. + (let* ((macroend (match-beginning 0)) + (raw (buffer-substring-no-properties + macrostart macroend)) + (STATE (srecode-compile-state "TMP")) + (inserter (condition-case nil + (srecode-compile-parse-inserter + raw STATE) + (error nil))) + ) + (when inserter + (let ((base + (cons (oref inserter :object-name) + (if (and (slot-boundp inserter :secondname) + (oref inserter :secondname)) + (split-string (oref inserter :secondname) + ":") + nil))) + (key (oref inserter key))) + (cond ((null key) + ;; A plain variable + (cons nil base)) + (t + ;; A complex variable thingy. + (cons (format "%c" key) + base))))) + ) + ))) + )) + +(define-mode-local-override semantic-analyze-current-context + srecode-template-mode (point) + "Provide a Semantic analysis in SRecode template mode." + (let* ((context-return nil) + (prefixandbounds (semantic-ctxt-current-symbol-and-bounds)) + (prefix (car prefixandbounds)) + (bounds (nth 2 prefixandbounds)) + (key (car (srecode-parse-this-macro (point)))) + (prefixsym nil) + (prefix-var nil) + (prefix-context nil) + (prefix-function nil) + (prefixclass (semantic-ctxt-current-class-list)) + (globalvar (semantic-find-tags-by-class 'variable (current-buffer))) + (argtype 'macro) + (scope (semantic-calculate-scope point)) + ) + + (oset scope fullscope (append (oref scope localvar) globalvar)) + + (when prefix + ;; First, try to find the variable for the first + ;; entry in the prefix list. + (setq prefix-var (semantic-find-first-tag-by-name + (car prefix) (oref scope fullscope))) + + (cond + ((and (or (not key) (string= key "?")) + (> (length prefix) 1)) + ;; Variables can have lisp function names. + (with-mode-local emacs-lisp-mode + (let ((fcns (semanticdb-find-tags-by-name (car (last prefix))))) + (setq prefix-function (car (semanticdb-find-result-nth fcns 0))) + (setq argtype 'elispfcn))) + ) + ((or (string= key "<") (string= key ">")) + ;; Includes have second args that is the template name. + (if (= (length prefix) 3) + (let ((contexts (semantic-find-tags-by-class + 'context (current-buffer)))) + (setq prefix-context + (or (semantic-find-first-tag-by-name + (nth 1 prefix) contexts) + ;; Calculate from location + (semantic-tag + (symbol-name + (srecode-template-current-context)) + 'context))) + (setq argtype 'template)) + (setq prefix-context + ;; Calculate from location + (semantic-tag + (symbol-name (srecode-template-current-context)) + 'context)) + (setq argtype 'template) + ) + ;; The last one? + (when (> (length prefix) 1) + (let ((toc (srecode-template-find-templates-of-context + (read (semantic-tag-name prefix-context)))) + ) + (setq prefix-function + (or (semantic-find-first-tag-by-name + (car (last prefix)) toc) + ;; Not in this buffer? Search the master + ;; templates list. + nil)) + )) + ) + ) + + (setq prefixsym + (cond ((= (length prefix) 3) + (list (or prefix-var (nth 0 prefix)) + (or prefix-context (nth 1 prefix)) + (or prefix-function (nth 2 prefix)))) + ((= (length prefix) 2) + (list (or prefix-var (nth 0 prefix)) + (or prefix-function (nth 1 prefix)))) + ((= (length prefix) 1) + (list (or prefix-var (nth 0 prefix))) + ))) + + (setq context-return + (semantic-analyze-context-functionarg + "context-for-srecode" + :buffer (current-buffer) + :scope scope + :bounds bounds + :prefix (or prefixsym + prefix) + :prefixtypes nil + :prefixclass prefixclass + :errors nil + ;; Use the functionarg analyzer class so we + ;; can save the current key, and the index + ;; into the macro part we are completing on. + :function (list key) + :index (length prefix) + :argument (list argtype) + )) + + context-return))) + +(define-mode-local-override semantic-analyze-possible-completions + srecode-template-mode (context) + "Return a list of possible completions based on NONTEXT." + (save-excursion + (set-buffer (oref context buffer)) + (let* ((prefix (car (last (oref context :prefix)))) + (prefixstr (cond ((stringp prefix) + prefix) + ((semantic-tag-p prefix) + (semantic-tag-name prefix)))) +; (completetext (cond ((semantic-tag-p prefix) +; (semantic-tag-name prefix)) +; ((stringp prefix) +; prefix) +; ((stringp (car prefix)) +; (car prefix)))) + (argtype (car (oref context :argument))) + (matches nil)) + + ;; Depending on what the analyzer is, we have different ways + ;; of creating completions. + (cond ((eq argtype 'template) + (setq matches (semantic-find-tags-for-completion + prefixstr (current-buffer))) + (setq matches (semantic-find-tags-by-class + 'function matches)) + ) + ((eq argtype 'elispfcn) + (with-mode-local emacs-lisp-mode + (setq matches (semanticdb-find-tags-for-completion + prefixstr)) + (setq matches (semantic-find-tags-by-class + 'function matches)) + ) + ) + ((eq argtype 'macro) + (let ((scope (oref context scope))) + (setq matches + (semantic-find-tags-for-completion + prefixstr (oref scope fullscope)))) + ) + ) + + matches))) + + + +;;; Utils +;; +(defun srecode-template-get-mode () + "Get the supported major mode for this template file." + (let ((m (semantic-find-first-tag-by-name "mode" (current-buffer)))) + (when m (read (semantic-tag-variable-default m))))) + +(defun srecode-template-get-escape-start () + "Get the current escape_start characters." + (let ((es (semantic-find-first-tag-by-name "escape_start" (current-buffer))) + ) + (if es (car (semantic-tag-get-attribute es :default-value)) + "{{"))) + +(defun srecode-template-get-escape-end () + "Get the current escape_end characters." + (let ((ee (semantic-find-first-tag-by-name "escape_end" (current-buffer))) + ) + (if ee (car (semantic-tag-get-attribute ee :default-value)) + "}}"))) + +(defun srecode-template-current-context (&optional point) + "Calculate the context encompassing POINT." + (save-excursion + (when point (goto-char (point))) + (let ((ct (semantic-current-tag))) + (when (not ct) + (setq ct (semantic-find-tag-by-overlay-prev))) + + ;; Loop till we find the context. + (while (and ct (not (semantic-tag-of-class-p ct 'context))) + (setq ct (semantic-find-tag-by-overlay-prev + (semantic-tag-start ct)))) + + (if ct + (read (semantic-tag-name ct)) + 'declaration)))) + +(defun srecode-template-find-templates-of-context (context &optional buffer) + "Find all the templates belonging to a particular CONTEXT. +When optional BUFFER is provided, search that buffer." + (save-excursion + (when buffer (set-buffer buffer)) + (let ((tags (semantic-fetch-available-tags)) + (cc 'declaration) + (scan nil) + (ans nil)) + + (when (eq cc context) + (setq scan t)) + + (dolist (T tags) + ;; Handle contexts + (when (semantic-tag-of-class-p T 'context) + (setq cc (read (semantic-tag-name T))) + (when (eq cc context) + (setq scan t))) + + ;; Scan + (when (and scan (semantic-tag-of-class-p T 'function)) + (setq ans (cons T ans))) + ) + + (nreverse ans)))) + + +;;; MMM-Mode support ?? +;;(condition-case nil +;; (require 'mmm-mode) +;; (error (message "SRecoder Template Mode: No multi-mode not support."))) +;; +;;(defun srecode-template-add-submode () +;; "Add a submode to the current template file using mmm-mode. +;;If mmm-mode isn't available, then do nothing." +;; (if (not (featurep 'mmm-mode)) +;; nil ;; Nothing to do. +;; ;; Else, set up mmm-mode in this buffer. +;; (let ((submode (semantic-find-tags-by-name "mode"))) +;; (if (not submode) +;; nil ;; Nothing to do. +;; ;; Well, we have a mode, lets try turning on mmm-mode. +;; +;; ;; (mmm-mode-on) +;; +;; +;; +;; )))) +;; + +(provide 'srecode/srt-mode) + +;; The autoloads in this file must go into the global loaddefs.el, not +;; the srecode one, so that srecode-template-mode can be called from +;; auto-mode-alist. + +;; Local variables: +;; generated-autoload-load-name: "srecode/srt-mode" +;; End: + +;;; srecode/srt-mode.el ends here diff --git a/lisp/cedet/srecode/srt-wy.el b/lisp/cedet/srecode/srt-wy.el new file mode 100644 index 00000000000..4446a66afca --- /dev/null +++ b/lisp/cedet/srecode/srt-wy.el @@ -0,0 +1,277 @@ +;;; srecode/srt-wy.el --- Generated parser support file + +;; Copyright (C) 2005, 2007, 2008, 2009 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Generated from srecode-template.wy in the CEDET repository. + +;;; Code: + +(require 'semantic/lex) + + +;;; Prologue +;; + +;;; Declarations +;; +(defconst srecode-template-wy--keyword-table + (semantic-lex-make-keyword-table + '(("set" . SET) + ("show" . SHOW) + ("macro" . MACRO) + ("context" . CONTEXT) + ("template" . TEMPLATE) + ("sectiondictionary" . SECTIONDICTIONARY) + ("prompt" . PROMPT) + ("default" . DEFAULT) + ("defaultmacro" . DEFAULTMACRO) + ("read" . READ) + ("bind" . BIND)) + '(("bind" summary "bind \"<letter>\"") + ("read" summary "prompt <symbol> \"Describe Symbol: \" [default[macro] <lispsym>|\"valuetext\"] [read <lispsym>]") + ("defaultmacro" summary "prompt <symbol> \"Describe Symbol: \" [default[macro] <lispsym>|\"valuetext\"] [read <lispsym>]") + ("default" summary "prompt <symbol> \"Describe Symbol: \" [default[macro] <lispsym>|\"valuetext\"] [read <lispsym>]") + ("prompt" summary "prompt <symbol> \"Describe Symbol: \" [default[macro] <lispsym>|\"valuetext\"] [read <lispsym>]") + ("sectiondictionary" summary "sectiondictionary <name>\\n <dictionary entries>") + ("template" summary "template <name>\\n <template definition>") + ("context" summary "context <name>") + ("macro" summary "... macro \"string\" ...") + ("show" summary "show <name> ; to show a section") + ("set" summary "set <name> <value>"))) + "Table of language keywords.") + +(defconst srecode-template-wy--token-table + (semantic-lex-make-type-table + '(("number" + (number)) + ("string" + (string)) + ("symbol" + (symbol)) + ("property" + (property)) + ("separator" + (TEMPLATE_BLOCK . "^----")) + ("newline" + (newline))) + '(("number" :declared t) + ("string" :declared t) + ("symbol" :declared t) + ("property" :declared t) + ("newline" :declared t) + ("punctuation" syntax "\\s.+") + ("punctuation" :declared t) + ("keyword" :declared t))) + "Table of lexical tokens.") + +(defconst srecode-template-wy--parse-table + (progn + (eval-when-compile + (require 'semantic/wisent/comp)) + (wisent-compile-grammar + '((SET SHOW MACRO CONTEXT TEMPLATE SECTIONDICTIONARY PROMPT DEFAULT DEFAULTMACRO READ BIND newline TEMPLATE_BLOCK property symbol string number) + nil + (template_file + ((newline) + nil) + ((context)) + ((prompt)) + ((variable)) + ((template))) + (context + ((CONTEXT symbol newline) + (wisent-raw-tag + (semantic-tag $2 'context)))) + (prompt + ((PROMPT symbol string opt-default-fcn opt-read-fcn newline) + (wisent-raw-tag + (semantic-tag $2 'prompt :text + (read $3) + :default $4 :read $5)))) + (opt-default-fcn + ((DEFAULT symbol) + (progn + (read $2))) + ((DEFAULT string) + (progn + (read $2))) + ((DEFAULTMACRO string) + (progn + (cons 'macro + (read $2)))) + (nil nil)) + (opt-read-fcn + ((READ symbol) + (progn + (read $2))) + (nil nil)) + (variable + ((SET symbol insertable-string-list newline) + (wisent-raw-tag + (semantic-tag-new-variable $2 nil $3))) + ((SHOW symbol newline) + (wisent-raw-tag + (semantic-tag-new-variable $2 nil t)))) + (insertable-string-list + ((insertable-string) + (list $1)) + ((insertable-string-list insertable-string) + (append $1 + (list $2)))) + (insertable-string + ((string) + (read $1)) + ((MACRO string) + (cons 'macro + (read $2)))) + (template + ((TEMPLATE templatename opt-dynamic-arguments newline opt-string opt-section-dictionaries TEMPLATE_BLOCK newline opt-bind) + (wisent-raw-tag + (semantic-tag-new-function $2 nil $3 :documentation $5 :code $7 :dictionaries $6 :binding $9)))) + (templatename + ((symbol)) + ((PROMPT)) + ((CONTEXT)) + ((TEMPLATE)) + ((DEFAULT)) + ((MACRO)) + ((DEFAULTMACRO)) + ((READ)) + ((SET))) + (opt-dynamic-arguments + ((property opt-dynamic-arguments) + (cons $1 $2)) + (nil nil)) + (opt-string + ((string newline) + (read $1)) + (nil nil)) + (opt-section-dictionaries + (nil nil) + ((section-dictionary-list))) + (section-dictionary-list + ((one-section-dictionary) + (list $1)) + ((section-dictionary-list one-section-dictionary) + (append $1 + (list $2)))) + (one-section-dictionary + ((SECTIONDICTIONARY string newline variable-list) + (cons + (read $2) + $4))) + (variable-list + ((variable) + (wisent-cook-tag $1)) + ((variable-list variable) + (append $1 + (wisent-cook-tag $2)))) + (opt-bind + ((BIND string newline) + (read $2)) + (nil nil))) + '(template_file))) + "Parser table.") + +(defun srecode-template-wy--install-parser () + "Setup the Semantic Parser." + (semantic-install-function-overrides + '((parse-stream . wisent-parse-stream))) + (setq semantic-parser-name "LALR" + semantic--parse-table srecode-template-wy--parse-table + semantic-debug-parser-source "srecode-template.wy" + semantic-flex-keywords-obarray srecode-template-wy--keyword-table + semantic-lex-types-obarray srecode-template-wy--token-table) + ;; Collect unmatched syntax lexical tokens + (semantic-make-local-hook 'wisent-discarding-token-functions) + (add-hook 'wisent-discarding-token-functions + 'wisent-collect-unmatched-syntax nil t)) + + +;;; Analyzers +;; +(define-lex-keyword-type-analyzer srecode-template-wy--<keyword>-keyword-analyzer + "keyword analyzer for <keyword> tokens." + "\\(\\sw\\|\\s_\\)+") + +(define-lex-regex-type-analyzer srecode-template-wy--<symbol>-regexp-analyzer + "regexp analyzer for <symbol> tokens." + "\\(\\sw\\|\\s_\\)+" + nil + 'symbol) + +(define-lex-sexp-type-analyzer srecode-template-wy--<string>-sexp-analyzer + "sexp analyzer for <string> tokens." + "\\s\"" + 'string) + +(define-lex-regex-type-analyzer srecode-template-wy--<number>-regexp-analyzer + "regexp analyzer for <number> tokens." + semantic-lex-number-expression + nil + 'number) + +(define-lex-string-type-analyzer srecode-template-wy--<punctuation>-string-analyzer + "string analyzer for <punctuation> tokens." + "\\s.+" + nil + 'punctuation) + + +;;; Epilogue +;; +(define-lex-simple-regex-analyzer srecode-template-property-analyzer + "Detect and create a dynamic argument properties." + ":\\(\\w\\|\\s_\\)*" 'property 0) + +(define-lex-regex-analyzer srecode-template-separator-block + "Detect and create a template quote block." + "^----\n" + (semantic-lex-push-token + (semantic-lex-token + 'TEMPLATE_BLOCK + (match-end 0) + (semantic-lex-unterminated-syntax-protection 'TEMPLATE_BLOCK + (goto-char (match-end 0)) + (re-search-forward "^----$") + (match-beginning 0)))) + (setq semantic-lex-end-point (point))) + + +(define-lex wisent-srecode-template-lexer + "Lexical analyzer that handles SRecode Template buffers. +It ignores whitespace, newlines and comments." + semantic-lex-newline + semantic-lex-ignore-whitespace + semantic-lex-ignore-newline + semantic-lex-ignore-comments + srecode-template-separator-block + srecode-template-wy--<keyword>-keyword-analyzer + srecode-template-property-analyzer + srecode-template-wy--<symbol>-regexp-analyzer + srecode-template-wy--<number>-regexp-analyzer + srecode-template-wy--<string>-sexp-analyzer + srecode-template-wy--<punctuation>-string-analyzer + semantic-lex-default-action + ) + +(provide 'srecode/srt-wy) + +;;; srecode/srt-wy.el ends here diff --git a/lisp/cedet/srecode/srt.el b/lisp/cedet/srecode/srt.el new file mode 100644 index 00000000000..7f438ae5951 --- /dev/null +++ b/lisp/cedet/srecode/srt.el @@ -0,0 +1,106 @@ +;;; srecode/srt.el --- argument handlers for SRT files + +;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Filters for SRT files, the Semantic Recoder template files. + +;;; Code: + +(require 'eieio) +(require 'srecode/dictionary) +(require 'srecode/insert) + +(defvar srecode-read-variable-name-history nil + "History for `srecode-read-variable-name'.") + +(defun srecode-read-variable-name (prompt &optional initial hist default) + "Read in the name of a declaired variable in the current SRT file. +PROMPT is the prompt to use. +INITIAL is the initial string. +HIST is the history value, otherwise `srecode-read-variable-name-history' + is used. +DEFAULT is the default if RET is hit." + (let* ((newdict (srecode-create-dictionary)) + (currfcn (semantic-current-tag)) + ) + (srecode-resolve-argument-list + (mapcar 'read + (semantic-tag-get-attribute currfcn :arguments)) + newdict) + + (with-slots (namehash) newdict + (completing-read prompt namehash nil nil initial + (or hist 'srecode-read-variable-name-history) + default)) + )) + +(defvar srecode-read-major-mode-history nil + "History for `srecode-read-variable-name'.") + +(defun srecode-read-major-mode-name (prompt &optional initial hist default) + "Read in the name of a desired `major-mode'. +PROMPT is the prompt to use. +INITIAL is the initial string. +HIST is the history value, otherwise `srecode-read-variable-name-history' + is used. +DEFAULT is the default if RET is hit." + (completing-read prompt obarray + (lambda (s) (string-match "-mode$" (symbol-name s))) + nil initial (or hist 'srecode-read-major-mode-history)) + ) + +(defun srecode-semantic-handle-:srt (dict) + "Add macros into the dictionary DICT based on the current SRT file. +Adds the following: +ESCAPE_START - This files value of escape_start +ESCAPE_END - This files value of escape_end +MODE - The mode of this buffer. If not declared yet, guess." + (let* ((es (semantic-find-first-tag-by-name "escape_start" (current-buffer))) + (ee (semantic-find-first-tag-by-name "escape_end" (current-buffer))) + (mode-var (semantic-find-first-tag-by-name "mode" (current-buffer))) + (mode (if mode-var + (semantic-tag-variable-default mode-var) + nil)) + ) + (srecode-dictionary-set-value dict "ESCAPE_START" + (if es + (car (semantic-tag-variable-default es)) + "{{")) + (srecode-dictionary-set-value dict "ESCAPE_END" + (if ee + (car (semantic-tag-variable-default ee)) + "}}")) + (when (not mode) + (let* ((fname (file-name-nondirectory + (buffer-file-name (current-buffer)))) + ) + (when (string-match "-\\(\\w+\\)\\.srt" fname) + (setq mode (concat (match-string 1 fname) "-mode"))))) + + (when mode + (srecode-dictionary-set-value dict "MAJORMODE" mode)) + + )) + +(provide 'srecode/srt) + +;;; srecode/srt.el ends here diff --git a/lisp/cedet/srecode/table.el b/lisp/cedet/srecode/table.el new file mode 100644 index 00000000000..2591983c7a6 --- /dev/null +++ b/lisp/cedet/srecode/table.el @@ -0,0 +1,248 @@ +;;; srecode/table.el --- Tables of Semantic Recoders + +;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Semantic Recoder tables manage lists of templates and the major +;; modes they are associated with. +;; + +(require 'eieio) +(require 'eieio-base) +(require 'mode-local) +(require 'srecode) + +(declare-function srecode-load-tables-for-mode "srecode/find") + +;;; Code: + +;;; TEMPLATE TABLE +;; +(defclass srecode-template-table () + (;; + ;; Raw file tracking + ;; + (file :initarg :file + :type string + :documentation + "The name of the file this table was built from.") + (filesize :initarg :filesize + :type number + :documentation + "The size of the file when it was parsed.") + (filedate :initarg :filedate + :type cons + :documentation + "Date from the inode of the file when it was last edited. +Format is from the `file-attributes' function.") + (major-mode :initarg :major-mode + :documentation + "The major mode this table of templates is associated with.") + ;; + ;; Template file sorting data + ;; + (application :initarg :application + :type symbol + :documentation + "Tracks the name of the application these templates belong to. +If this is nil, then this template table belongs to a set of generic +templates that can be used with no additional dictionary values. +When it is non-nil, it is assumed the template macros need specialized +Emacs Lisp code to fill in the dictoinary.") + (priority :initarg :priority + :type number + :documentation + "For file of this Major Mode, what is the priority of this file. +When there are multiple template files with similar names, templates with +the highest priority are scanned last, allowing them to override values in +previous template files.") + ;; + ;; Parsed Data from the template file + ;; + (templates :initarg :templates + :type list + :documentation + "The list of templates compiled into this table.") + (namehash :initarg :namehash + :documentation + "Hash table containing the names of all the templates.") + (contexthash :initarg :contexthash + :documentation + "") + (variables :initarg :variables + :documentation + "AList of variables. +These variables are used to initialize dictionaries.") + ) + "Semantic recoder template table. +A Table contains all templates from a single .srt file. +Tracks various lookup hash tables.") + +;;; MODE TABLE +;; +(defvar srecode-mode-table-list nil + "List of all the SRecode mode table classes that have been built.") + +(defclass srecode-mode-table (eieio-instance-tracker) + ((tracking-symbol :initform 'srecode-mode-table-list) + (major-mode :initarg :major-mode + :documentation + "Table of template tables for this major-mode.") + (tables :initarg :tables + :documentation + "All the tables that have been defined for this major mode.") + ) + "Track template tables for a particular major mode. +Tracks all the template-tables for a specific major mode.") + +(defun srecode-get-mode-table (mode) + "Get the SRecoder mode table for the major mode MODE. +Optional argument SOFT indicates to not make a new one if a table +was not found." + (let ((ans nil)) + (while (and (not ans) mode) + (setq ans (eieio-instance-tracker-find + mode 'major-mode 'srecode-mode-table-list) + mode (get-mode-local-parent mode))) + ans)) + +(defun srecode-make-mode-table (mode) + "Get the SRecoder mode table for the major mode MODE." + (let ((old (eieio-instance-tracker-find + mode 'major-mode 'srecode-mode-table-list))) + (if old + old + (let* ((ms (if (stringp mode) mode (symbol-name mode))) + (new (srecode-mode-table ms + :major-mode mode + :tables nil))) + ;; Save this new mode table in that mode's variable. + (eval `(setq-mode-local ,mode srecode-table ,new)) + + new)))) + +(defmethod srecode-mode-table-find ((mt srecode-mode-table) file) + "Look in the mode table MT for a template table from FILE. +Return nil if there was none." + (object-assoc file 'file (oref mt tables))) + +(defun srecode-mode-table-new (mode file &rest init) + "Create a new template table for MODE in FILE. +INIT are the initialization parametrs for the new template table." + (let* ((mt (srecode-make-mode-table mode)) + (old (srecode-mode-table-find mt file)) + (attr (file-attributes file)) + (new (apply 'srecode-template-table + (file-name-nondirectory file) + :file file + :filesize (nth 7 attr) + :filedate (nth 5 attr) + :major-mode mode + init + ))) + ;; Whack the old table. + (when old (object-remove-from-list mt 'tables old)) + ;; Add the new table + (object-add-to-list mt 'tables new) + ;; Sort the list in reverse order. When other routines + ;; go front-to-back, the highest priority items are put + ;; into the search table first, allowing lower priority items + ;; to be the items found in the search table. + (object-sort-list mt 'tables (lambda (a b) + (> (oref a :priority) + (oref b :priority)))) + ;; Return it. + new)) + +(defun object-sort-list (object slot predicate) + "Sort the items in OBJECT's SLOT. +Use PREDICATE is the same as for the `sort' function." + (when (slot-boundp object slot) + (when (listp (eieio-oref object slot)) + (eieio-oset object slot (sort (eieio-oref object slot) predicate))))) + +;;; DEBUG +;; +;; Dump out information about the current srecoder compiled templates. +;; +(defun srecode-dump-templates (mode) + "Dump a list of the current templates for MODE." + (interactive "sMode: ") + (require 'srecode/find) + (let ((modesym (cond ((string= mode "") + major-mode) + ((not (string-match "-mode" mode)) + (intern-soft (concat mode "-mode"))) + (t + (intern-soft mode))))) + (srecode-load-tables-for-mode modesym) + (let ((tmp (srecode-get-mode-table modesym)) + ) + (if (not tmp) + (error "No table found for mode %S" modesym)) + (with-output-to-temp-buffer "*SRECODE DUMP*" + (srecode-dump tmp)) + ))) + +(defmethod srecode-dump ((tab srecode-mode-table)) + "Dump the contents of the SRecode mode table TAB." + (princ "MODE TABLE FOR ") + (princ (oref tab :major-mode)) + (princ "\n--------------------------------------------\n\nNumber of tables: ") + (let ((subtab (oref tab :tables))) + (princ (length subtab)) + (princ "\n\n") + (while subtab + (srecode-dump (car subtab)) + (setq subtab (cdr subtab))) + )) + +(defmethod srecode-dump ((tab srecode-template-table)) + "Dump the contents of the SRecode template table TAB." + (princ "Template Table for ") + (princ (object-name-string tab)) + (princ "\nPriority: ") + (prin1 (oref tab :priority)) + (when (oref tab :application) + (princ "\nApplication: ") + (princ (oref tab :application))) + (princ "\n\nVariables:\n") + (let ((vars (oref tab variables))) + (while vars + (princ (car (car vars))) + (princ "\t") + (if (< (length (car (car vars))) 9) + (princ "\t")) + (prin1 (cdr (car vars))) + (princ "\n") + (setq vars (cdr vars)))) + (princ "\n\nTemplates:\n") + (let ((temp (oref tab templates))) + (while temp + (srecode-dump (car temp)) + (setq temp (cdr temp)))) + ) + + +(provide 'srecode/table) + +;;; srecode/table.el ends here + diff --git a/lisp/cedet/srecode/template.el b/lisp/cedet/srecode/template.el new file mode 100644 index 00000000000..fee960f5852 --- /dev/null +++ b/lisp/cedet/srecode/template.el @@ -0,0 +1,69 @@ +;;; srecode-template.el --- SRecoder template language parser support. + +;;; Copyright (C) 2005, 2007, 2008 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Parser setup for the semantic recoder template parser. + +;;; Code: +(require 'semantic) +(require 'semantic/ctxt) +(require 'semantic/wisent) +(require 'srecode/srt-wy) + +(define-mode-local-override semantic-tag-components + srecode-template-mode (tag) + "Return sectiondictionary tags." + (when (semantic-tag-of-class-p tag 'function) + (let ((dicts (semantic-tag-get-attribute tag :dictionaries)) + (ans nil)) + (while dicts + (setq ans (append ans (cdr (car dicts)))) + (setq dicts (cdr dicts))) + ans) + )) + +(defun srecode-template-setup-parser () + "Setup buffer for parse." + (srecode-template-wy--install-parser) + + (setq + ;; Lexical Analysis + semantic-lex-analyzer 'wisent-srecode-template-lexer + ;; Parsing + ;; Environment + semantic-imenu-summary-function 'semantic-format-tag-name + imenu-create-index-function 'semantic-create-imenu-index + semantic-command-separation-character "\n" + semantic-lex-comment-regex ";;" + ;; Speedbar + semantic-symbol->name-assoc-list + '((function . "Template") + (variable . "Variable") + ) + ;; Navigation + senator-step-at-tag-classes '(function variable) + )) + +;;;;###autoload +(add-hook 'srecode-template-mode-hook 'srecode-template-setup-parser) + +(provide 'srecode/template) + +;;; srecode/template.el ends here diff --git a/lisp/cedet/srecode/texi.el b/lisp/cedet/srecode/texi.el new file mode 100644 index 00000000000..6c223f1cc5a --- /dev/null +++ b/lisp/cedet/srecode/texi.el @@ -0,0 +1,282 @@ +;;; srecode-texi.el --- Srecode texinfo support. + +;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Texinfo semantic recoder support. +;; +;; Contains some handlers, and a few simple texinfo srecoder applications. + +(require 'semantic) +(require 'semantic/texi) +(require 'srecode/semantic) + +;;; Code: + +(defun srecode-texi-add-menu (newnode) + "Add an item into the current menu. Add @node statements as well. +Argument NEWNODE is the name of the new node." + (interactive "sName of new node: ") + (srecode-load-tables-for-mode major-mode) + (semantic-fetch-tags) + (let ((currnode (reverse (semantic-find-tag-by-overlay))) + (nodebounds nil)) + (when (not currnode) + (error "Cannot find node to put menu item into")) + (setq currnode (car currnode)) + (setq nodebounds (semantic-tag-texi-section-text-bounds currnode)) + ;; Step 1: + ;; Limit search within this node. + ;; Step 2: + ;; Find the menu. If there isn't one, add one to the end. + ;; Step 3: + ;; Add new item to end of menu list. + ;; Step 4: + ;; Find correct node new item should show up after, and stick + ;; the new node there. + (if (string= (semantic-texi-current-environment) "menu") + ;; We are already in a menu, so insert the new item right here. + (beginning-of-line) + ;; Else, try to find a menu item to append to. + (goto-char (car nodebounds)) + (if (not (re-search-forward "^@menu" (car (cdr nodebounds)) t)) + (progn + (goto-char (car (cdr nodebounds))) + (if (not (y-or-n-p "Add menu here? ")) + (error "Abort")) + (srecode-insert "declaration:menu")) + ;; Else, find the end + (re-search-forward "@end menu") + (beginning-of-line))) + ;; At this point, we are in a menu... or not. + ;; If we are, do stuff, else error. + (when (string= (semantic-texi-current-environment) "menu") + (let ((menuname newnode) + (returnpoint nil)) + (srecode-insert "declaration:menuitem" "NAME" menuname) + (set-mark (point)) + (setq returnpoint (make-marker)) + ;; Update the bound since we added text + (setq nodebounds (semantic-tag-texi-section-text-bounds currnode)) + (beginning-of-line) + (forward-char -1) + (beginning-of-line) + (let ((end nil)) + (if (not (looking-at "\\* \\([^:]+\\):")) + (setq end (car (cdr nodebounds))) + (let* ((nname (match-string 1)) + (tag + (semantic-deep-find-tags-by-name nname (current-buffer)))) + (when tag + (setq end (semantic-tag-end (car tag)))) + )) + (when (not end) + (goto-char returnpoint) + (error "Could not find location for new node" )) + (when end + (goto-char end) + (when (bolp) (forward-char -1)) + (insert "\n") + (if (eq (semantic-current-tag) currnode) + (srecode-insert "declaration:subnode" "NAME" menuname) + (srecode-insert "declaration:node" "NAME" menuname)) + ) + ))) + )) + +;;;###autoload +(defun srecode-semantic-handle-:texi (dict) + "Add macros into the dictionary DICT based on the current texinfo file. +Adds the following: + LEVEL - chapter, section, subsection, etc + NEXTLEVEL - One below level" + + ;; LEVEL and NEXTLEVEL calculation + (semantic-fetch-tags) + (let ((tags (reverse (semantic-find-tag-by-overlay))) + (level nil)) + (while (and tags (not (semantic-tag-of-class-p (car tags) 'section))) + (setq tags (cdr tags))) + (when tags + (save-excursion + (goto-char (semantic-tag-start (car tags))) + (when (looking-at "@node") + (forward-line 1) + (beginning-of-line)) + (when (looking-at "@\\(\\w+\\)") + (setq level (match-string 1)) + ))) + (srecode-dictionary-set-value dict "LEVEL" (or level "chapter")) + (let ((nl (assoc level '( ( nil . "top" ) + ("top" . "chapter") + ("chapter" . "section") + ("section" . "subsection") + ("subsection" . "subsubsection") + ("subsubsection" . "subsubsection") + )))) + (srecode-dictionary-set-value dict "NEXTLEVEL" (cdr nl)))) + ) + +;;;###autoload +(defun srecode-semantic-handle-:texitag (dict) + "Add macros into the dictionary DICT based on the current :tag file. +Adds the following: + TAGDOC - Texinfo formatted doc string for :tag." + + ;; If we also have a TAG, what is the doc? + (let ((tag (srecode-dictionary-lookup-name dict "TAG")) + (doc nil) + ) + + ;; If the user didn't apply :tag, then do so now. + (when (not tag) + (srecode-semantic-handle-:tag dict)) + + (setq tag (srecode-dictionary-lookup-name dict "TAG")) + + (when (not tag) + (error "No tag to insert for :texitag template argument")) + + ;; Extract the tag out of the compound object. + (setq tag (oref tag :prime)) + + ;; Extract the doc string + (setq doc (semantic-documentation-for-tag tag)) + + (when doc + (srecode-dictionary-set-value dict "TAGDOC" + (srecode-texi-massage-to-texinfo + tag (semantic-tag-buffer tag) + doc))) + )) + +;;; OVERRIDES +;; +;; Override some semantic and srecode features with texi specific +;; versions. + +(define-mode-local-override semantic-insert-foreign-tag + texinfo-mode (foreign-tag) + "Insert TAG from a foreign buffer in TAGFILE. +Assume TAGFILE is a source buffer, and create a documentation +thingy from it using the `document' tool." + (let ((srecode-semantic-selected-tag foreign-tag)) + ;; @todo - choose of the many types of tags to insert, + ;; or put all that logic into srecode. + (srecode-insert "declaration:function"))) + + + +;;; Texinfo mangling. + +(define-overloadable-function srecode-texi-texify-docstring + (docstring) + "Texify the doc string DOCSTRING. +Takes plain text formatting that may exist, and converts it to +using TeXinfo formatting.") + +(defun srecode-texi-texify-docstring-default (docstring) + "Texify the doc string DOCSTRING. +Takes a few very generic guesses as to what the formatting is." + (let ((case-fold-search nil) + (start 0)) + (while (string-match + "\\(^\\|[^{]\\)\\<\\([A-Z0-9_-]+\\)\\>\\($\\|[^}]\\)" + docstring start) + (let ((ms (match-string 2 docstring))) + ;(when (eq mode 'emacs-lisp-mode) + ; (setq ms (downcase ms))) + + (when (not (or (string= ms "A") + (string= ms "a") + )) + (setq docstring (concat (substring docstring 0 (match-beginning 2)) + "@var{" + ms + "}" + (substring docstring (match-end 2)))))) + (setq start (match-end 2))) + ;; Return our modified doc string. + docstring)) + +(defun srecode-texi-massage-to-texinfo (tag buffer string) + "Massage TAG's documentation from BUFFER as STRING. +This is to take advantage of TeXinfo's markup symbols." + (save-excursion + (if buffer + (progn (set-buffer buffer) + (srecode-texi-texify-docstring string)) + ;; Else, no buffer, so lets do something else + (with-mode-local texinfo-mode + (srecode-texi-texify-docstring string))))) + +(define-mode-local-override srecode-texi-texify-docstring emacs-lisp-mode + (string) + "Take STRING, (a normal doc string), and convert it into a texinfo string. +For instances where CLASS is the class being referenced, do not Xref +that class. + + `function' => @dfn{function} + `variable' => @code{variable} + `class' => @code{class} @xref{class} + `unknown' => @code{unknonwn} + \"text\" => ``text'' + 'quoteme => @code{quoteme} + non-nil => non-@code{nil} + t => @code{t} + :tag => @code{:tag} + [ stuff ] => @code{[ stuff ]} + Key => @kbd{Key} (key is C\\-h, M\\-h, SPC, RET, TAB and the like) + ... => @dots{}" + (while (string-match "`\\([-a-zA-Z0-9<>.]+\\)'" string) + (let* ((vs (substring string (match-beginning 1) (match-end 1))) + (v (intern-soft vs))) + (setq string + (concat + (replace-match (concat + (if (fboundp v) + "@dfn{" "@code{") + vs "}") + nil t string))))) + (while (string-match "\\( \\|^\\)\\(nil\\|t\\|'[-a-zA-Z0-9]+\\|:[-a-zA-Z0-9]+\\)\\([. ,]\\|$\\)" string) + (setq string (replace-match "@code{\\2}" t nil string 2))) + (while (string-match "\\( \\|^\\)\\(\\(non-\\)\\(nil\\)\\)\\([. ,]\\|$\\)" string) + (setq string (replace-match "\\3@code{\\4}" t nil string 2))) + (while (string-match "\\( \\|^\\)\\(\\[[^]]+\\]\\)\\( \\|$\\)" string) + (setq string (replace-match "@code{\\2}" t nil string 2))) + (while (string-match "\\( \\|^\\)\\(\\(\\(C-\\|M-\\|S-\\)+\\([^ \t\n]\\|RET\\|SPC\\|TAB\\)\\)\\|\\(RET\\|SPC\\|TAB\\)\\)\\( \\|\\s.\\|$\\)" string) + (setq string (replace-match "@kbd{\\2}" t nil string 2))) + (while (string-match "\"\\(.+\\)\"" string) + (setq string (replace-match "``\\1''" t nil string 0))) + (while (string-match "\\.\\.\\." string) + (setq string (replace-match "@dots{}" t nil string 0))) + ;; Also do base docstring type. + (srecode-texi-texify-docstring-default string)) + +(provide 'srecode/texi) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: srecode/loaddefs +;; generated-autoload-load-name: "srecode/texi" +;; End: + +;;; srecode/texi.el ends here diff --git a/lisp/files.el b/lisp/files.el index c72faf3c677..0e70d673e8e 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -2203,6 +2203,7 @@ since only a single case-insensitive search through the alist is made." ("\\.f9[05]\\'" . f90-mode) ("\\.indent\\.pro\\'" . fundamental-mode) ; to avoid idlwave-mode ("\\.\\(pro\\|PRO\\)\\'" . idlwave-mode) + ("\\.srt\\'" . srecode-template-mode) ; in the CEDET library ("\\.prolog\\'" . prolog-mode) ("\\.tar\\'" . tar-mode) ;; The list of archive file extensions should be in sync with diff --git a/test/cedet/srecode-tests.el b/test/cedet/srecode-tests.el new file mode 100644 index 00000000000..0c13936829d --- /dev/null +++ b/test/cedet/srecode-tests.el @@ -0,0 +1,266 @@ +;;; From srecode-fields: + +(require 'srecode/fields) + +(defvar srecode-field-utest-text + "This is a test buffer. + +It is filled with some text." + "Text for tests.") + +(defun srecode-field-utest () + "Test the srecode field manager." + (interactive) + (if (featurep 'xemacs) + (message "There is no XEmacs support for SRecode Fields.") + (srecode-field-utest-impl))) + +(defun srecode-field-utest-impl () + "Implementation of the SRecode field utest." + (save-excursion + (find-file "/tmp/srecode-field-test.txt") + + (erase-buffer) + (goto-char (point-min)) + (insert srecode-field-utest-text) + (set-buffer-modified-p nil) + + ;; Test basic field generation. + (let ((srecode-field-archive nil) + (f nil)) + + (end-of-line) + (forward-word -1) + + (setq f (srecode-field "Test" + :name "TEST" + :start 6 + :end 8)) + + (when (or (not (slot-boundp f 'overlay)) (not (oref f overlay))) + (error "Field test: Overlay info not created for field")) + + (when (and (overlay-p (oref f overlay)) + (not (overlay-get (oref f overlay) 'srecode-init-only))) + (error "Field creation overlay is not tagged w/ init flag")) + + (srecode-overlaid-activate f) + + (when (or (not (overlay-p (oref f overlay))) + (overlay-get (oref f overlay) 'srecode-init-only)) + (error "New field overlay not created during activation")) + + (when (not (= (length srecode-field-archive) 1)) + (error "Field test: Incorrect number of elements in the field archive")) + (when (not (eq f (car srecode-field-archive))) + (error "Field test: Field did not auto-add itself to the field archive")) + + (when (not (overlay-get (oref f overlay) 'keymap)) + (error "Field test: Overlay keymap not set")) + + (when (not (string= "is" (srecode-overlaid-text f))) + (error "Field test: Expected field text 'is', not %s" + (srecode-overlaid-text f))) + + ;; Test deletion. + (srecode-delete f) + + (when (slot-boundp f 'overlay) + (error "Field test: Overlay not deleted after object delete")) + ) + + ;; Test basic region construction. + (let* ((srecode-field-archive nil) + (reg nil) + (fields + (list + (srecode-field "Test1" :name "TEST-1" :start 5 :end 10) + (srecode-field "Test2" :name "TEST-2" :start 15 :end 20) + (srecode-field "Test3" :name "TEST-3" :start 25 :end 30) + + (srecode-field "Test4" :name "TEST-4" :start 35 :end 35)) + )) + + (when (not (= (length srecode-field-archive) 4)) + (error "Region Test: Found %d fields. Expected 4" + (length srecode-field-archive))) + + (setq reg (srecode-template-inserted-region "REG" + :start 4 + :end 40)) + + (srecode-overlaid-activate reg) + + ;; Make sure it was cleared. + (when srecode-field-archive + (error "Region Test: Did not clear field archive")) + + ;; Auto-positioning. + (when (not (eq (point) 5)) + (error "Region Test: Did not reposition on first field")) + + ;; Active region + (when (not (eq (srecode-active-template-region) reg)) + (error "Region Test: Active region not set")) + + ;; Various sizes + (mapc (lambda (T) + (if (string= (object-name-string T) "Test4") + (progn + (when (not (srecode-empty-region-p T)) + (error "Field %s is not empty" + (object-name T))) + ) + (when (not (= (srecode-region-size T) 5)) + (error "Calculated size of %s was not 5" + (object-name T))))) + fields) + + ;; Make sure things stay up after a 'command'. + (srecode-field-post-command) + (when (not (eq (srecode-active-template-region) reg)) + (error "Region Test: Active region did not stay up")) + + ;; Test field movement. + (when (not (eq (srecode-overlaid-at-point 'srecode-field) + (nth 0 fields))) + (error "Region Test: Field %s not under point" + (object-name (nth 0 fields)))) + + (srecode-field-next) + + (when (not (eq (srecode-overlaid-at-point 'srecode-field) + (nth 1 fields))) + (error "Region Test: Field %s not under point" + (object-name (nth 1 fields)))) + + (srecode-field-prev) + + (when (not (eq (srecode-overlaid-at-point 'srecode-field) + (nth 0 fields))) + (error "Region Test: Field %s not under point" + (object-name (nth 0 fields)))) + + ;; Move cursor out of the region and have everything cleaned up. + (goto-char 42) + (srecode-field-post-command) + (when (srecode-active-template-region) + (error "Region Test: Active region did not clear on move out")) + + (mapc (lambda (T) + (when (slot-boundp T 'overlay) + (error "Overlay did not clear off of of field %s" + (object-name T)))) + fields) + + ;; End of LET + ) + + ;; Test variable linkage. + (let* ((srecode-field-archive nil) + (f1 (srecode-field "Test1" :name "TEST" :start 6 :end 8)) + (f2 (srecode-field "Test2" :name "TEST" :start 28 :end 30)) + (f3 (srecode-field "Test3" :name "NOTTEST" :start 35 :end 40)) + (reg (srecode-template-inserted-region "REG" :start 4 :end 40)) + ) + (srecode-overlaid-activate reg) + + (when (not (string= (srecode-overlaid-text f1) + (srecode-overlaid-text f2))) + (error "Linkage Test: Init strings are not =")) + (when (string= (srecode-overlaid-text f1) + (srecode-overlaid-text f3)) + (error "Linkage Test: Init string on dissimilar fields is now the same")) + + (goto-char 7) + (insert "a") + + (when (not (string= (srecode-overlaid-text f1) + (srecode-overlaid-text f2))) + (error "Linkage Test: mid-insert strings are not =")) + (when (string= (srecode-overlaid-text f1) + (srecode-overlaid-text f3)) + (error "Linkage Test: mid-insert string on dissimilar fields is now the same")) + + (goto-char 9) + (insert "t") + + (when (not (string= (srecode-overlaid-text f1) "iast")) + (error "Linkage Test: tail-insert failed to captured added char")) + (when (not (string= (srecode-overlaid-text f1) + (srecode-overlaid-text f2))) + (error "Linkage Test: tail-insert strings are not =")) + (when (string= (srecode-overlaid-text f1) + (srecode-overlaid-text f3)) + (error "Linkage Test: tail-insert string on dissimilar fields is now the same")) + + (goto-char 6) + (insert "b") + + (when (not (string= (srecode-overlaid-text f1) "biast")) + (error "Linkage Test: tail-insert failed to captured added char")) + (when (not (string= (srecode-overlaid-text f1) + (srecode-overlaid-text f2))) + (error "Linkage Test: tail-insert strings are not =")) + (when (string= (srecode-overlaid-text f1) + (srecode-overlaid-text f3)) + (error "Linkage Test: tail-insert string on dissimilar fields is now the same")) + + ;; Cleanup + (srecode-delete reg) + ) + + (set-buffer-modified-p nil) + + (message " All field tests passed.") + )) + +;;; From srecode-document: + +(require 'srecode/doc) + +(defun srecode-document-function-comment-extract-test () + "Test old comment extraction. +Dump out the extracted dictionary." + (interactive) + + (srecode-load-tables-for-mode major-mode) + (srecode-load-tables-for-mode major-mode 'document) + + (if (not (srecode-table)) + (error "No template table found for mode %s" major-mode)) + + (let* ((temp (srecode-template-get-table (srecode-table) + "function-comment" + "declaration" + 'document)) + (fcn-in (semantic-current-tag))) + + (if (not temp) + (error "No templates for function comments")) + + ;; Try to figure out the tag we want to use. + (when (or (not fcn-in) + (not (semantic-tag-of-class-p fcn-in 'function))) + (error "No tag of class 'function to insert comment for")) + + (let ((lextok (semantic-documentation-comment-preceeding-tag fcn-in 'lex)) + ) + + (when (not lextok) + (error "No comment to attempt an extraction")) + + (let ((s (semantic-lex-token-start lextok)) + (e (semantic-lex-token-end lextok)) + (extract nil)) + + (pulse-momentary-highlight-region s e) + + ;; Extract text from the existing comment. + (setq extract (srecode-extract temp s e)) + + (with-output-to-temp-buffer "*SRECODE DUMP*" + (princ "EXTRACTED DICTIONARY FOR ") + (princ (semantic-tag-name fcn-in)) + (princ "\n--------------------------------------------\n") + (srecode-dump extract)))))) |