| 1 | ;;; srecode/compile --- Compilation of srecode template files. |
| 2 | |
| 3 | ;; Copyright (C) 2005, 2007-2012 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Eric M. Ludlam <zappo@gnu.org> |
| 6 | ;; Keywords: codegeneration |
| 7 | |
| 8 | ;; This file is part of GNU Emacs. |
| 9 | |
| 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
| 11 | ;; it under the terms of the GNU General Public License as published by |
| 12 | ;; the Free Software Foundation, either version 3 of the License, or |
| 13 | ;; (at your option) any later version. |
| 14 | |
| 15 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 18 | ;; GNU General Public License for more details. |
| 19 | |
| 20 | ;; You should have received a copy of the GNU General Public License |
| 21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
| 22 | |
| 23 | ;;; Commentary: |
| 24 | ;; |
| 25 | ;; Compile a Semantic Recoder template file. |
| 26 | ;; |
| 27 | ;; Template files are parsed using a Semantic/Wisent parser into |
| 28 | ;; a tag table. The code therein is then further parsed down using |
| 29 | ;; a regular expression parser. |
| 30 | ;; |
| 31 | ;; The output are a series of EIEIO objects which represent the |
| 32 | ;; templates in a way that could be inserted later. |
| 33 | |
| 34 | (eval-when-compile (require 'cl)) |
| 35 | (require 'semantic) |
| 36 | (require 'eieio) |
| 37 | (require 'eieio-base) |
| 38 | (require 'srecode/table) |
| 39 | (require 'srecode/dictionary) |
| 40 | |
| 41 | (declare-function srecode-template-inserter-newline-child-p "srecode/insert" |
| 42 | t t) |
| 43 | |
| 44 | ;;; Code: |
| 45 | |
| 46 | ;;; Template Class |
| 47 | ;; |
| 48 | ;; Templates describe a pattern of text that can be inserted into a |
| 49 | ;; buffer. |
| 50 | ;; |
| 51 | (defclass srecode-template (eieio-named) |
| 52 | ((context :initarg :context |
| 53 | :initform nil |
| 54 | :documentation |
| 55 | "Context this template belongs to.") |
| 56 | (args :initarg :args |
| 57 | :documentation |
| 58 | "List of arguments that this template requires.") |
| 59 | (code :initarg :code |
| 60 | :documentation |
| 61 | "Compiled text from the template.") |
| 62 | (dictionary :initarg :dictionary |
| 63 | :type (or null srecode-dictionary) |
| 64 | :documentation |
| 65 | "List of section dictionaries. |
| 66 | The compiled template can contain lists of section dictionaries, |
| 67 | or values that are expected to be passed down into different |
| 68 | section macros. The template section dictionaries are merged in with |
| 69 | any incoming dictionaries values.") |
| 70 | (binding :initarg :binding |
| 71 | :documentation |
| 72 | "Preferred keybinding for this template in `srecode-minor-mode-map'.") |
| 73 | (active :allocation :class |
| 74 | :initform nil |
| 75 | :documentation |
| 76 | "During template insertion, this is the stack of active templates. |
| 77 | The top-most template is the 'active' template. Use the accessor methods |
| 78 | for push, pop, and peek for the active template.") |
| 79 | (table :initarg :table |
| 80 | :documentation |
| 81 | "The table this template lives in.") |
| 82 | ) |
| 83 | "Class defines storage for semantic recoder templates.") |
| 84 | |
| 85 | (defun srecode-flush-active-templates () |
| 86 | "Flush the active template storage. |
| 87 | Useful if something goes wrong in SRecode, and the active template |
| 88 | stack is broken." |
| 89 | (interactive) |
| 90 | (if (oref srecode-template active) |
| 91 | (when (y-or-n-p (format "%d active templates. Flush? " |
| 92 | (length (oref srecode-template active)))) |
| 93 | (oset-default srecode-template active nil)) |
| 94 | (message "No active templates to flush.")) |
| 95 | ) |
| 96 | |
| 97 | ;;; Inserters |
| 98 | ;; |
| 99 | ;; Each inserter object manages a different thing that |
| 100 | ;; might be inserted into a template output stream. |
| 101 | ;; |
| 102 | ;; The 'srecode-insert-method' on each inserter does the actual |
| 103 | ;; work, and the smaller, simple inserter object is saved in |
| 104 | ;; the compiled templates. |
| 105 | ;; |
| 106 | ;; See srecode/insert.el for the specialized classes. |
| 107 | ;; |
| 108 | (defclass srecode-template-inserter (eieio-named) |
| 109 | ((secondname :initarg :secondname |
| 110 | :type (or null string) |
| 111 | :documentation |
| 112 | "If there is a colon in the inserter's name, it represents |
| 113 | additional static argument data.")) |
| 114 | "This represents an item to be inserted via a template macro. |
| 115 | Plain text strings are not handled via this baseclass." |
| 116 | :abstract t) |
| 117 | |
| 118 | (defmethod srecode-parse-input ((ins srecode-template-inserter) |
| 119 | tag input STATE) |
| 120 | "For the template inserter INS, parse INPUT. |
| 121 | Shorten input only by the amount needed. |
| 122 | Return the remains of INPUT. |
| 123 | STATE is the current compilation state." |
| 124 | input) |
| 125 | |
| 126 | (defmethod srecode-match-end ((ins srecode-template-inserter) name) |
| 127 | "For the template inserter INS, do I end a section called NAME?" |
| 128 | nil) |
| 129 | |
| 130 | (defmethod srecode-inserter-apply-state ((ins srecode-template-inserter) STATE) |
| 131 | "For the template inserter INS, apply information from STATE." |
| 132 | nil) |
| 133 | |
| 134 | (defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter) |
| 135 | escape-start escape-end) |
| 136 | "Insert an example using inserter INS. |
| 137 | Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use." |
| 138 | (princ " ") |
| 139 | (princ escape-start) |
| 140 | (when (and (slot-exists-p ins 'key) (oref ins key)) |
| 141 | (princ (format "%c" (oref ins key)))) |
| 142 | (princ "VARNAME") |
| 143 | (princ escape-end) |
| 144 | (terpri) |
| 145 | ) |
| 146 | |
| 147 | |
| 148 | ;;; Compile State |
| 149 | (defclass srecode-compile-state () |
| 150 | ((context :initform "declaration" |
| 151 | :documentation "The active context.") |
| 152 | (prompts :initform nil |
| 153 | :documentation "The active prompts.") |
| 154 | (escape_start :initform "{{" |
| 155 | :documentation "The starting escape sequence.") |
| 156 | (escape_end :initform "}}" |
| 157 | :documentation "The ending escape sequence.") |
| 158 | ) |
| 159 | "Current state of the compile.") |
| 160 | |
| 161 | (defmethod srecode-compile-add-prompt ((state srecode-compile-state) |
| 162 | prompttag) |
| 163 | "Add PROMPTTAG to the current list of prompts." |
| 164 | (with-slots (prompts) state |
| 165 | (let ((match (assoc (semantic-tag-name prompttag) prompts)) |
| 166 | (newprompts prompts)) |
| 167 | (when match |
| 168 | (let ((tmp prompts)) |
| 169 | (setq newprompts nil) |
| 170 | (while tmp |
| 171 | (when (not (string= (car (car tmp)) |
| 172 | (car prompttag))) |
| 173 | (setq newprompts (cons (car tmp) |
| 174 | newprompts))) |
| 175 | (setq tmp (cdr tmp))))) |
| 176 | (setq prompts (cons prompttag newprompts))) |
| 177 | )) |
| 178 | |
| 179 | ;;; TEMPLATE COMPILER |
| 180 | ;; |
| 181 | (defun srecode-compile-file (fname) |
| 182 | "Compile the templates from the file FNAME." |
| 183 | (let ((peb (get-file-buffer fname))) |
| 184 | (save-excursion |
| 185 | ;; Make whatever it is local. |
| 186 | (if (not peb) |
| 187 | (set-buffer (semantic-find-file-noselect fname)) |
| 188 | (set-buffer peb)) |
| 189 | ;; Do the compile. |
| 190 | (unless (semantic-active-p) |
| 191 | (semantic-new-buffer-fcn)) |
| 192 | (srecode-compile-templates) |
| 193 | ;; Trash the buffer if we had to read it in. |
| 194 | (if (not peb) |
| 195 | (kill-buffer (current-buffer))) |
| 196 | ))) |
| 197 | |
| 198 | ;;;###autoload |
| 199 | (defun srecode-compile-templates () |
| 200 | "Compile a semantic recode template file into a mode-local variable." |
| 201 | (interactive) |
| 202 | (require 'srecode/insert) |
| 203 | (message "Compiling template %s..." |
| 204 | (file-name-nondirectory (buffer-file-name))) |
| 205 | (let ((tags (semantic-fetch-tags)) |
| 206 | (tag nil) |
| 207 | (class nil) |
| 208 | (table nil) |
| 209 | (STATE (srecode-compile-state (file-name-nondirectory |
| 210 | (buffer-file-name)))) |
| 211 | (mode nil) |
| 212 | (application nil) |
| 213 | (framework nil) |
| 214 | (priority nil) |
| 215 | (project nil) |
| 216 | (vars nil) |
| 217 | ) |
| 218 | |
| 219 | ;; |
| 220 | ;; COMPILE |
| 221 | ;; |
| 222 | (while tags |
| 223 | (setq tag (car tags) |
| 224 | class (semantic-tag-class tag)) |
| 225 | ;; What type of item is it? |
| 226 | (cond |
| 227 | ;; CONTEXT tags specify the context all future tags |
| 228 | ;; belong to. |
| 229 | ((eq class 'context) |
| 230 | (oset STATE context (semantic-tag-name tag)) |
| 231 | ) |
| 232 | |
| 233 | ;; PROMPT tags specify prompts for dictionary ? inserters |
| 234 | ;; which appear in the following templates |
| 235 | ((eq class 'prompt) |
| 236 | (srecode-compile-add-prompt STATE tag) |
| 237 | ) |
| 238 | |
| 239 | ;; VARIABLE tags can specify operational control |
| 240 | ((eq class 'variable) |
| 241 | (let* ((name (semantic-tag-name tag)) |
| 242 | (value (semantic-tag-variable-default tag)) |
| 243 | (firstvalue (car value))) |
| 244 | ;; If it is a single string, and one value, then |
| 245 | ;; look to see if it is one of our special variables. |
| 246 | (if (and (= (length value) 1) (stringp firstvalue)) |
| 247 | (cond ((string= name "mode") |
| 248 | (setq mode (intern firstvalue))) |
| 249 | ((string= name "escape_start") |
| 250 | (oset STATE escape_start firstvalue) |
| 251 | ) |
| 252 | ((string= name "escape_end") |
| 253 | (oset STATE escape_end firstvalue) |
| 254 | ) |
| 255 | ((string= name "application") |
| 256 | (setq application (read firstvalue))) |
| 257 | ((string= name "framework") |
| 258 | (setq framework (read firstvalue))) |
| 259 | ((string= name "priority") |
| 260 | (setq priority (read firstvalue))) |
| 261 | ((string= name "project") |
| 262 | (setq project firstvalue)) |
| 263 | (t |
| 264 | ;; Assign this into some table of variables. |
| 265 | (setq vars (cons (cons name firstvalue) vars)) |
| 266 | )) |
| 267 | ;; If it isn't a single string, then the value of the |
| 268 | ;; variable belongs to a compound dictionary value. |
| 269 | ;; |
| 270 | ;; Create a compound dictionary value from "value". |
| 271 | (require 'srecode/dictionary) |
| 272 | (let ((cv (srecode-dictionary-compound-variable |
| 273 | name :value value))) |
| 274 | (setq vars (cons (cons name cv) vars))) |
| 275 | )) |
| 276 | ) |
| 277 | |
| 278 | ;; FUNCTION tags are really templates. |
| 279 | ((eq class 'function) |
| 280 | (setq table (cons (srecode-compile-one-template-tag tag STATE) |
| 281 | table)) |
| 282 | ) |
| 283 | |
| 284 | ;; Ooops |
| 285 | (t (error "Unknown TAG class %s" class)) |
| 286 | ) |
| 287 | ;; Continue |
| 288 | (setq tags (cdr tags))) |
| 289 | |
| 290 | ;; MSG - Before install since nreverse whacks our list. |
| 291 | (message "%d templates compiled for %s" |
| 292 | (length table) mode) |
| 293 | |
| 294 | ;; |
| 295 | ;; APPLY TO MODE |
| 296 | ;; |
| 297 | (if (not mode) |
| 298 | (error "You must specify a MODE for your templates")) |
| 299 | |
| 300 | ;; |
| 301 | ;; Calculate priority |
| 302 | ;; |
| 303 | (if (not priority) |
| 304 | (let ((d (expand-file-name (file-name-directory (buffer-file-name)))) |
| 305 | (sd (expand-file-name (file-name-directory (locate-library "srecode")))) |
| 306 | (defaultdelta (if (eq mode 'default) 0 10))) |
| 307 | ;; @TODO : WHEN INTEGRATING INTO EMACS |
| 308 | ;; The location of Emacs default templates needs to be specified |
| 309 | ;; here to also have a lower priority. |
| 310 | (if (string-match (concat "^" sd) d) |
| 311 | (setq priority (+ 30 defaultdelta)) |
| 312 | ;; If the user created template is for a project, then |
| 313 | ;; don't add as much as if it is unique to just some user. |
| 314 | (if (stringp project) |
| 315 | (setq priority (+ 50 defaultdelta)) |
| 316 | (setq priority (+ 80 defaultdelta)))) |
| 317 | (message "Templates %s has estimated priority of %d" |
| 318 | (file-name-nondirectory (buffer-file-name)) |
| 319 | priority)) |
| 320 | (message "Compiling templates %s priority %d... done!" |
| 321 | (file-name-nondirectory (buffer-file-name)) |
| 322 | priority)) |
| 323 | |
| 324 | ;; Save it up! |
| 325 | (srecode-compile-template-table table mode priority application framework project vars) |
| 326 | ) |
| 327 | ) |
| 328 | |
| 329 | (defun srecode-compile-one-template-tag (tag state) |
| 330 | "Compile a template tag TAG into a srecode template object. |
| 331 | STATE is the current compile state as an object of class |
| 332 | `srecode-compile-state'." |
| 333 | (let* ((context (oref state context)) |
| 334 | (code (cdr (srecode-compile-split-code |
| 335 | tag (semantic-tag-get-attribute tag :code) |
| 336 | state))) |
| 337 | (args (semantic-tag-function-arguments tag)) |
| 338 | (binding (semantic-tag-get-attribute tag :binding)) |
| 339 | (dict-tags (semantic-tag-get-attribute tag :dictionaries)) |
| 340 | (root-dict (when dict-tags |
| 341 | (srecode-create-dictionaries-from-tags |
| 342 | dict-tags state))) |
| 343 | (addargs)) |
| 344 | ;; Examine arguments. |
| 345 | (dolist (arg args) |
| 346 | (let ((symbol (intern arg))) |
| 347 | (push symbol addargs) |
| 348 | |
| 349 | ;; If we have a wrap, then put wrap inserters on both ends of |
| 350 | ;; the code. |
| 351 | (when (eq symbol :blank) |
| 352 | (setq code (append |
| 353 | (list (srecode-compile-inserter |
| 354 | "BLANK" |
| 355 | "\r" |
| 356 | state |
| 357 | :secondname nil |
| 358 | :where 'begin)) |
| 359 | code |
| 360 | (list (srecode-compile-inserter |
| 361 | "BLANK" |
| 362 | "\r" |
| 363 | state |
| 364 | :secondname nil |
| 365 | :where 'end))))))) |
| 366 | |
| 367 | ;; Construct and return the template object. |
| 368 | (srecode-template (semantic-tag-name tag) |
| 369 | :context context |
| 370 | :args (nreverse addargs) |
| 371 | :dictionary root-dict |
| 372 | :binding binding |
| 373 | :code code)) |
| 374 | ) |
| 375 | |
| 376 | (defun srecode-compile-do-hard-newline-p (comp) |
| 377 | "Examine COMP to decide if the upcoming newline should be hard. |
| 378 | It is hard if the previous inserter is a newline object." |
| 379 | (while (and comp (stringp (car comp))) |
| 380 | (setq comp (cdr comp))) |
| 381 | (or (not comp) |
| 382 | (progn (require 'srecode/insert) |
| 383 | (srecode-template-inserter-newline-child-p (car comp))))) |
| 384 | |
| 385 | (defun srecode-compile-split-code (tag str STATE |
| 386 | &optional end-name) |
| 387 | "Split the code for TAG into something templatable. |
| 388 | STR is the string of code from TAG to split. |
| 389 | STATE is the current compile state. |
| 390 | ESCAPE_START and ESCAPE_END are regexps that indicate the beginning |
| 391 | escape character, and end escape character pattern for expandable |
| 392 | macro names. |
| 393 | Optional argument END-NAME specifies the name of a token upon which |
| 394 | parsing should stop. |
| 395 | If END-NAME is specified, and the input string" |
| 396 | (let* ((what str) |
| 397 | (end-token nil) |
| 398 | (comp nil) |
| 399 | (regex (concat "\n\\|" (regexp-quote (oref STATE escape_start)))) |
| 400 | (regexend (regexp-quote (oref STATE escape_end))) |
| 401 | ) |
| 402 | (while (and what (not end-token)) |
| 403 | (cond |
| 404 | ((string-match regex what) |
| 405 | (let* ((prefix (substring what 0 (match-beginning 0))) |
| 406 | (match (substring what |
| 407 | (match-beginning 0) |
| 408 | (match-end 0))) |
| 409 | (namestart (match-end 0)) |
| 410 | (junk (string-match regexend what namestart)) |
| 411 | end tail name key) |
| 412 | ;; Add string to compiled output |
| 413 | (when (> (length prefix) 0) |
| 414 | (setq comp (cons prefix comp))) |
| 415 | (if (string= match "\n") |
| 416 | ;; Do newline thingy. |
| 417 | (let ((new-inserter |
| 418 | (srecode-compile-inserter |
| 419 | "INDENT" |
| 420 | "\n" |
| 421 | STATE |
| 422 | :secondname nil |
| 423 | ;; This newline is "hard" meaning ALWAYS do it |
| 424 | ;; if the previous entry is also a newline. |
| 425 | ;; Without it, user entered blank lines will be |
| 426 | ;; ignored. |
| 427 | :hard (srecode-compile-do-hard-newline-p comp) |
| 428 | ))) |
| 429 | ;; Trim WHAT back. |
| 430 | (setq what (substring what namestart)) |
| 431 | (when (> (length what) 0) |
| 432 | ;; make the new inserter, but only if we aren't last. |
| 433 | (setq comp (cons new-inserter comp)) |
| 434 | )) |
| 435 | ;; Regular inserter thingy. |
| 436 | (setq end (if junk |
| 437 | (match-beginning 0) |
| 438 | (error "Could not find end escape for %s" |
| 439 | (semantic-tag-name tag))) |
| 440 | tail (match-end 0)) |
| 441 | (cond ((not end) |
| 442 | (error "No matching escape end for %s" |
| 443 | (semantic-tag-name tag))) |
| 444 | ((<= end namestart) |
| 445 | (error "Stray end escape for %s" |
| 446 | (semantic-tag-name tag))) |
| 447 | ) |
| 448 | ;; Add string to compiled output |
| 449 | (setq name (substring what namestart end) |
| 450 | key nil) |
| 451 | ;; Trim WHAT back. |
| 452 | (setq what (substring what tail)) |
| 453 | ;; Get the inserter |
| 454 | (let ((new-inserter |
| 455 | (srecode-compile-parse-inserter name STATE)) |
| 456 | ) |
| 457 | ;; If this is an end inserter, then assign into |
| 458 | ;; the end-token. |
| 459 | (if (srecode-match-end new-inserter end-name) |
| 460 | (setq end-token new-inserter)) |
| 461 | ;; Add the inserter to our compilation stream. |
| 462 | (setq comp (cons new-inserter comp)) |
| 463 | ;; Allow the inserter an opportunity to modify |
| 464 | ;; the input stream. |
| 465 | (setq what (srecode-parse-input new-inserter tag what |
| 466 | STATE)) |
| 467 | ) |
| 468 | ))) |
| 469 | (t |
| 470 | (if end-name |
| 471 | (error "Unmatched section end %s" end-name)) |
| 472 | (setq comp (cons what comp) |
| 473 | what nil)))) |
| 474 | (cons what (nreverse comp)))) |
| 475 | |
| 476 | (defun srecode-compile-parse-inserter (txt STATE) |
| 477 | "Parse the inserter TXT with the current STATE. |
| 478 | Return an inserter object." |
| 479 | (let ((key (aref txt 0)) |
| 480 | name |
| 481 | ) |
| 482 | (if (and (or (< key ?A) (> key ?Z)) |
| 483 | (or (< key ?a) (> key ?z)) ) |
| 484 | (setq name (substring txt 1)) |
| 485 | (setq name txt |
| 486 | key nil)) |
| 487 | (let* ((junk (string-match ":" name)) |
| 488 | (namepart (if junk |
| 489 | (substring name 0 (match-beginning 0)) |
| 490 | name)) |
| 491 | (secondname (if junk |
| 492 | (substring name (match-end 0)) |
| 493 | nil)) |
| 494 | (new-inserter (srecode-compile-inserter |
| 495 | namepart key STATE |
| 496 | :secondname secondname |
| 497 | ))) |
| 498 | ;; Return the new inserter |
| 499 | new-inserter))) |
| 500 | |
| 501 | (defun srecode-compile-inserter (name key STATE &rest props) |
| 502 | "Create an srecode inserter object for some macro NAME. |
| 503 | KEY indicates a single character key representing a type |
| 504 | of inserter to create. |
| 505 | STATE is the current compile state. |
| 506 | PROPS are additional properties that might need to be passed |
| 507 | to the inserter constructor." |
| 508 | ;;(message "Compile: %s %S" name props) |
| 509 | (if (not key) |
| 510 | (apply 'srecode-template-inserter-variable name props) |
| 511 | (let ((classes (class-children srecode-template-inserter)) |
| 512 | (new nil)) |
| 513 | ;; Loop over the various subclasses and |
| 514 | ;; create the correct inserter. |
| 515 | (while (and (not new) classes) |
| 516 | (setq classes (append classes (class-children (car classes)))) |
| 517 | ;; Do we have a match? |
| 518 | (when (and (not (class-abstract-p (car classes))) |
| 519 | (equal (oref (car classes) key) key)) |
| 520 | ;; Create the new class, and apply state. |
| 521 | (setq new (apply (car classes) name props)) |
| 522 | (srecode-inserter-apply-state new STATE) |
| 523 | ) |
| 524 | (setq classes (cdr classes))) |
| 525 | (if (not new) (error "SRECODE: Unknown macro code %S" key)) |
| 526 | new))) |
| 527 | |
| 528 | (defun srecode-compile-template-table (templates mode priority application framework project vars) |
| 529 | "Compile a list of TEMPLATES into an semantic recode table. |
| 530 | The table being compiled is for MODE, or the string \"default\". |
| 531 | PRIORITY is a numerical value that indicates this tables location |
| 532 | in an ordered search. |
| 533 | APPLICATION is the name of the application these templates belong to. |
| 534 | FRAMEWORK is the name of the framework these templates belong to. |
| 535 | PROJECT is a directory name which these templates scope to. |
| 536 | A list of defined variables VARS provides a variable table." |
| 537 | (let ((namehash (make-hash-table :test 'equal |
| 538 | :size (length templates))) |
| 539 | (contexthash (make-hash-table :test 'equal :size 10)) |
| 540 | (lp templates) |
| 541 | ) |
| 542 | |
| 543 | (while lp |
| 544 | |
| 545 | (let* ((objname (oref (car lp) :object-name)) |
| 546 | (context (oref (car lp) :context)) |
| 547 | (globalname (concat context ":" objname)) |
| 548 | ) |
| 549 | |
| 550 | ;; Place this template object into the global name hash. |
| 551 | (puthash globalname (car lp) namehash) |
| 552 | |
| 553 | ;; Place this template into the specific context name hash. |
| 554 | (let ((hs (gethash context contexthash))) |
| 555 | ;; Make a new context if none was available. |
| 556 | (when (not hs) |
| 557 | (setq hs (make-hash-table :test 'equal :size 20)) |
| 558 | (puthash context hs contexthash)) |
| 559 | ;; Put into that context's hash. |
| 560 | (puthash objname (car lp) hs) |
| 561 | ) |
| 562 | |
| 563 | (setq lp (cdr lp)))) |
| 564 | |
| 565 | (when (stringp project) |
| 566 | (setq project (expand-file-name project))) |
| 567 | |
| 568 | (let* ((table (srecode-mode-table-new mode (buffer-file-name) |
| 569 | :templates (nreverse templates) |
| 570 | :namehash namehash |
| 571 | :contexthash contexthash |
| 572 | :variables vars |
| 573 | :major-mode mode |
| 574 | :priority priority |
| 575 | :application application |
| 576 | :framework framework |
| 577 | :project project)) |
| 578 | (tmpl (oref table templates))) |
| 579 | ;; Loop over all the templates, and xref. |
| 580 | (while tmpl |
| 581 | (oset (car tmpl) :table table) |
| 582 | (setq tmpl (cdr tmpl)))) |
| 583 | )) |
| 584 | |
| 585 | |
| 586 | |
| 587 | ;;; DEBUG |
| 588 | ;; |
| 589 | ;; Dump out information about the current srecoder compiled templates. |
| 590 | ;; |
| 591 | |
| 592 | (defmethod srecode-dump ((tmp srecode-template)) |
| 593 | "Dump the contents of the SRecode template tmp." |
| 594 | (princ "== Template \"") |
| 595 | (princ (object-name-string tmp)) |
| 596 | (princ "\" in context ") |
| 597 | (princ (oref tmp context)) |
| 598 | (princ "\n") |
| 599 | (when (oref tmp args) |
| 600 | (princ " Arguments: ") |
| 601 | (prin1 (oref tmp args)) |
| 602 | (princ "\n")) |
| 603 | (when (oref tmp dictionary) |
| 604 | (princ " Section Dictionaries:\n") |
| 605 | (srecode-dump (oref tmp dictionary) 4) |
| 606 | ;(princ "\n") |
| 607 | ) |
| 608 | (when (and (slot-boundp tmp 'binding) (oref tmp binding)) |
| 609 | (princ " Binding: ") |
| 610 | (prin1 (oref tmp binding)) |
| 611 | (princ "\n")) |
| 612 | (princ " Compiled Codes:\n") |
| 613 | (srecode-dump-code-list (oref tmp code) " ") |
| 614 | (princ "\n\n") |
| 615 | ) |
| 616 | |
| 617 | (defun srecode-dump-code-list (code indent) |
| 618 | "Dump the CODE from a template code list to standard output. |
| 619 | Argument INDENT specifies the indentation level for the list." |
| 620 | (let ((i 1)) |
| 621 | (while code |
| 622 | (princ indent) |
| 623 | (prin1 i) |
| 624 | (princ ") ") |
| 625 | (cond ((stringp (car code)) |
| 626 | (prin1 (car code))) |
| 627 | ((srecode-template-inserter-child-p (car code)) |
| 628 | (srecode-dump (car code) indent)) |
| 629 | (t |
| 630 | (princ "Unknown Code: ") |
| 631 | (prin1 (car code)))) |
| 632 | (setq code (cdr code) |
| 633 | i (1+ i)) |
| 634 | (when code |
| 635 | (princ "\n")))) |
| 636 | ) |
| 637 | |
| 638 | (defmethod srecode-dump ((ins srecode-template-inserter) indent) |
| 639 | "Dump the state of the SRecode template inserter INS." |
| 640 | (princ "INS: \"") |
| 641 | (princ (object-name-string ins)) |
| 642 | (when (oref ins :secondname) |
| 643 | (princ "\" : \"") |
| 644 | (princ (oref ins :secondname))) |
| 645 | (princ "\" type \"") |
| 646 | (let* ((oc (symbol-name (object-class ins))) |
| 647 | (junk (string-match "srecode-template-inserter-" oc)) |
| 648 | (on (if junk |
| 649 | (substring oc (match-end 0)) |
| 650 | oc))) |
| 651 | (princ on)) |
| 652 | (princ "\"") |
| 653 | ) |
| 654 | |
| 655 | (provide 'srecode/compile) |
| 656 | |
| 657 | ;; Local variables: |
| 658 | ;; generated-autoload-file: "loaddefs.el" |
| 659 | ;; generated-autoload-load-name: "srecode/compile" |
| 660 | ;; End: |
| 661 | |
| 662 | ;;; srecode/compile.el ends here |