diff options
Diffstat (limited to 'lisp/cedet/srecode/compile.el')
| -rw-r--r-- | lisp/cedet/srecode/compile.el | 641 |
1 files changed, 641 insertions, 0 deletions
diff --git a/lisp/cedet/srecode/compile.el b/lisp/cedet/srecode/compile.el new file mode 100644 index 00000000000..5b3d8fb50fc --- /dev/null +++ b/lisp/cedet/srecode/compile.el @@ -0,0 +1,641 @@ +;;; 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 key) + ;; 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)) + name + ) + (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 |