cgit.sxemacs.org Git - packages/blob - xemacs-packages/semantic/semantic-grammar.el

   1 ;;; semantic-grammar.el --- Major mode framework for Semantic grammars
   2 ;;
   3 ;; Copyright (C) 2002, 2003, 2004, 2005, 2007 David Ponce
   4 ;;
   5 ;; Author: David Ponce <david@dponce.com>
   6 ;; Maintainer: David Ponce <david@dponce.com>
   7 ;; Created: 15 Aug 2002
   8 ;; Keywords: syntax
   9 ;; X-RCS: $Id: semantic-grammar.el,v 1.1 2007-11-26 15:10:37 michaels Exp $
  10 ;;
  11 ;; This file is not part of GNU Emacs.
  12 ;;
  13 ;; This program is free software; you can redistribute it and/or
  14 ;; modify it under the terms of the GNU General Public License as
  15 ;; published by the Free Software Foundation; either version 2, or (at
  16 ;; your option) any later version.
  17 ;;
  18 ;; This software is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 ;; General Public License for more details.
  22 ;;
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  26 ;; Boston, MA 02110-1301, USA.
  27
  28 ;;; Commentary:
  29 ;;
  30 ;; Major mode framework for editing Semantic's input grammar files.
  31
  32 ;;; History:
  33 ;;
  34
  35 ;;; Code:
  36 (require 'semantic-wisent)
  37 (require 'sformat)
  38 (require 'font-lock)
  39 (require 'pp)
  40
  41 (eval-when-compile
  42   (require 'senator)
  43   (require 'semantic-edit)
  44   (require 'semantic-find)
  45   (require 'semantic-format)
  46   (require 'semantic-idle))
  47 \f
  48 ;;;;
  49 ;;;; Set up lexer
  50 ;;;;
  51
  52 (defconst semantic-grammar-lex-c-char-re "'\\s\\?.'"
  53   "Regexp matching C-like character literals.")
  54
  55 ;; Most of the analyzers are auto-generated from the grammar, but the
  56 ;; following which need special handling code.
  57 ;;
  58 (define-lex-regex-analyzer semantic-grammar-lex-prologue
  59   "Detect and create a prologue token."
  60   "\\<%{"
  61   ;; Zing to the end of this brace block.
  62   (semantic-lex-push-token
  63    (semantic-lex-token
  64     'PROLOGUE (point)
  65     (save-excursion
  66       (semantic-lex-unterminated-syntax-protection 'PROLOGUE
  67         (forward-char)
  68         (forward-sexp 1)
  69         (point))))))
  70
  71 (defsubst semantic-grammar-epilogue-start ()
  72   "Return the start position of the grammar epilogue."
  73   (save-excursion
  74     (goto-char (point-min))
  75     (if (re-search-forward "^\\s-*\\<%%\\>\\s-*$" nil t 2)
  76         (match-beginning 0)
  77       (1+ (point-max)))))
  78
  79 (define-lex-regex-analyzer semantic-grammar-lex-epilogue
  80   "Detect and create an epilogue or percent-percent token."
  81   "\\<%%\\>"
  82   (let ((start (match-beginning 0))
  83         (end   (match-end 0))
  84         (class 'PERCENT_PERCENT))
  85     (when (>= start (semantic-grammar-epilogue-start))
  86       (setq class 'EPILOGUE
  87             end   (point-max)))
  88     (semantic-lex-push-token
  89      (semantic-lex-token class start end))))
  90
  91 ;; Provide auto-generated analyzers and the lexer.
  92 (require 'semantic-grammar-wy)
  93
  94 ;;; Test the lexer
  95 ;;
  96 (defun semantic-grammar-lex-buffer ()
  97   "Run `semantic-grammar-lex' on current buffer."
  98   (interactive)
  99   (semantic-lex-init)
 100   (setq semantic-lex-analyzer 'semantic-grammar-lexer)
 101   (let ((token-stream
 102          (semantic-lex (point-min) (point-max))))
 103     (with-current-buffer (get-buffer-create "*semantic-grammar-lex*")
 104       (erase-buffer)
 105       (pp token-stream (current-buffer))
 106       (goto-char (point-min))
 107       (pop-to-buffer (current-buffer)))))
 108 \f
 109 ;;;;
 110 ;;;; Semantic action expansion
 111 ;;;;
 112
 113 (defun semantic-grammar-ASSOC (&rest args)
 114   "Return expansion of built-in ASSOC expression.
 115 ARGS are ASSOC's key value list."
 116   (let ((key t))
 117     `(semantic-tag-make-assoc-list
 118       ,@(mapcar #'(lambda (i)
 119                     (prog1
 120                         (if key
 121                             (list 'quote i)
 122                           i)
 123                       (setq key (not key))))
 124                 args))))
 125
 126 (defsubst semantic-grammar-quote-p (sym)
 127   "Return non-nil if SYM is bound to the `quote' function."
 128   (condition-case nil
 129       (eq (indirect-function sym)
 130           (indirect-function 'quote))
 131     (error nil)))
 132
 133 (defsubst semantic-grammar-backquote-p (sym)
 134   "Return non-nil if SYM is bound to the `backquote' function."
 135   (condition-case nil
 136       (eq (indirect-function sym)
 137           (indirect-function 'backquote))
 138     (error nil)))
 139 \f
 140 ;;;;
 141 ;;;; API to access grammar tags
 142 ;;;;
 143
 144 (defvar-mode-local semantic-grammar-mode
 145   senator-add-log-tags '(nonterminal put token keyword)
 146   "List of nonterminal tags used with add-log.")
 147
 148 (define-mode-local-override semantic-tag-components
 149   semantic-grammar-mode (tag)
 150   "Return the children of tag TAG."
 151   (semantic-tag-get-attribute tag :children))
 152
 153 (defun semantic-grammar-first-tag-name (class)
 154   "Return the name of the first tag of class CLASS found.
 155 Warn if other tags of class CLASS exist."
 156   (let* ((tags (semantic-find-tags-by-class
 157                 class (current-buffer))))
 158     (if tags
 159         (prog1
 160             (semantic-tag-name (car tags))
 161           (if (cdr tags)
 162               (message "*** Ignore all but first declared %s"
 163                        class))))))
 164
 165 (defun semantic-grammar-tag-symbols (class)
 166   "Return the list of symbols defined in tags of class CLASS.
 167 That is tag names plus names defined in tag attribute `:rest'."
 168   (let* ((tags (semantic-find-tags-by-class
 169                 class (current-buffer))))
 170     (apply 'append
 171            (mapcar
 172             #'(lambda (tag)
 173                 (mapcar
 174                  'intern
 175                  (cons (semantic-tag-name tag)
 176                        (semantic-tag-get-attribute tag :rest))))
 177             tags))))
 178
 179 (defsubst semantic-grammar-item-text (item)
 180   "Return the readable string form of ITEM."
 181   (if (string-match semantic-grammar-lex-c-char-re item)
 182       (concat "?" (substring item 1 -1))
 183     item))
 184
 185 (defsubst semantic-grammar-item-value (item)
 186   "Return symbol or character value of ITEM string."
 187   (if (string-match semantic-grammar-lex-c-char-re item)
 188       (let ((c (read (concat "?" (substring item 1 -1)))))
 189         (if (featurep 'xemacs)
 190             ;; Handle characters as integers in XEmacs like in GNU Emacs.
 191             (char-int c)
 192           c))
 193     (intern item)))
 194
 195 (defun semantic-grammar-prologue ()
 196   "Return grammar prologue code as a string value."
 197   (let ((tag (semantic-find-first-tag-by-name
 198               "prologue"
 199               (semantic-find-tags-by-class 'code (current-buffer)))))
 200     (if tag
 201         (save-excursion
 202           (concat
 203            (buffer-substring
 204             (progn
 205               (goto-char (semantic-tag-start tag))
 206               (skip-chars-forward "%{\r\n\t ")
 207               (point))
 208             (progn
 209               (goto-char (semantic-tag-end tag))
 210               (skip-chars-backward "\r\n\t %}")
 211               (point)))
 212            "\n"))
 213       "")))
 214
 215 (defun semantic-grammar-epilogue ()
 216   "Return grammar epilogue code as a string value."
 217   (let ((tag (semantic-find-first-tag-by-name
 218               "epilogue"
 219               (semantic-find-tags-by-class 'code (current-buffer)))))
 220     (if tag
 221         (save-excursion
 222           (concat
 223            (buffer-substring
 224             (progn
 225               (goto-char (semantic-tag-start tag))
 226               (skip-chars-forward "%\r\n\t ")
 227               (point))
 228             (progn
 229               (goto-char (semantic-tag-end tag))
 230               (skip-chars-backward "\r\n\t")
 231               ;; If a grammar footer is found, skip it.
 232               (re-search-backward "^;;;\\s-+\\S-+\\s-+ends here"
 233                                   (save-excursion
 234                                     (beginning-of-line)
 235                                     (point))
 236                                   t)
 237               (skip-chars-backward "\r\n\t")
 238               (point)))
 239            "\n"))
 240       "")))
 241
 242 (defsubst semantic-grammar-buffer-file (&optional buffer)
 243   "Return name of file sans directory BUFFER is visiting.
 244 No argument or nil as argument means use the current buffer."
 245   (file-name-nondirectory (buffer-file-name buffer)))
 246
 247 (defun semantic-grammar-package ()
 248   "Return the %package value as a string.
 249 If there is no %package statement in the grammar, return a default
 250 package name derived from the grammar file name.  For example, the
 251 default package name for the grammar file foo.wy is foo-wy, and for
 252 foo.by it is foo-by."
 253   (or (semantic-grammar-first-tag-name 'package)
 254       (let* ((file (semantic-grammar-buffer-file))
 255              (ext  (file-name-extension file))
 256              (i    (string-match (format "\\([.]\\)%s\\'" ext) file)))
 257         (concat (substring file 0 i) "-" ext))))
 258
 259 (defsubst semantic-grammar-languagemode ()
 260   "Return the %languagemode value as a list of symbols or nil."
 261   (semantic-grammar-tag-symbols 'languagemode))
 262
 263 (defsubst semantic-grammar-start ()
 264   "Return the %start value as a list of symbols or nil."
 265   (semantic-grammar-tag-symbols 'start))
 266
 267 (defsubst semantic-grammar-scopestart ()
 268   "Return the %scopestart value as a symbol or nil."
 269   (intern (or (semantic-grammar-first-tag-name 'scopestart) "nil")))
 270
 271 (defsubst semantic-grammar-quotemode ()
 272   "Return the %quotemode value as a symbol or nil."
 273   (intern (or (semantic-grammar-first-tag-name 'quotemode) "nil")))
 274
 275 (defsubst semantic-grammar-keywords ()
 276   "Return the language keywords.
 277 That is an alist of (VALUE . TOKEN) where VALUE is the string value of
 278 the keyword and TOKEN is the terminal symbol identifying the keyword."
 279   (mapcar
 280    #'(lambda (key)
 281        (cons (semantic-tag-get-attribute key :value)
 282              (intern (semantic-tag-name key))))
 283    (semantic-find-tags-by-class 'keyword (current-buffer))))
 284
 285 (defun semantic-grammar-keyword-properties (keywords)
 286   "Return the list of KEYWORDS properties."
 287   (let ((puts (semantic-find-tags-by-class
 288                'put (current-buffer)))
 289         put keys key plist assoc pkey pval props)
 290     (while puts
 291       (setq put   (car puts)
 292             puts  (cdr puts)
 293             keys  (mapcar
 294                    'intern
 295                    (cons (semantic-tag-name put)
 296                          (semantic-tag-get-attribute put :rest))))
 297       (while keys
 298         (setq key   (car keys)
 299               keys  (cdr keys)
 300               assoc (rassq key keywords))
 301         (if (null assoc)
 302             nil ;;(message "*** %%put to undefined keyword %s ignored" key)
 303           (setq key   (car assoc)
 304                 plist (semantic-tag-get-attribute put :value))
 305           (while plist
 306             (setq pkey  (intern (caar plist))
 307                   pval  (read (cdar plist))
 308                   props (cons (list key pkey pval) props)
 309                   plist (cdr plist))))))
 310     props))
 311
 312 (defun semantic-grammar-tokens ()
 313   "Return defined lexical tokens.
 314 That is an alist (TYPE . DEFS) where type is a %token <type> symbol
 315 and DEFS is an alist of (TOKEN . VALUE).  TOKEN is the terminal symbol
 316 identifying the token and VALUE is the string value of the token or
 317 nil."
 318   (let (tags alist assoc tag type term names value)
 319
 320     ;; Check for <type> in %left, %right & %nonassoc declarations
 321     (setq tags (semantic-find-tags-by-class
 322                 'assoc (current-buffer)))
 323     (while tags
 324       (setq tag  (car tags)
 325             tags (cdr tags))
 326       (when (setq type (semantic-tag-type tag))
 327         (setq names (semantic-tag-get-attribute tag :value)
 328               assoc (assoc type alist))
 329         (or assoc (setq assoc (list type)
 330                         alist (cons assoc alist)))
 331         (while names
 332           (setq term  (car names)
 333                 names (cdr names))
 334           (or (string-match semantic-grammar-lex-c-char-re term)
 335               (setcdr assoc (cons (list (intern term))
 336                                   (cdr assoc)))))))
 337
 338     ;; Then process %token declarations so they can override any
 339     ;; previous specifications
 340     (setq tags (semantic-find-tags-by-class
 341                 'token (current-buffer)))
 342     (while tags
 343       (setq tag  (car tags)
 344             tags (cdr tags))
 345       (setq names (cons (semantic-tag-name tag)
 346                         (semantic-tag-get-attribute tag :rest))
 347             type  (or (semantic-tag-type tag) "<no-type>")
 348             value (semantic-tag-get-attribute tag :value)
 349             assoc (assoc type alist))
 350       (or assoc (setq assoc (list type)
 351                       alist (cons assoc alist)))
 352       (while names
 353         (setq term  (intern (car names))
 354               names (cdr names))
 355         (setcdr assoc (cons (cons term value) (cdr assoc)))))
 356     alist))
 357
 358 (defun semantic-grammar-token-%type-properties (&optional props)
 359   "Return properties set by %type statements.
 360 This declare a new type if necessary.
 361 If optional argument PROPS is non-nil, it is an existing list of
 362 properties where to add new properties."
 363   (let (type)
 364     (dolist (tag (semantic-find-tags-by-class 'type (current-buffer)))
 365       (setq type (semantic-tag-name tag))
 366       ;; Indicate to auto-generate the analyzer for this type
 367       (push (list type :declared t) props)
 368       (dolist (e (semantic-tag-get-attribute tag :value))
 369         (push (list type (intern (car e)) (read (or (cdr e) "nil")))
 370               props)))
 371     props))
 372
 373 (defun semantic-grammar-token-%put-properties (tokens)
 374   "For types found in TOKENS, return properties set by %put statements."
 375   (let (found type props)
 376     (dolist (put (semantic-find-tags-by-class 'put (current-buffer)))
 377       (dolist (type (cons (semantic-tag-name put)
 378                           (semantic-tag-get-attribute put :rest)))
 379         (setq found (assoc type tokens))
 380         (if (null found)
 381             nil ;; %put <type> ignored, no token defined
 382           (setq type (car found))
 383           (dolist (e (semantic-tag-get-attribute put :value))
 384             (push (list type (intern (car e)) (read (or (cdr e) "nil")))
 385                   props)))))
 386     props))
 387
 388 (defsubst semantic-grammar-token-properties (tokens)
 389   "Return properties of declared types.
 390 Types are explicitly declared by %type statements.  Types found in
 391 TOKENS are those declared implicitly by %token statements.
 392 Properties can be set by %put and %type statements.
 393 Properties set by %type statements take precedence over those set by
 394 %put statements."
 395   (let ((props (semantic-grammar-token-%put-properties tokens)))
 396     (semantic-grammar-token-%type-properties props)))
 397
 398 (defun semantic-grammar-use-macros ()
 399   "Return macro definitions from %use-macros statements.
 400 Also load the specified macro libraries."
 401   (let (lib defs)
 402     (dolist (tag (semantic-find-tags-by-class 'macro (current-buffer)))
 403       (setq lib (intern (semantic-tag-type tag)))
 404       (condition-case nil
 405           ;;(load lib) ;; Be sure to use the latest macro library.
 406           (require lib)
 407         (error nil))
 408       (dolist (mac (semantic-tag-get-attribute tag :value))
 409         (push (cons (intern mac)
 410                     (intern (format "%s-%s" lib mac)))
 411               defs)))
 412     (nreverse defs)))
 413
 414 (defvar semantic-grammar-macros nil
 415   "List of associations (MACRO-NAME . EXPANDER).")
 416 (make-variable-buffer-local 'semantic-grammar-macros)
 417
 418 (defun semantic-grammar-macros ()
 419   "Build and return the alist of defined macros."
 420   (append
 421    ;; Definitions found in tags.
 422    (semantic-grammar-use-macros)
 423    ;; Other pre-installed definitions.
 424    semantic-grammar-macros))
 425 \f
 426 ;;;;
 427 ;;;; Overloaded functions that build parser data.
 428 ;;;;
 429
 430 ;;; Keyword table builder
 431 ;;
 432 (defun semantic-grammar-keywordtable-builder-default ()
 433   "Return the default value of the keyword table."
 434   (let ((keywords (semantic-grammar-keywords)))
 435     `(semantic-lex-make-keyword-table
 436       ',keywords
 437       ',(semantic-grammar-keyword-properties keywords))))
 438
 439 (define-overload semantic-grammar-keywordtable-builder ()
 440   "Return the keyword table table value.")
 441
 442 ;;; Token table builder
 443 ;;
 444 (defun semantic-grammar-tokentable-builder-default ()
 445   "Return the default value of the table of lexical tokens."
 446   (let ((tokens (semantic-grammar-tokens)))
 447     `(semantic-lex-make-type-table
 448       ',tokens
 449       ',(semantic-grammar-token-properties tokens))))
 450
 451 (define-overload semantic-grammar-tokentable-builder ()
 452   "Return the value of the table of lexical tokens.")
 453
 454 ;;; Parser table builder
 455 ;;
 456 (defun semantic-grammar-parsetable-builder-default ()
 457   "Return the default value of the parse table."
 458   (error "`semantic-grammar-parsetable-builder' not defined"))
 459
 460 (define-overload semantic-grammar-parsetable-builder ()
 461   "Return the parser table value.")
 462
 463 ;;; Parser setup code builder
 464 ;;
 465 (defun semantic-grammar-setupcode-builder-default ()
 466   "Return the default value of the setup code form."
 467   (error "`semantic-grammar-setupcode-builder' not defined"))
 468
 469 (define-overload semantic-grammar-setupcode-builder ()
 470   "Return the parser setup code form.")
 471 \f
 472 ;;;;
 473 ;;;; Lisp code generation
 474 ;;;;
 475 (defvar semantic--grammar-input-buffer  nil)
 476 (defvar semantic--grammar-output-buffer nil)
 477
 478 (defsubst semantic-grammar-keywordtable ()
 479   "Return the variable name of the keyword table."
 480   (concat (file-name-sans-extension
 481            (semantic-grammar-buffer-file
 482             semantic--grammar-output-buffer))
 483           "--keyword-table"))
 484
 485 (defsubst semantic-grammar-tokentable ()
 486   "Return the variable name of the token table."
 487   (concat (file-name-sans-extension
 488            (semantic-grammar-buffer-file
 489             semantic--grammar-output-buffer))
 490           "--token-table"))
 491
 492 (defsubst semantic-grammar-parsetable ()
 493   "Return the variable name of the parse table."
 494   (concat (file-name-sans-extension
 495            (semantic-grammar-buffer-file
 496             semantic--grammar-output-buffer))
 497           "--parse-table"))
 498
 499 (defsubst semantic-grammar-setupfunction ()
 500   "Return the name of the parser setup function."
 501   (concat (file-name-sans-extension
 502            (semantic-grammar-buffer-file
 503             semantic--grammar-output-buffer))
 504           "--install-parser"))
 505
 506 (defmacro semantic-grammar-as-string (object)
 507   "Return OBJECT as a string value."
 508   `(if (stringp ,object)
 509        ,object
 510      ;;(require 'pp)
 511      (pp-to-string ,object)))
 512
 513 (defun semantic-grammar-insert-defconst (name value docstring)
 514   "Insert declaration of constant NAME with VALUE and DOCSTRING."
 515   (let ((start (point)))
 516     (insert (format "(defconst %s\n%s%S)\n\n" name value docstring))
 517     (save-excursion
 518       (goto-char start)
 519       (indent-sexp))))
 520
 521 (defun semantic-grammar-insert-defun (name body docstring)
 522   "Insert declaration of function NAME with BODY and DOCSTRING."
 523   (let ((start (point)))
 524     (insert (format "(defun %s ()\n%S\n%s)\n\n" name docstring body))
 525     (save-excursion
 526       (goto-char start)
 527       (indent-sexp))))
 528
 529 (defun semantic-grammar-insert-define (define)
 530   "Insert the declaration specified by DEFINE expression.
 531 Typically a DEFINE expression should look like this:
 532
 533 \(define-thing name docstring expression1 ...)"
 534   ;;(require 'pp)
 535   (let ((start (point)))
 536     (insert (format "(%S %S" (car define) (nth 1 define)))
 537     (dolist (item (nthcdr 2 define))
 538       (insert "\n")
 539       (delete-blank-lines)
 540       (pp item (current-buffer)))
 541     (insert ")\n\n")
 542     (save-excursion
 543       (goto-char start)
 544       (indent-sexp))))
 545
 546 (defconst semantic-grammar-header-template
 547   "\
 548 ;;; %F --- Generated parser support file
 549
 550 %C
 551
 552 ;; Author: %U <%M>
 553 ;; Created: %D
 554 ;; Keywords: syntax
 555 ;; X-RCS: %V
 556
 557 ;; This file is not part of GNU Emacs.
 558 ;;
 559 ;; This program is free software; you can redistribute it and/or
 560 ;; modify it under the terms of the GNU General Public License as
 561 ;; published by the Free Software Foundation; either version 2, or (at
 562 ;; your option) any later version.
 563 ;;
 564 ;; This software is distributed in the hope that it will be useful,
 565 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 566 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 567 ;; General Public License for more details.
 568 ;;
 569 ;; You should have received a copy of the GNU General Public License
 570 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
 571 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
 572 ;; Boston, MA 02110-1301, USA.
 573
 574 ;;; Commentary:
 575 ;;
 576 ;; PLEASE DO NOT MANUALLY EDIT THIS FILE!  It is automatically
 577 ;; generated from the grammar file %G.
 578
 579 ;;; History:
 580 ;;
 581
 582 ;;; Code:
 583 "
 584   "Generated header template.")
 585
 586 (defconst semantic-grammar-footer-template
 587   "\
 588
 589 \(provide '%L)
 590
 591 ;;; %F ends here
 592 "
 593   "Generated footer template.")
 594
 595 (defun semantic-grammar-copyright-line ()
 596   "Return the grammar copyright line, or nil if not found."
 597   (save-excursion
 598     (goto-char (point-min))
 599     (when (re-search-forward "^;;+[ \t]+Copyright (C) .*$"
 600                              ;; Search only in the four top lines
 601                              (save-excursion (forward-line 4) (point))
 602                              t)
 603       (match-string 0))))
 604
 605 (defun semantic-grammar-header ()
 606   "Return text of a generated standard header."
 607   (let ((file (semantic-grammar-buffer-file
 608                semantic--grammar-output-buffer))
 609         (gram (semantic-grammar-buffer-file))
 610         (date (format-time-string "%Y-%m-%d %T%z"))
 611         (vcid (concat "$" "Id" "$")) ;; Avoid expansion
 612         ;; Try to get the copyright from the input grammar, or
 613         ;; generate a new one if not found.
 614         (copy (or (semantic-grammar-copyright-line)
 615                   (concat (format-time-string ";; Copyright (C) %Y ")
 616                           user-full-name))))
 617     (Sformat '((?U user-full-name)
 618                (?M user-mail-address)
 619                (?F file)
 620                (?G gram)
 621                (?C copy)
 622                (?D date)
 623                (?V vcid))
 624              semantic-grammar-header-template)))
 625
 626 (defun semantic-grammar-footer ()
 627   "Return text of a generated standard footer."
 628   (let* ((file (semantic-grammar-buffer-file
 629                 semantic--grammar-output-buffer))
 630          (libr (file-name-sans-extension file)))
 631     (Sformat '((?F file)
 632                (?L libr))
 633              semantic-grammar-footer-template)))
 634
 635 (defun semantic-grammar-token-data ()
 636   "Return the string value of the table of lexical tokens."
 637   (semantic-grammar-as-string
 638    (semantic-grammar-tokentable-builder)))
 639
 640 (defun semantic-grammar-keyword-data ()
 641   "Return the string value of the table of keywords."
 642   (semantic-grammar-as-string
 643    (semantic-grammar-keywordtable-builder)))
 644
 645 (defun semantic-grammar-parser-data ()
 646   "Return the parser table as a string value."
 647   (semantic-grammar-as-string
 648    (semantic-grammar-parsetable-builder)))
 649
 650 (defun semantic-grammar-setup-data ()
 651   "Return the parser setup code form as a string value."
 652   (semantic-grammar-as-string
 653    (semantic-grammar-setupcode-builder)))
 654 \f
 655 ;;; Generation of lexical analyzers.
 656 ;;
 657 (defvar semantic-grammar--lex-block-specs)
 658
 659 (defsubst semantic-grammar--lex-delim-spec (block-spec)
 660   "Return delimiters specification from BLOCK-SPEC."
 661   (condition-case nil
 662       (let* ((standard-input (cdr block-spec))
 663              (delim-spec (read)))
 664         (if (and (consp delim-spec)
 665                  (car delim-spec) (symbolp (car delim-spec))
 666                  (cadr delim-spec) (symbolp (cadr delim-spec)))
 667             delim-spec
 668           (error)))
 669     (error
 670      (error "Invalid delimiters specification %s in block token %s"
 671             (cdr block-spec) (car block-spec)))))
 672
 673 (defun semantic-grammar--lex-block-specs ()
 674   "Compute lexical block specifications for the current buffer.
 675 Block definitions are read from the current table of lexical types."
 676   (cond
 677    ;; Block specifications have been parsed and are invalid.
 678    ((eq semantic-grammar--lex-block-specs 'error)
 679     nil
 680     )
 681    ;; Parse block specifications.
 682    ((null semantic-grammar--lex-block-specs)
 683     (condition-case err
 684         (let* ((blocks       (cdr (semantic-lex-type-value "block" t)))
 685                (open-delims  (cdr (semantic-lex-type-value "open-paren" t)))
 686                (close-delims (cdr (semantic-lex-type-value "close-paren" t)))
 687                olist clist block-spec delim-spec open-spec close-spec)
 688           (dolist (block-spec blocks)
 689             (setq delim-spec (semantic-grammar--lex-delim-spec block-spec)
 690                   open-spec  (assq (car  delim-spec) open-delims)
 691                   close-spec (assq (cadr delim-spec) close-delims))
 692             (or open-spec
 693                 (error "Missing open-paren token %s required by block %s"
 694                        (car delim-spec) (car block-spec)))
 695             (or close-spec
 696                 (error "Missing close-paren token %s required by block %s"
 697                        (cdr delim-spec) (car block-spec)))
 698             ;; build alist ((OPEN-DELIM OPEN-SYM BLOCK-SYM) ...)
 699             (push (list (cdr open-spec) (car open-spec) (car block-spec))
 700                   olist)
 701             ;; build alist ((CLOSE-DELIM CLOSE-SYM) ...)
 702             (push (list (cdr close-spec) (car close-spec))
 703                   clist))
 704           (setq semantic-grammar--lex-block-specs (cons olist clist)))
 705       (error
 706        (setq semantic-grammar--lex-block-specs 'error)
 707        (message "%s" (error-message-string err))
 708        nil))
 709     )
 710    ;; Block specifications already parsed.
 711    (t
 712     semantic-grammar--lex-block-specs)))
 713
 714 (defsubst semantic-grammar-quoted-form (exp)
 715   "Return a quoted form of EXP if it isn't a self evaluating form."
 716   (if (and (not (null exp))
 717            (or (listp exp) (symbolp exp)))
 718       (list 'quote exp)
 719     exp))
 720
 721 (defun semantic-grammar-insert-defanalyzer (type)
 722   "Insert declaration of the lexical analyzer defined with TYPE."
 723   (let* ((type-name  (symbol-name type))
 724          (type-value (symbol-value type))
 725          (syntax     (get type 'syntax))
 726          (declared   (get type :declared))
 727          spec mtype prefix name doc)
 728     ;; Generate an analyzer if the corresponding type has been
 729     ;; explicitly declared in a %type statement, and if at least the
 730     ;; syntax property has been provided.
 731     (when (and declared syntax)
 732       (setq prefix (file-name-sans-extension
 733                     (semantic-grammar-buffer-file
 734                      semantic--grammar-output-buffer))
 735             mtype (or (get type 'matchdatatype) 'regexp)
 736             name (intern (format "%s--<%s>-%s-analyzer" prefix type mtype))
 737             doc (format "%s analyzer for <%s> tokens." mtype type))
 738       (cond
 739        ;; Regexp match analyzer
 740        ((eq mtype 'regexp)
 741         (semantic-grammar-insert-define
 742          `(define-lex-regex-type-analyzer ,name
 743             ,doc ,syntax
 744             ,(semantic-grammar-quoted-form (cdr type-value))
 745             ',(or (car type-value) (intern type-name))))
 746         )
 747        ;; String compare analyzer
 748        ((eq mtype 'string)
 749         (semantic-grammar-insert-define
 750          `(define-lex-string-type-analyzer ,name
 751             ,doc ,syntax
 752             ,(semantic-grammar-quoted-form (cdr type-value))
 753             ',(or (car type-value) (intern type-name))))
 754         )
 755        ;; Block analyzer
 756        ((and (eq mtype 'block)
 757              (setq spec (semantic-grammar--lex-block-specs)))
 758         (semantic-grammar-insert-define
 759          `(define-lex-block-type-analyzer ,name
 760             ,doc ,syntax
 761             ,(semantic-grammar-quoted-form spec)))
 762         )
 763        ;; Sexp analyzer
 764        ((eq mtype 'sexp)
 765         (semantic-grammar-insert-define
 766          `(define-lex-sexp-type-analyzer ,name
 767             ,doc ,syntax
 768             ',(or (car type-value) (intern type-name))))
 769         )
 770        ;; keyword analyzer
 771        ((eq mtype 'keyword)
 772         (semantic-grammar-insert-define
 773          `(define-lex-keyword-type-analyzer ,name
 774             ,doc ,syntax))
 775         )
 776        ))
 777     ))
 778
 779 (defun semantic-grammar-insert-defanalyzers ()
 780   "Insert declarations of lexical analyzers."
 781   (let (tokens props)
 782     (with-current-buffer semantic--grammar-input-buffer
 783       (setq tokens (semantic-grammar-tokens)
 784             props  (semantic-grammar-token-properties tokens)))
 785     (insert "(require 'semantic-lex)\n\n")
 786     (let ((semantic-lex-types-obarray
 787            (semantic-lex-make-type-table tokens props))
 788           semantic-grammar--lex-block-specs)
 789       (mapatoms 'semantic-grammar-insert-defanalyzer
 790                 semantic-lex-types-obarray))))
 791 \f
 792 ;;; Generation of the grammar support file.
 793 ;;
 794 (defcustom semantic-grammar-file-regexp "\\.[wb]y$"
 795   "Regexp which matches grammar source files."
 796   :group 'semantic
 797   :type 'regexp)
 798
 799 (defsubst semantic-grammar-noninteractive ()
 800   "Return non-nil if running without interactive terminal."
 801   (if (featurep 'xemacs)
 802       (noninteractive)
 803     noninteractive))
 804
 805 (defun semantic-grammar-create-package (&optional force)
 806   "Create package Lisp code from grammar in current buffer.
 807 Does nothing if the Lisp code seems up to date.
 808 If optional argument FORCE is non-nil, unconditionally re-generate the
 809 Lisp code."
 810   (interactive "P")
 811   (setq force (or force current-prefix-arg))
 812   (semantic-fetch-tags)
 813   (let* (
 814          ;; Values of the following local variables are obtained from
 815          ;; the grammar parsed tree in current buffer, that is before
 816          ;; switching to the output file.
 817          (package  (semantic-grammar-package))
 818          (output   (concat package ".el"))
 819          (semantic--grammar-input-buffer  (current-buffer))
 820          (semantic--grammar-output-buffer (find-file-noselect output))
 821          (header   (semantic-grammar-header))
 822          (prologue (semantic-grammar-prologue))
 823          (epilogue (semantic-grammar-epilogue))
 824          (footer   (semantic-grammar-footer))
 825          )
 826     (if (and (not force)
 827              (not (buffer-modified-p))
 828              (file-newer-than-file-p
 829               (buffer-file-name semantic--grammar-output-buffer)
 830               (buffer-file-name semantic--grammar-input-buffer)))
 831         (message "Package `%s' is up to date." package)
 832       ;; Create the package
 833       (set-buffer semantic--grammar-output-buffer)
 834       ;; Use Unix EOLs, so that the file is portable to all platforms.
 835       (setq buffer-file-coding-system 'raw-text-unix)
 836       (erase-buffer)
 837       (unless (eq major-mode 'emacs-lisp-mode)
 838         (emacs-lisp-mode))
 839
 840 ;;;; Header + Prologue
 841
 842       (insert header
 843               "\f\n;;; Prologue\n;;\n"
 844               prologue
 845               )
 846       ;; Evaluate the prologue now, because it might provide definition
 847       ;; of grammar macro expanders.
 848       (eval-region (point-min) (point))
 849
 850       (save-excursion
 851
 852 ;;;; Declarations
 853
 854         (insert "\f\n;;; Declarations\n;;\n")
 855
 856         ;; `eval-defun' is not necessary to reset `defconst' values.
 857         (semantic-grammar-insert-defconst
 858          (semantic-grammar-keywordtable)
 859          (with-current-buffer semantic--grammar-input-buffer
 860            (semantic-grammar-keyword-data))
 861          "Table of language keywords.")
 862
 863         (semantic-grammar-insert-defconst
 864          (semantic-grammar-tokentable)
 865          (with-current-buffer semantic--grammar-input-buffer
 866            (semantic-grammar-token-data))
 867          "Table of lexical tokens.")
 868
 869         (semantic-grammar-insert-defconst
 870          (semantic-grammar-parsetable)
 871          (with-current-buffer semantic--grammar-input-buffer
 872            (semantic-grammar-parser-data))
 873          "Parser table.")
 874
 875         (semantic-grammar-insert-defun
 876          (semantic-grammar-setupfunction)
 877          (with-current-buffer semantic--grammar-input-buffer
 878            (semantic-grammar-setup-data))
 879          "Setup the Semantic Parser.")
 880
 881 ;;;; Analyzers
 882         (insert "\f\n;;; Analyzers\n;;\n")
 883
 884         (semantic-grammar-insert-defanalyzers)
 885
 886 ;;;; Epilogue & Footer
 887
 888         (insert "\f\n;;; Epilogue\n;;\n"
 889                 epilogue
 890                 footer
 891                 )
 892
 893         )
 894
 895       ;; If running in batch mode, there is nothing more to do.
 896       ;; Save the generated file and quit.
 897       (if (semantic-grammar-noninteractive)
 898           (let ((version-control t)
 899                 (delete-old-versions t)
 900                 (make-backup-files t)
 901                 (vc-make-backup-files t))
 902             (save-buffer 16)
 903             (kill-buffer (current-buffer)))
 904         ;; If running interactively, eval declarations and epilogue
 905         ;; code, then pop to the buffer visiting the generated file.
 906         (eval-region (point) (point-max))
 907         (goto-char (point-min))
 908         (pop-to-buffer (current-buffer))
 909         ;; The generated code has been evaluated and updated into
 910         ;; memory.  Now find all buffers that match the major modes we
 911         ;; have created this language for, and force them to call our
 912         ;; setup function again, refreshing all semantic data, and
 913         ;; enabling them to work with the new code just created.
 914 ;;;; FIXME?
 915         ;; At this point, I don't know any user's defined setup code :-(
 916         ;; At least, what I can do for now, is to run the generated
 917         ;; parser-install function.
 918         (semantic-map-mode-buffers
 919          (semantic-grammar-setupfunction)
 920          (semantic-grammar-languagemode)))
 921       )
 922     ;; Return the name of the generated package file.
 923     output))
 924
 925 (defun semantic-grammar-recreate-package ()
 926   "Unconditionnaly create Lisp code from grammar in current buffer.
 927 Like \\[universal-argument] \\[semantic-grammar-create-package]."
 928   (interactive)
 929   (semantic-grammar-create-package t))
 930
 931 (defun semantic-grammar-batch-build-one-package (file)
 932   "Build a Lisp package from the grammar in FILE.
 933 That is, generate Lisp code from FILE, and `byte-compile' it.
 934 Return non-nil if there were no errors, nil if errors."
 935   ;; We need this require so that we can find `byte-compile-dest-file'.
 936   (require 'bytecomp)
 937   (unless (auto-save-file-name-p file)
 938     ;; Create the package
 939     (let ((packagename
 940            (condition-case err
 941                (with-current-buffer (find-file-noselect file)
 942                  (semantic-grammar-create-package))
 943              (error
 944               (message "%s" (error-message-string err))
 945               nil))))
 946       (when packagename
 947         ;; Only byte compile if out of date
 948         (if (file-newer-than-file-p
 949              packagename (byte-compile-dest-file packagename))
 950             (let (;; Some complex grammar table expressions need a few
 951                   ;; more resources than the default.
 952                   (max-specpdl-size    (max 3000 max-specpdl-size))
 953                   (max-lisp-eval-depth (max 1000 max-lisp-eval-depth))
 954                   )
 955               ;; byte compile the resultant file
 956               (byte-compile-file packagename))
 957           t)))))
 958
 959 ;;;###autoload
 960 (defun semantic-grammar-batch-build-packages ()
 961   "Build Lisp packages from grammar files on the command line.
 962 That is, run `semantic-grammar-batch-build-one-package' for each file.
 963 Each file is processed even if an error occurred previously.
 964 Must be used from the command line, with `-batch'.
 965 For example, to process grammar files in current directory, invoke:
 966
 967   \"emacs -batch -f semantic-grammar-batch-build-packages .\".
 968
 969 See also the variable `semantic-grammar-file-regexp'."
 970   (or (semantic-grammar-noninteractive)
 971       (error "\
 972 `semantic-grammar-batch-build-packages' must be used with -batch"
 973              ))
 974   (let ((status 0)
 975         ;; Remove vc from find-file-hooks.  It causes bad stuff to
 976         ;; happen in Emacs 20.
 977         (find-file-hooks (delete 'vc-find-file-hook find-file-hooks)))
 978     (message "Compiling Grammars from: %s" (locate-library "semantic-grammar"))
 979     (dolist (arg command-line-args-left)
 980       (unless (and arg (file-exists-p arg))
 981         (error "Argument %s is not a valid file name" arg))
 982       (setq arg (expand-file-name arg))
 983       (if (file-directory-p arg)
 984           ;; Directory as argument
 985           (dolist (src (condition-case nil
 986                            (directory-files
 987                             arg nil semantic-grammar-file-regexp)
 988                          (error
 989                           (error "Unable to read directory files"))))
 990             (or (semantic-grammar-batch-build-one-package
 991                  (expand-file-name src arg))
 992                 (setq status 1)))
 993         ;; Specific file argument
 994         (or (semantic-grammar-batch-build-one-package arg)
 995             (setq status 1))))
 996     (kill-emacs status)
 997     ))
 998 \f
 999 ;;;;
1000 ;;;; Macros highlighting
1001 ;;;;
1002
1003 (defvar semantic--grammar-macros-regexp-1 nil)
1004 (make-variable-buffer-local 'semantic--grammar-macros-regexp-1)
1005
1006 (defun semantic--grammar-macros-regexp-1 ()
1007   "Return font-lock keyword regexp for pre-installed macro names."
1008   (and semantic-grammar-macros
1009        (not semantic--grammar-macros-regexp-1)
1010        (condition-case nil
1011            (setq semantic--grammar-macros-regexp-1
1012                  (concat "(\\s-*"
1013                          (regexp-opt
1014                           (mapcar #'(lambda (e) (symbol-name (car e)))
1015                                   semantic-grammar-macros)
1016                           t)
1017                          "\\>"))
1018          (error nil)))
1019   semantic--grammar-macros-regexp-1)
1020
1021 (defconst semantic--grammar-macdecl-re
1022   "\\<%use-macros\\>[ \t\r\n]+\\(\\sw\\|\\s_\\)+[ \t\r\n]+{"
1023   "Regexp that matches a macro declaration statement.")
1024
1025 (defvar semantic--grammar-macros-regexp-2 nil)
1026 (make-variable-buffer-local 'semantic--grammar-macros-regexp-2)
1027
1028 (defun semantic--grammar-clear-macros-regexp-2 (&rest ignore)
1029   "Clear the cached regexp that match macros local in this grammar.
1030 IGNORE arguments.
1031 Added to `before-change-functions' hooks to be run before each text
1032 change."
1033   (setq semantic--grammar-macros-regexp-2 nil))
1034
1035 (defun semantic--grammar-macros-regexp-2 ()
1036   "Return the regexp that match macros local in this grammar."
1037   (unless semantic--grammar-macros-regexp-2
1038     (let (macs)
1039       (save-excursion
1040         (goto-char (point-min))
1041         (while (re-search-forward semantic--grammar-macdecl-re nil t)
1042           (condition-case nil
1043               (setq macs (nconc macs
1044                                 (split-string
1045                                  (buffer-substring-no-properties
1046                                   (point)
1047                                   (progn
1048                                     (backward-char)
1049                                     (forward-list 1)
1050                                     (down-list -1)
1051                                     (point))))))
1052             (error nil)))
1053         (when macs
1054           (setq semantic--grammar-macros-regexp-2
1055                 (concat "(\\s-*" (regexp-opt macs t) "\\>"))))))
1056   semantic--grammar-macros-regexp-2)
1057
1058 (defun semantic--grammar-macros-matcher (end)
1059   "Search for a grammar macro name to highlight.
1060 END is the limit of the search."
1061   (let ((regexp (semantic--grammar-macros-regexp-1)))
1062     (or (and regexp (re-search-forward regexp end t))
1063         (and (setq regexp (semantic--grammar-macros-regexp-2))
1064              (re-search-forward regexp end t)))))
1065 \f
1066 ;;;;
1067 ;;;; Define major mode
1068 ;;;;
1069
1070 (defvar semantic-grammar-syntax-table
1071   (let ((table (make-syntax-table (standard-syntax-table))))
1072     (modify-syntax-entry ?\: "."     table) ;; COLON
1073     (modify-syntax-entry ?\> "."     table) ;; GT
1074     (modify-syntax-entry ?\< "."     table) ;; LT
1075     (modify-syntax-entry ?\| "."     table) ;; OR
1076     (modify-syntax-entry ?\; ". 12"  table) ;; SEMI, Comment start ;;
1077     (modify-syntax-entry ?\n ">"     table) ;; Comment end
1078     (modify-syntax-entry ?\" "\""    table) ;; String
1079     (modify-syntax-entry ?\% "w"     table) ;; Word
1080     (modify-syntax-entry ?\- "_"     table) ;; Symbol
1081     (modify-syntax-entry ?\. "_"     table) ;; Symbol
1082     (modify-syntax-entry ?\\ "\\"    table) ;; Quote
1083     (modify-syntax-entry ?\` "'"     table) ;; Prefix ` (backquote)
1084     (modify-syntax-entry ?\' "'"     table) ;; Prefix ' (quote)
1085     (modify-syntax-entry ?\, "'"     table) ;; Prefix , (comma)
1086     (modify-syntax-entry ?\# "'"     table) ;; Prefix # (sharp)
1087     table)
1088   "Syntax table used in a Semantic grammar buffers.")
1089
1090 (defvar semantic-grammar-mode-hook nil
1091   "Hook run when starting Semantic grammar mode.")
1092
1093 (defvar semantic-grammar-mode-keywords-1
1094   `(("\\(\\<%%\\>\\|\\<%[{}]\\)"
1095      0 font-lock-reference-face)
1096     ("\\(%\\)\\(\\(\\sw\\|\\s_\\)+\\)"
1097      (1 font-lock-reference-face)
1098      (2 font-lock-keyword-face))
1099     ("\\<error\\>"
1100      0 (unless (semantic-grammar-in-lisp-p) 'bold))
1101     ("^\\(\\(\\sw\\|\\s_\\)+\\)[ \n\r\t]*:"
1102      1 font-lock-function-name-face)
1103     (semantic--grammar-macros-matcher
1104      1 ,(if (boundp 'font-lock-builtin-face)
1105             'font-lock-builtin-face
1106           'font-lock-preprocessor-face))
1107     ("\\$\\(\\sw\\|\\s_\\)*"
1108      0 font-lock-variable-name-face)
1109     ("<\\(\\(\\sw\\|\\s_\\)+\\)>"
1110      1 font-lock-type-face)
1111     (,semantic-grammar-lex-c-char-re
1112      0 ,(if (boundp 'font-lock-constant-face)
1113             'font-lock-constant-face
1114           'font-lock-string-face) t)
1115     ;; Must highlight :keyword here, because ':' is a punctuation in
1116     ;; grammar mode!
1117     ("[\r\n\t ]+:\\sw+\\>"
1118      0 font-lock-builtin-face)
1119     ;; Append the Semantic keywords
1120     ,@semantic-fw-font-lock-keywords
1121     )
1122   "Font Lock keywords used to highlight Semantic grammar buffers.")
1123
1124 (defvar semantic-grammar-mode-keywords-2
1125   (append semantic-grammar-mode-keywords-1
1126           lisp-font-lock-keywords-1)
1127   "Font Lock keywords used to highlight Semantic grammar buffers.")
1128
1129 (defvar semantic-grammar-mode-keywords-3
1130   (append semantic-grammar-mode-keywords-1
1131           lisp-font-lock-keywords-2)
1132   "Font Lock keywords used to highlight Semantic grammar buffers.")
1133
1134 (defvar semantic-grammar-mode-keywords
1135   semantic-grammar-mode-keywords-1
1136   "Font Lock keywords used to highlight Semantic grammar buffers.")
1137
1138 (defvar semantic-grammar-map
1139   (let ((km (make-sparse-keymap)))
1140
1141     (define-key km "|" 'semantic-grammar-electric-punctuation)
1142     (define-key km ";" 'semantic-grammar-electric-punctuation)
1143     (define-key km "%" 'semantic-grammar-electric-punctuation)
1144     (define-key km "(" 'semantic-grammar-electric-punctuation)
1145     (define-key km ")" 'semantic-grammar-electric-punctuation)
1146     (define-key km ":" 'semantic-grammar-electric-punctuation)
1147
1148     (define-key km "\t"       'semantic-grammar-indent)
1149     (define-key km "\M-\t"    'semantic-grammar-complete)
1150     (define-key km "\C-c\C-c" 'semantic-grammar-create-package)
1151     (define-key km "\C-cm"    'semantic-grammar-find-macro-expander)
1152     (define-key km "\C-cik"    'semantic-grammar-insert-keyword)
1153 ;;  (define-key km "\C-cc"    'semantic-grammar-generate-and-load)
1154 ;;  (define-key km "\C-cr"    'semantic-grammar-generate-one-rule)
1155
1156     km)
1157   "Keymap used in `semantic-grammar-mode'.")
1158
1159 (defvar semantic-grammar-menu
1160   '("Grammar"
1161     ["Indent Line" semantic-grammar-indent]
1162     ["Complete Symbol" semantic-grammar-complete]
1163     ["Find Macro" semantic-grammar-find-macro-expander]
1164     "--"
1165     ["Insert %keyword" semantic-grammar-insert-keyword]
1166     "--"
1167     ["Update Lisp Package" semantic-grammar-create-package]
1168     ["Recreate Lisp Package" semantic-grammar-recreate-package]
1169     )
1170   "Common semantic grammar menu.")
1171
1172 (defun semantic-grammar-setup-menu-emacs (symbol mode-menu)
1173   "Setup a GNU Emacs grammar menu in variable SYMBOL.
1174 MODE-MENU is an optional specific menu whose items are appended to the
1175 common grammar menu."
1176   (let ((items (make-symbol "items")))
1177     `(unless (boundp ',symbol)
1178        (easy-menu-define ,symbol (current-local-map)
1179          "Grammar Menu" semantic-grammar-menu)
1180        (let ((,items (cdr ,mode-menu)))
1181          (when ,items
1182            (easy-menu-add-item ,symbol nil "--")
1183            (while ,items
1184              (easy-menu-add-item ,symbol nil (car ,items))
1185              (setq ,items (cdr ,items))))))
1186     ))
1187
1188 (defun semantic-grammar-setup-menu-xemacs (symbol mode-menu)
1189   "Setup an XEmacs grammar menu in variable SYMBOL.
1190 MODE-MENU is an optional specific menu whose items are appended to the
1191 common grammar menu."
1192   (let ((items (make-symbol "items"))
1193         (path (make-symbol "path")))
1194     `(progn
1195        (unless (boundp ',symbol)
1196          (easy-menu-define ,symbol nil
1197            "Grammar Menu" (copy-sequence semantic-grammar-menu)))
1198        (easy-menu-add ,symbol)
1199        (let ((,items (cdr ,mode-menu))
1200              (,path (list (car ,symbol))))
1201          (when ,items
1202            (easy-menu-add-item nil ,path "--")
1203            (while ,items
1204              (easy-menu-add-item nil ,path (car ,items))
1205              (setq ,items (cdr ,items))))))
1206     ))
1207
1208 (defmacro semantic-grammar-setup-menu (&optional mode-menu)
1209   "Setup a mode local grammar menu.
1210 MODE-MENU is an optional specific menu whose items are appended to the
1211 common grammar menu."
1212   (let ((menu (intern (format "%s-menu" major-mode))))
1213     (if (featurep 'xemacs)
1214         (semantic-grammar-setup-menu-xemacs menu mode-menu)
1215       (semantic-grammar-setup-menu-emacs menu mode-menu))))
1216
1217 (defsubst semantic-grammar-in-lisp-p ()
1218   "Return non-nil if point is in Lisp code."
1219   (or (>= (point) (semantic-grammar-epilogue-start))
1220       (condition-case nil
1221           (save-excursion
1222             (up-list -1)
1223             t)
1224         (error nil))))
1225
1226 (defun semantic-grammar-edits-new-change-hook-fcn (overlay)
1227   "Function set into `semantic-edits-new-change-hook'.
1228 Argument OVERLAY is the overlay created to mark the change.
1229 When OVERLAY marks a change in the scope of a nonterminal tag extend
1230 the change bounds to encompass the whole nonterminal tag."
1231   (let ((outer (car (semantic-find-tag-by-overlay-in-region
1232                      (semantic-edits-os overlay)
1233                      (semantic-edits-oe overlay)))))
1234     (if (semantic-tag-of-class-p outer 'nonterminal)
1235         (semantic-overlay-move overlay
1236                                (semantic-tag-start outer)
1237                                (semantic-tag-end outer)))))
1238
1239 (defun semantic-grammar-mode ()
1240   "Initialize a buffer for editing Semantic grammars.
1241
1242 \\{semantic-grammar-map}"
1243   (interactive)
1244   (kill-all-local-variables)
1245   (setq major-mode 'semantic-grammar-mode
1246         mode-name "Semantic Grammar Framework")
1247   (set (make-local-variable 'parse-sexp-ignore-comments) t)
1248   (set (make-local-variable 'comment-start) ";;")
1249   ;; Look within the line for a ; following an even number of backslashes
1250   ;; after either a non-backslash or the line beginning.
1251   (set (make-local-variable 'comment-start-skip)
1252        "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *")
1253   (set-syntax-table semantic-grammar-syntax-table)
1254   (use-local-map semantic-grammar-map)
1255   (set (make-local-variable 'indent-line-function)
1256        'semantic-grammar-indent)
1257   (set (make-local-variable 'fill-paragraph-function)
1258        'lisp-fill-paragraph)
1259   (set (make-local-variable 'font-lock-multiline)
1260        'undecided)
1261   (set (make-local-variable 'font-lock-defaults)
1262        '((semantic-grammar-mode-keywords
1263           semantic-grammar-mode-keywords-1
1264           semantic-grammar-mode-keywords-2
1265           semantic-grammar-mode-keywords-3)
1266          nil  ;; perform string/comment fontification
1267          nil  ;; keywords are case sensitive.
1268          ;; This puts _ & - as a word constituant,
1269          ;; simplifying our keywords significantly
1270          ((?_ . "w") (?- . "w"))))
1271   ;; Setup Semantic to parse grammar
1272   (semantic-grammar-wy--install-parser)
1273   (setq semantic-lex-comment-regex ";;"
1274         semantic-lex-analyzer 'semantic-grammar-lexer
1275         semantic-type-relation-separator-character '(":")
1276         semantic-symbol->name-assoc-list
1277         '(
1278           (code         . "Setup Code")
1279           (keyword      . "Keyword")
1280           (token        . "Token")
1281           (nonterminal  . "Nonterminal")
1282           (rule         . "Rule")
1283           ))
1284   (set (make-local-variable 'semantic-format-face-alist)
1285        '(
1286          (code         . default)
1287          (keyword      . font-lock-keyword-face)
1288          (token        . font-lock-type-face)
1289          (nonterminal  . font-lock-function-name-face)
1290          (rule         . default)
1291          ))
1292   (set (make-local-variable 'semantic-stickyfunc-sticky-classes)
1293        '(nonterminal))
1294   ;; Before each change, clear the cached regexp used to highlight
1295   ;; macros local in this grammar.
1296   (semantic-make-local-hook 'before-change-functions)
1297   (add-hook 'before-change-functions
1298             'semantic--grammar-clear-macros-regexp-2 nil t)
1299   ;; Handle safe re-parse of grammar rules.
1300   (semantic-make-local-hook 'semantic-edits-new-change-hooks)
1301   (add-hook 'semantic-edits-new-change-hooks
1302             'semantic-grammar-edits-new-change-hook-fcn
1303             nil t)
1304   (semantic-run-mode-hooks 'semantic-grammar-mode-hook))
1305 \f
1306 ;;;;
1307 ;;;; Useful commands
1308 ;;;;
1309
1310 (defvar semantic-grammar-skip-quoted-syntax-table
1311   (let ((st (copy-syntax-table semantic-grammar-syntax-table)))
1312     (modify-syntax-entry ?\' "$" st)
1313     st)
1314   "Syntax table to skip a whole quoted expression in grammar code.
1315 Consider quote as a \"paired delimiter\", so `forward-sexp' will skip
1316 whole quoted expression.")
1317
1318 (defsubst semantic-grammar-backward-item ()
1319   "Move point to beginning of the previous grammar item."
1320   (forward-comment (- (point-max)))
1321   (if (zerop (skip-syntax-backward "."))
1322       (if (eq (char-before) ?\')
1323           (with-syntax-table
1324               ;; Can't be Lisp code here!  Temporarily consider quote
1325               ;; as a "paired delimiter", so `forward-sexp' can skip
1326               ;; the whole quoted expression.
1327               semantic-grammar-skip-quoted-syntax-table
1328             (forward-sexp -1))
1329         (forward-sexp -1))))
1330
1331 (defun semantic-grammar-anchored-indentation ()
1332   "Return indentation based on previous anchor character found."
1333   (let (indent)
1334     (save-excursion
1335       (while (not indent)
1336         (semantic-grammar-backward-item)
1337         (cond
1338          ((bobp)
1339           (setq indent 0))
1340          ((looking-at ":\\(\\s-\\|$\\)")
1341           (setq indent (current-column))
1342           (forward-char)
1343           (skip-syntax-forward "-")
1344           (if (eolp) (setq indent 2))
1345           )
1346          ((and (looking-at "[;%]")
1347                (not (looking-at "\\<%prec\\>")))
1348           (setq indent 0)
1349           ))))
1350     indent))
1351
1352 (defun semantic-grammar-do-grammar-indent ()
1353   "Indent a line of grammar.
1354 When called the point is not in Lisp code."
1355   (let (indent n)
1356     (save-excursion
1357       (beginning-of-line)
1358       (skip-syntax-forward "-")
1359       (setq indent (current-column))
1360       (cond
1361        ((or (bobp)
1362             (looking-at "\\(\\w\\|\\s_\\)+\\s-*:")
1363             (and (looking-at "%")
1364                  (not (looking-at "%prec\\>"))))
1365         (setq n 0))
1366        ((looking-at ":")
1367         (setq n 2))
1368        ((and (looking-at ";;")
1369              (save-excursion (forward-comment (point-max))
1370                              (looking-at ":")))
1371         (setq n 1))
1372        (t
1373         (setq n (semantic-grammar-anchored-indentation))
1374         (unless (zerop n)
1375           (cond
1376            ((looking-at ";;")
1377             (setq n (1- n)))
1378            ((looking-at "[|;]")
1379             )
1380            (t
1381             (setq n (+ n 2)))))))
1382       (when (/= n indent)
1383         (beginning-of-line)
1384         (delete-horizontal-space)
1385         (indent-to n)))))
1386
1387 (defvar semantic-grammar-brackets-as-parens-syntax-table
1388   (let ((st (copy-syntax-table emacs-lisp-mode-syntax-table)))
1389     (modify-syntax-entry ?\{ "(}  " st)
1390     (modify-syntax-entry ?\} "){  " st)
1391     st)
1392   "Syntax table that consider brackets as parenthesis.
1393 So `lisp-indent-line' will work inside bracket blocks.")
1394
1395 (defun semantic-grammar-do-lisp-indent ()
1396   "Maybe run the Emacs Lisp indenter on a line of code.
1397 Return nil if not in a Lisp expression."
1398     (condition-case nil
1399         (save-excursion
1400           (beginning-of-line)
1401           (skip-chars-forward "\t ")
1402           (let ((first (point)))
1403             (or (>= first (semantic-grammar-epilogue-start))
1404                 (up-list -1))
1405             (condition-case nil
1406                 (while t
1407                   (up-list -1))
1408               (error nil))
1409             (beginning-of-line)
1410             (save-restriction
1411               (narrow-to-region (point) first)
1412               (goto-char (point-max))
1413               (with-syntax-table
1414                   ;; Temporarily consider brackets as parenthesis so
1415                   ;; `lisp-indent-line' can indent Lisp code inside
1416                   ;; brackets.
1417                   semantic-grammar-brackets-as-parens-syntax-table
1418                 (lisp-indent-line))))
1419           t)
1420       (error nil)))
1421
1422 (defun semantic-grammar-indent ()
1423   "Indent the current line.
1424 Use the Lisp or grammar indenter depending on point location."
1425   (interactive)
1426   (let ((orig (point))
1427         first)
1428     (or (semantic-grammar-do-lisp-indent)
1429         (semantic-grammar-do-grammar-indent))
1430     (setq first (save-excursion
1431                   (beginning-of-line)
1432                   (skip-chars-forward "\t ")
1433                   (point)))
1434     (if (or (< orig first) (/= orig (point)))
1435         (goto-char first))))
1436
1437 (defun semantic-grammar-electric-punctuation ()
1438   "Insert and reindent for the symbol just typed in."
1439   (interactive)
1440   (self-insert-command 1)
1441   (save-excursion
1442     (semantic-grammar-indent)))
1443
1444 (defun semantic-grammar-complete ()
1445   "Attempt to complete the symbol under point.
1446 Completion is position sensitive.  If the cursor is in a match section of
1447 a rule, then nonterminals symbols are scanned.  If the cursor is in a Lisp
1448 expression then Lisp symbols are completed."
1449   (interactive)
1450   (if (semantic-grammar-in-lisp-p)
1451       ;; We are in lisp code.  Do lisp completion.
1452       (lisp-complete-symbol)
1453     ;; We are not in lisp code.  Do rule completion.
1454     (let* ((nonterms (semantic-find-tags-by-class 'nonterminal (current-buffer)))
1455            (sym (car (semantic-ctxt-current-symbol)))
1456            (ans (try-completion sym nonterms)))
1457       (cond ((eq ans t)
1458              ;; All done
1459              (message "Symbols is already complete"))
1460             ((and (stringp ans) (string= ans sym))
1461              ;; Max matchable.  Show completions.
1462              (let ((all (all-completions sym nonterms)))
1463                (with-output-to-temp-buffer "*Completions*"
1464                  (display-completion-list (all-completions sym nonterms)))
1465                ))
1466             ((stringp ans)
1467              ;; Expand the completions
1468              (forward-sexp -1)
1469              (delete-region (point) (progn (forward-sexp 1) (point)))
1470              (insert ans))
1471             (t (message "No Completions."))
1472             ))
1473     ))
1474
1475 (defun semantic-grammar-insert-keyword (name)
1476   "Insert a new %keyword declaration with NAME.
1477 Assumes it is typed in with the correct casing."
1478   (interactive "sKeyword: ")
1479   (if (not (bolp)) (insert "\n"))
1480   (insert "%keyword " (upcase name) "        \"" name "\"
1481 %put     " (upcase name) " summary
1482 \"\"\n")
1483   (forward-char -2))
1484
1485 ;;; Macro facilities
1486 ;;
1487
1488 (defsubst semantic--grammar-macro-function-tag (name)
1489   "Search for a function tag for the grammar macro with name NAME.
1490 Return the tag found or nil if not found."
1491   (car (semantic-find-tags-by-class
1492         'function
1493         (or (semantic-find-tags-by-name name (current-buffer))
1494             (and (featurep 'semanticdb)
1495                  semanticdb-current-database
1496                  (cdar (semanticdb-find-tags-by-name name nil t)))))))
1497
1498 (defsubst semantic--grammar-macro-lib-part (def)
1499   "Return the library part of the grammar macro defined by DEF."
1500   (let ((suf (format "-%s\\'" (regexp-quote (symbol-name (car def)))))
1501         (fun (symbol-name (cdr def))))
1502     (substring fun 0 (string-match suf fun))))
1503
1504 (defun semantic--grammar-macro-compl-elt (def &optional full)
1505   "Return a completion entry for the grammar macro defined by DEF.
1506 If optional argument FULL is non-nil qualify the macro name with the
1507 library found in DEF."
1508   (let ((mac (car def))
1509         (lib (semantic--grammar-macro-lib-part def)))
1510     (cons (if full
1511               (format "%s/%s" mac lib)
1512             (symbol-name mac))
1513           (list mac lib))))
1514
1515 (defun semantic--grammar-macro-compl-dict ()
1516   "Return a completion dictionnary of macro definitions."
1517   (let ((defs (semantic-grammar-macros))
1518         def dups dict)
1519     (while defs
1520       (setq def  (car defs)
1521             defs (cdr defs))
1522       (if (or (assoc (car def) defs) (assoc (car def) dups))
1523           (push def dups)
1524         (push (semantic--grammar-macro-compl-elt def) dict)))
1525     (while dups
1526       (setq def  (car dups)
1527             dups (cdr dups))
1528       (push (semantic--grammar-macro-compl-elt def t) dict))
1529     dict))
1530
1531 (defun semantic-grammar-find-macro-expander (macro-name library)
1532   "Visit the Emacs Lisp library where a grammar macro is implemented.
1533 MACRO-NAME is a symbol that identifies a grammar macro.
1534 LIBRARY is the name (sans extension) of the Emacs Lisp library where
1535 to start searching the macro implementation.  Lookup in included
1536 libraries, if necessary.
1537 Find a function tag (in current tags table) whose name contains MACRO-NAME.
1538 Select the buffer containing the tag's definition, and move point there."
1539   (interactive
1540    (let* ((dic (semantic--grammar-macro-compl-dict))
1541           (def (assoc (completing-read "Macro: " dic nil 1) dic)))
1542      (or (cdr def) '(nil nil))))
1543   (when (and macro-name library)
1544     (let* ((lib (format "%s.el" library))
1545            (buf (find-file-noselect (or (locate-library lib t) lib)))
1546            (tag (with-current-buffer buf
1547                   (semantic--grammar-macro-function-tag
1548                    (format "%s-%s" library macro-name)))))
1549       (if tag
1550           (progn
1551             (pop-to-buffer (semantic-tag-buffer tag))
1552             (goto-char (semantic-tag-start tag))
1553             (semantic-momentary-highlight-tag tag))
1554         (pop-to-buffer buf)
1555         (message "No expander found in library %s for macro %s"
1556                  library macro-name)))))
1557
1558 ;;; Additional help
1559 ;;
1560
1561 (defvar semantic-grammar-syntax-help
1562   `(
1563     ;; Lexical Symbols
1564     ("symbol" . "Syntax: A symbol of alpha numeric and symbol characters")
1565     ("number" . "Syntax: Numeric characters.")
1566     ("punctuation" . "Syntax: Punctuation character.")
1567     ("semantic-list" . "Syntax: A list delimited by any valid list characters")
1568     ("open-paren" . "Syntax: Open Parenthesis character")
1569     ("close-paren" . "Syntax: Close Parenthesis character")
1570     ("string" . "Syntax: String character delimited text")
1571     ("comment" . "Syntax: Comment character delimited text")
1572     ;; Special Macros
1573     ("EMPTY" . "Syntax: Match empty text")
1574     ("ASSOC" . "Lambda Key: (ASSOC key1 value1 key2 value2 ...)")
1575     ("EXPAND" . "Lambda Key: (EXPAND <list id> <rule>)")
1576     ("EXPANDFULL" . "Lambda Key: (EXPANDFULL <list id> <rule>)")
1577     ;; Tag Generator Macros
1578     ("TAG" . "Generic Tag Generation: (TAG <name> <tag-class> [ :key value ]*)")
1579     ("VARIABLE-TAG" . "(VARIABLE-TAG <name> <lang-type> <default-value> [ :key value ]*)")
1580     ("FUNCTION-TAG" . "(FUNCTION-TAG <name> <lang-type> <arg-list> [ :key value ]*)")
1581     ("TYPE-TAG" . "(TYPE-TAG <name> <lang-type> <part-list> <parents> [ :key value ]*)")
1582     ("INCLUDE-TAG" . "(INCLUDE-TAG <name> <system-flag> [ :key value ]*)")
1583     ("PACKAGE-TAG" . "(PACKAGE-TAG <name> <detail> [ :key value ]*)")
1584     ("CODE-TAG" . "(CODE-TAG <name> <detail> [ :key value ]*)")
1585     ("ALIAS-TAG" . "(ALIAS-TAG <name> <aliasclass> <definition> [:key value]*)")
1586     ;; Special value macros
1587     ("$1" . "Match Value: Value from match list in slot 1")
1588     ("$2" . "Match Value: Value from match list in slot 2")
1589     ("$3" . "Match Value: Value from match list in slot 3")
1590     ("$4" . "Match Value: Value from match list in slot 4")
1591     ("$5" . "Match Value: Value from match list in slot 5")
1592     ("$6" . "Match Value: Value from match list in slot 6")
1593     ("$7" . "Match Value: Value from match list in slot 7")
1594     ("$8" . "Match Value: Value from match list in slot 8")
1595     ("$9" . "Match Value: Value from match list in slot 9")
1596     ;; Same, but with annoying , in front.
1597     (",$1" . "Match Value: Value from match list in slot 1")
1598     (",$2" . "Match Value: Value from match list in slot 2")
1599     (",$3" . "Match Value: Value from match list in slot 3")
1600     (",$4" . "Match Value: Value from match list in slot 4")
1601     (",$5" . "Match Value: Value from match list in slot 5")
1602     (",$6" . "Match Value: Value from match list in slot 6")
1603     (",$7" . "Match Value: Value from match list in slot 7")
1604     (",$8" . "Match Value: Value from match list in slot 8")
1605     (",$9" . "Match Value: Value from match list in slot 9")
1606     )
1607   "Association of syntax elements, and the corresponding help.")
1608
1609 (eval-when-compile
1610   (require 'eldoc)
1611   (require 'semantic-ctxt)
1612   (cond
1613    ((fboundp 'eldoc-function-argstring-from-docstring)
1614     (defalias 'semantic-grammar-function-argstring-from-docstring
1615       'eldoc-function-argstring-from-docstring)
1616     )
1617    ((fboundp 'help-split-fundoc)
1618     (defsubst semantic-grammar-function-argstring-from-docstring (fun)
1619       (help-split-fundoc (documentation fun t) fun))
1620     )
1621    (t
1622     (defalias 'semantic-grammar-function-argstring-from-docstring
1623       'ignore)
1624     )
1625    ))
1626
1627 (defun semantic-grammar-eldoc-get-macro-docstring (macro expander)
1628   "Return a one-line docstring for the given grammar MACRO.
1629 EXPANDER is the name of the function that expands MACRO."
1630   (if (and (eq expander (aref eldoc-last-data 0))
1631            (eq 'function (aref eldoc-last-data 2)))
1632       (aref eldoc-last-data 1)
1633     (let ((doc (semantic-grammar-function-argstring-from-docstring expander)))
1634       (cond
1635        (doc
1636         (setq doc (car doc))
1637         (string-match "\\`[^ )]* ?" doc)
1638         (setq doc (concat "(" (substring doc (match-end 0)))))
1639        (t
1640         (setq doc (eldoc-function-argstring expander))))
1641       (when doc
1642         (setq doc (eldoc-docstring-format-sym-doc
1643                    macro (format "==> %s %s" expander doc)))
1644         (eldoc-last-data-store expander doc 'function))
1645       doc)))
1646
1647 (define-mode-local-override semantic-idle-summary-current-symbol-info
1648   semantic-grammar-mode ()
1649   "Display additional eldoc information about grammar syntax elements.
1650 Syntax element is the current symbol at point.
1651 If it is associated a help string in `semantic-grammar-syntax-help',
1652 return that string.
1653 If it is a macro name, return a description of the associated expander
1654 function parameter list.
1655 If it is a function name, return a description of this function
1656 parameter list.
1657 It it is a variable name, return a brief (one-line) documentation
1658 string for the variable.
1659 If a default description of the current context can be obtained,
1660 return it.
1661 Otherwise return nil."
1662   (let* ((elt (car (semantic-ctxt-current-symbol)))
1663          (val (and elt (cdr (assoc elt semantic-grammar-syntax-help)))))
1664     (when (and (not val) elt (semantic-grammar-in-lisp-p))
1665       ;; Ensure to load macro definitions before doing `intern-soft'.
1666       (setq val (semantic-grammar-macros)
1667             elt (intern-soft elt)
1668             val (and elt (cdr (assq elt val))))
1669       (cond
1670        ;; Grammar macro
1671        ((and val (fboundp val))
1672         (setq val (semantic-grammar-eldoc-get-macro-docstring elt val)))
1673        ;; Function
1674        ((and elt (fboundp elt))
1675         (setq val (eldoc-get-fnsym-args-string elt)))
1676        ;; Variable
1677        ((and elt (boundp elt))
1678         (setq val (eldoc-get-var-docstring elt)))
1679        (t nil)))
1680     (or val (semantic-idle-summary-current-symbol-info-default))))
1681
1682 (define-mode-local-override semantic-tag-boundary-p
1683   semantic-grammar-mode (tag)
1684   "Return non-nil for tags that should have a boundary drawn.
1685 Only tags of type 'nonterminal will be so marked."
1686   (let ((c (semantic-tag-class tag)))
1687     (eq c 'nonterminal)))
1688
1689 (define-mode-local-override semantic-ctxt-current-function
1690   semantic-grammar-mode (&optional point)
1691   "Determine the name of the current function at POINT."
1692   (save-excursion
1693     (and point (goto-char point))
1694     (when (semantic-grammar-in-lisp-p)
1695       (with-mode-local emacs-lisp-mode
1696         (semantic-ctxt-current-function)))))
1697
1698 (define-mode-local-override semantic-ctxt-current-argument
1699   semantic-grammar-mode (&optional point)
1700   "Determine the argument index of the called function at POINT."
1701   (save-excursion
1702     (and point (goto-char point))
1703     (when (semantic-grammar-in-lisp-p)
1704       (with-mode-local emacs-lisp-mode
1705         (semantic-ctxt-current-argument)))))
1706
1707 (define-mode-local-override semantic-ctxt-current-assignment
1708   semantic-grammar-mode (&optional point)
1709   "Determine the tag being assigned into at POINT."
1710   (save-excursion
1711     (and point (goto-char point))
1712     (when (semantic-grammar-in-lisp-p)
1713       (with-mode-local emacs-lisp-mode
1714         (semantic-ctxt-current-assignment)))))
1715
1716 (define-mode-local-override semantic-ctxt-current-class-list
1717   semantic-grammar-mode (&optional point)
1718   "Determine the class of tags that can be used at POINT."
1719   (save-excursion
1720     (and point (goto-char point))
1721     (if (semantic-grammar-in-lisp-p)
1722         (with-mode-local emacs-lisp-mode
1723           (semantic-ctxt-current-class-list))
1724       '(nonterminal keyword))))
1725
1726 (define-mode-local-override semantic-ctxt-current-mode
1727   semantic-grammar-mode (&optional point)
1728   "Return the major mode active at POINT.
1729 POINT defaults to the value of point in current buffer.
1730 Return `emacs-lisp-mode' is POINT is within Lisp code, otherwise
1731 return the current major mode."
1732   (save-excursion
1733     (and point (goto-char point))
1734     (if (semantic-grammar-in-lisp-p)
1735         'emacs-lisp-mode
1736       (semantic-ctxt-current-mode-default))))
1737
1738 (define-mode-local-override semantic-format-tag-abbreviate
1739   semantic-grammar-mode (tag &optional parent color)
1740   "Return a string abbreviation of TAG.
1741 Optional PARENT is not used.
1742 Optional COLOR is used to flag if color is added to the text."
1743   (let ((class (semantic-tag-class tag))
1744         (name (semantic-format-tag-name tag parent color)))
1745     (cond
1746      ((eq class 'nonterminal)
1747       (concat name ":"))
1748      ((eq class 'setting)
1749       "%settings%")
1750      ((memq class '(rule keyword))
1751       name)
1752      (t
1753       (concat "%" (symbol-name class) " " name)))))
1754
1755 (define-mode-local-override semantic-format-tag-summarize
1756   semantic-grammar-mode (tag &optional parent color)
1757   "Return a string summarizing TAG.
1758 Optional PARENT is not used.
1759 Optional argument COLOR determines if color is added to the text."
1760   (let ((class (semantic-tag-class tag))
1761         (name (semantic-format-tag-name tag parent color))
1762         (label nil)
1763         (desc nil))
1764     (cond
1765      ((eq class 'nonterminal)
1766       (setq label "Nonterminal: "
1767             desc (format
1768                   " with %d match lists."
1769                   (length (semantic-tag-components tag)))))
1770      ((eq class 'keyword)
1771       (setq label "Keyword: ")
1772       (let (summary)
1773         (semantic--find-tags-by-function
1774          #'(lambda (put)
1775              (unless summary
1776                (setq summary (cdr (assoc "summary"
1777                                          (semantic-tag-get-attribute
1778                                           put :value))))))
1779          ;; Get `put' tag with TAG name.
1780          (semantic-find-tags-by-name-regexp
1781           (regexp-quote (semantic-tag-name tag))
1782           (semantic-find-tags-by-class 'put (current-buffer))))
1783         (setq desc (concat " = "
1784                            (semantic-tag-get-attribute tag :value)
1785                            (if summary
1786                                (concat " - " (read summary))
1787                              "")))))
1788      ((eq class 'token)
1789       (setq label "Token: ")
1790       (let ((val   (semantic-tag-get-attribute tag :value))
1791             (names (semantic-tag-get-attribute tag :rest))
1792             (type  (semantic-tag-type tag)))
1793         (if names
1794             (setq name (mapconcat 'identity (cons name names) " ")))
1795         (setq desc (concat
1796                     (if type
1797                         (format " <%s>" type)
1798                       "")
1799                     (if val
1800                         (format "%s%S" val (if type " " ""))
1801                       "")))))
1802      ((eq class 'assoc)
1803       (setq label "Assoc: ")
1804       (let ((val   (semantic-tag-get-attribute tag :value))
1805             (type  (semantic-tag-type tag)))
1806         (setq desc (concat
1807                     (if type
1808                         (format " <%s>" type)
1809                       "")
1810                     (if val
1811                         (concat " " (mapconcat 'identity val " "))
1812                       "")))))
1813      (t
1814       (setq desc (semantic-format-tag-abbreviate tag parent color))))
1815     (if (and color label)
1816         (setq label (semantic--format-colorize-text label 'label)))
1817     (if (and color label desc)
1818         (setq desc (semantic--format-colorize-text desc 'comment)))
1819     (if label
1820         (concat label name desc)
1821       ;; Just a description is the abbreviated version
1822       desc)))
1823
1824 ;;; Semantic Analysis
1825 ;;
1826 (eval-when-compile
1827   (require 'semantic-analyze))
1828
1829 (define-mode-local-override semantic-analyze-current-context
1830   semantic-grammar-mode (point)
1831   "Provide a semantic analysis object describing a context in a grammar."
1832   (if (semantic-grammar-in-lisp-p)
1833       (with-mode-local emacs-lisp-mode
1834         (semantic-analyze-current-context point))
1835
1836     (let* ((context-return nil)
1837            (startpoint (point))
1838            (prefixandbounds (semantic-analyze-calculate-bounds))
1839            (prefix (car prefixandbounds))
1840            (endsym (nth 1 prefixandbounds))
1841            (bounds (nth 2 prefixandbounds))
1842            (prefixsym nil)
1843            (prefixclass (semantic-ctxt-current-class-list))
1844            )
1845
1846       ;; Do context for rules when in a match list.
1847       (setq prefixsym
1848             (semantic-find-first-tag-by-name
1849              (car prefix)
1850              (current-buffer)))
1851
1852       (setq context-return
1853             (semantic-analyze-context
1854              "context-for-semantic-grammar"
1855              :buffer (current-buffer)
1856              :scope nil
1857              :scopetypes nil
1858              :localvariables nil
1859              :bounds bounds
1860              :prefix (if prefixsym
1861                          (list prefixsym)
1862                        prefix)
1863              :prefixtypes nil
1864              :prefixclass prefixclass
1865              ))
1866
1867       context-return)))
1868
1869 (define-mode-local-override semantic-analyze-possible-completions
1870   semantic-grammar-mode (context)
1871   "Return a list of possible completions based on CONTEXT."
1872   (if (semantic-grammar-in-lisp-p)
1873       (with-mode-local emacs-lisp-mode
1874         (semantic-analyze-possible-completions context))
1875     (save-excursion
1876       (set-buffer (oref context buffer))
1877       (let* ((prefix (car (oref context :prefix)))
1878              (completetext (cond ((semantic-tag-p prefix)
1879                                   (semantic-tag-name prefix))
1880                                  ((stringp prefix)
1881                                   prefix)
1882                                  ((stringp (car prefix))
1883                                   (car prefix))))
1884              (tags (semantic-find-tags-for-completion completetext
1885                                                       (current-buffer))))
1886         (semantic-analyze-tags-of-class-list
1887          tags (oref context prefixclass)))
1888       )))
1889
1890 (provide 'semantic-grammar)
1891
1892 ;;; semantic-grammar.el ends here