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