Commit | Line | Data |
---|---|---|
4d902e6f CY |
1 | ;;; srecode/compile --- Compilation of srecode template files. |
2 | ||
acaf905b | 3 | ;; Copyright (C) 2005, 2007-2012 Free Software Foundation, Inc. |
4d902e6f CY |
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 | |
2f10955c | 28 | ;; a tag table. The code therein is then further parsed down using |
4d902e6f CY |
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 | ||
67d3ffe4 | 34 | (eval-when-compile (require 'cl)) |
4d902e6f CY |
35 | (require 'semantic) |
36 | (require 'eieio) | |
37 | (require 'eieio-base) | |
4d902e6f | 38 | (require 'srecode/table) |
b9749554 | 39 | (require 'srecode/dictionary) |
4d902e6f | 40 | |
84c23041 GM |
41 | (declare-function srecode-template-inserter-newline-child-p "srecode/insert" |
42 | t t) | |
4d902e6f CY |
43 | |
44 | ;;; Code: | |
45 | ||
46 | ;;; Template Class | |
47 | ;; | |
b9749554 | 48 | ;; Templates describe a pattern of text that can be inserted into a |
4d902e6f CY |
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 | |
4c36be58 | 65 | "List of section dictionaries. |
4d902e6f CY |
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 | |
da6062e6 | 69 | any incoming dictionaries values.") |
4d902e6f CY |
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. | |
2f10955c | 87 | Useful if something goes wrong in SRecode, and the active template |
4d902e6f CY |
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 | ;; | |
07a79ce4 | 106 | ;; See srecode/insert.el for the specialized classes. |
4d902e6f CY |
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. | |
82481502 CY |
190 | (unless (semantic-active-p) |
191 | (semantic-new-buffer-fcn)) | |
4d902e6f CY |
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) | |
b82525f2 | 202 | (require 'srecode/insert) |
4d902e6f CY |
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) | |
62a81506 | 213 | (framework nil) |
4d902e6f | 214 | (priority nil) |
b9749554 | 215 | (project nil) |
4d902e6f CY |
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))) | |
62a81506 CY |
257 | ((string= name "framework") |
258 | (setq framework (read firstvalue))) | |
4d902e6f CY |
259 | ((string= name "priority") |
260 | (setq priority (read firstvalue))) | |
b9749554 EL |
261 | ((string= name "project") |
262 | (setq project firstvalue)) | |
4d902e6f CY |
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) | |
b9749554 EL |
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)))) | |
4d902e6f CY |
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! | |
62a81506 | 325 | (srecode-compile-template-table table mode priority application framework project vars) |
4d902e6f CY |
326 | ) |
327 | ) | |
328 | ||
b9749554 EL |
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. | |
4d902e6f | 368 | (srecode-template (semantic-tag-name tag) |
b9749554 EL |
369 | :context context |
370 | :args (nreverse addargs) | |
371 | :dictionary root-dict | |
372 | :binding binding | |
373 | :code code)) | |
374 | ) | |
4d902e6f CY |
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) | |
62a81506 CY |
382 | (progn (require 'srecode/insert) |
383 | (srecode-template-inserter-newline-child-p (car comp))))) | |
4d902e6f CY |
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)) | |
6564b177 | 411 | end tail name key) |
4d902e6f CY |
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)) | |
6564b177 | 480 | name |
4d902e6f CY |
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 | ||
62a81506 | 528 | (defun srecode-compile-template-table (templates mode priority application framework project vars) |
4d902e6f CY |
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. | |
62a81506 | 534 | FRAMEWORK is the name of the framework these templates belong to. |
b9749554 | 535 | PROJECT is a directory name which these templates scope to. |
4d902e6f CY |
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)) | |
da6062e6 | 559 | ;; Put into that context's hash. |
4d902e6f CY |
560 | (puthash objname (car lp) hs) |
561 | ) | |
562 | ||
563 | (setq lp (cdr lp)))) | |
564 | ||
b9749554 EL |
565 | (when (stringp project) |
566 | (setq project (expand-file-name project))) | |
567 | ||
4d902e6f CY |
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 | |
b9749554 | 575 | :application application |
62a81506 | 576 | :framework framework |
b9749554 | 577 | :project project)) |
4d902e6f CY |
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" | |
4d902e6f CY |
659 | ;; generated-autoload-load-name: "srecode/compile" |
660 | ;; End: | |
661 | ||
662 | ;;; srecode/compile.el ends here |