lisp/cedet/srecode/compile.el

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