admin/grammars/wisent-grammar.el

   1 ;;; wisent-grammar.el --- Wisent's input grammar mode
   2
   3 ;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
   4 ;;
   5 ;; Author: David Ponce <david@dponce.com>
   6 ;; Maintainer: David Ponce <david@dponce.com>
   7 ;; Created: 26 Aug 2002
   8 ;; Keywords: syntax
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25 ;;
  26 ;; Major mode for editing Wisent's input grammar (.wy) files.
  27
  28 ;;; Code:
  29 (require 'semantic)
  30 (require 'semantic/grammar)
  31 (require 'semantic/find)
  32 (require 'semantic/lex)
  33 (require 'semantic/wisent)
  34 (require 'semantic/bovine)
  35
  36 (defsubst wisent-grammar-region-placeholder (symb)
  37   "Given a $N placeholder symbol in SYMB, return a $regionN symbol.
  38 Return nil if $N is not a valid placeholder symbol."
  39   (let ((n (symbol-name symb)))
  40     (if (string-match "^[$]\\([1-9][0-9]*\\)$" n)
  41         (intern (concat "$region" (match-string 1 n))))))
  42
  43 (defun wisent-grammar-EXPAND (symb nonterm)
  44   "Expand call to EXPAND grammar macro.
  45 Return the form to parse from within a nonterminal.
  46 SYMB is a $I placeholder symbol that gives the bounds of the area to
  47 parse.
  48 NONTERM is the nonterminal symbol to start with."
  49   (unless (member nonterm (semantic-grammar-start))
  50     (error "EXPANDFULL macro called with %s, but not used with %%start"
  51            nonterm))
  52   (let (($ri (wisent-grammar-region-placeholder symb)))
  53     (if $ri
  54         `(semantic-bovinate-from-nonterminal
  55           (car ,$ri) (cdr ,$ri) ',nonterm)
  56       (error "Invalid form (EXPAND %s %s)" symb nonterm))))
  57
  58 (defun wisent-grammar-EXPANDFULL (symb nonterm)
  59   "Expand call to EXPANDFULL grammar macro.
  60 Return the form to recursively parse an area.
  61 SYMB is a $I placeholder symbol that gives the bounds of the area.
  62 NONTERM is the nonterminal symbol to start with."
  63   (unless (member nonterm (semantic-grammar-start))
  64     (error "EXPANDFULL macro called with %s, but not used with %%start"
  65            nonterm))
  66   (let (($ri (wisent-grammar-region-placeholder symb)))
  67     (if $ri
  68         `(semantic-parse-region
  69           (car ,$ri) (cdr ,$ri) ',nonterm 1)
  70       (error "Invalid form (EXPANDFULL %s %s)" symb nonterm))))
  71
  72 (defun wisent-grammar-TAG (name class &rest attributes)
  73   "Expand call to TAG grammar macro.
  74 Return the form to create a generic semantic tag.
  75 See the function `semantic-tag' for the meaning of arguments NAME,
  76 CLASS and ATTRIBUTES."
  77   `(wisent-raw-tag
  78     (semantic-tag ,name ,class ,@attributes)))
  79
  80 (defun wisent-grammar-VARIABLE-TAG (name type default-value &rest attributes)
  81   "Expand call to VARIABLE-TAG grammar macro.
  82 Return the form to create a semantic tag of class variable.
  83 See the function `semantic-tag-new-variable' for the meaning of
  84 arguments NAME, TYPE, DEFAULT-VALUE and ATTRIBUTES."
  85   `(wisent-raw-tag
  86     (semantic-tag-new-variable ,name ,type ,default-value ,@attributes)))
  87
  88 (defun wisent-grammar-FUNCTION-TAG (name type arg-list &rest attributes)
  89   "Expand call to FUNCTION-TAG grammar macro.
  90 Return the form to create a semantic tag of class function.
  91 See the function `semantic-tag-new-function' for the meaning of
  92 arguments NAME, TYPE, ARG-LIST and ATTRIBUTES."
  93   `(wisent-raw-tag
  94     (semantic-tag-new-function ,name ,type ,arg-list ,@attributes)))
  95
  96 (defun wisent-grammar-TYPE-TAG (name type members parents &rest attributes)
  97   "Expand call to TYPE-TAG grammar macro.
  98 Return the form to create a semantic tag of class type.
  99 See the function `semantic-tag-new-type' for the meaning of arguments
 100 NAME, TYPE, MEMBERS, PARENTS and ATTRIBUTES."
 101   `(wisent-raw-tag
 102     (semantic-tag-new-type ,name ,type ,members ,parents ,@attributes)))
 103
 104 (defun wisent-grammar-INCLUDE-TAG (name system-flag &rest attributes)
 105   "Expand call to INCLUDE-TAG grammar macro.
 106 Return the form to create a semantic tag of class include.
 107 See the function `semantic-tag-new-include' for the meaning of
 108 arguments NAME, SYSTEM-FLAG and ATTRIBUTES."
 109   `(wisent-raw-tag
 110     (semantic-tag-new-include ,name ,system-flag ,@attributes)))
 111
 112 (defun wisent-grammar-PACKAGE-TAG (name detail &rest attributes)
 113   "Expand call to PACKAGE-TAG grammar macro.
 114 Return the form to create a semantic tag of class package.
 115 See the function `semantic-tag-new-package' for the meaning of
 116 arguments NAME, DETAIL and ATTRIBUTES."
 117   `(wisent-raw-tag
 118     (semantic-tag-new-package ,name ,detail ,@attributes)))
 119
 120 (defun wisent-grammar-CODE-TAG (name detail &rest attributes)
 121   "Expand call to CODE-TAG grammar macro.
 122 Return the form to create a semantic tag of class code.
 123 See the function `semantic-tag-new-code' for the meaning of arguments
 124 NAME, DETAIL and ATTRIBUTES."
 125   `(wisent-raw-tag
 126     (semantic-tag-new-code ,name ,detail ,@attributes)))
 127
 128 (defun wisent-grammar-ALIAS-TAG (name aliasclass definition &rest attributes)
 129   "Expand call to ALIAS-TAG grammar macro.
 130 Return the form to create a semantic tag of class alias.
 131 See the function `semantic-tag-new-alias' for the meaning of arguments
 132 NAME, ALIASCLASS, DEFINITION and ATTRIBUTES."
 133   `(wisent-raw-tag
 134     (semantic-tag-new-alias ,name ,aliasclass ,definition ,@attributes)))
 135
 136 (defun wisent-grammar-EXPANDTAG (raw-tag)
 137   "Expand call to EXPANDTAG grammar macro.
 138 Return the form to produce a list of cooked tags from raw form of
 139 Semantic tag RAW-TAG."
 140   `(wisent-cook-tag ,raw-tag))
 141
 142 (defun wisent-grammar-AST-ADD (ast &rest nodes)
 143   "Expand call to AST-ADD grammar macro.
 144 Return the form to update the abstract syntax tree AST with NODES.
 145 See also the function `semantic-ast-add'."
 146   `(semantic-ast-add ,ast ,@nodes))
 147
 148 (defun wisent-grammar-AST-PUT (ast &rest nodes)
 149   "Expand call to AST-PUT grammar macro.
 150 Return the form to update the abstract syntax tree AST with NODES.
 151 See also the function `semantic-ast-put'."
 152   `(semantic-ast-put ,ast ,@nodes))
 153
 154 (defun wisent-grammar-AST-GET (ast node)
 155   "Expand call to AST-GET grammar macro.
 156 Return the form to get, from the abstract syntax tree AST, the value
 157 of NODE.
 158 See also the function `semantic-ast-get'."
 159   `(semantic-ast-get ,ast ,node))
 160
 161 (defun wisent-grammar-AST-GET1 (ast node)
 162   "Expand call to AST-GET1 grammar macro.
 163 Return the form to get, from the abstract syntax tree AST, the first
 164 value of NODE.
 165 See also the function `semantic-ast-get1'."
 166   `(semantic-ast-get1 ,ast ,node))
 167
 168 (defun wisent-grammar-AST-GET-STRING (ast node)
 169   "Expand call to AST-GET-STRING grammar macro.
 170 Return the form to get, from the abstract syntax tree AST, the value
 171 of NODE as a string.
 172 See also the function `semantic-ast-get-string'."
 173   `(semantic-ast-get-string ,ast ,node))
 174
 175 (defun wisent-grammar-AST-MERGE (ast1 ast2)
 176   "Expand call to AST-MERGE grammar macro.
 177 Return the form to merge the abstract syntax trees AST1 and AST2.
 178 See also the function `semantic-ast-merge'."
 179   `(semantic-ast-merge ,ast1 ,ast2))
 180
 181 (defun wisent-grammar-SKIP-BLOCK (&optional symb)
 182   "Expand call to SKIP-BLOCK grammar macro.
 183 Return the form to skip a parenthesized block.
 184 Optional argument SYMB is a $I placeholder symbol that gives the
 185 bounds of the block to skip.  By default, skip the block at `$1'.
 186 See also the function `wisent-skip-block'."
 187   (let ($ri)
 188     (when symb
 189       (unless (setq $ri (wisent-grammar-region-placeholder symb))
 190         (error "Invalid form (SKIP-BLOCK %s)" symb)))
 191     `(wisent-skip-block ,$ri)))
 192
 193 (defun wisent-grammar-SKIP-TOKEN ()
 194   "Expand call to SKIP-TOKEN grammar macro.
 195 Return the form to skip the lookahead token.
 196 See also the function `wisent-skip-token'."
 197   `(wisent-skip-token))
 198
 199 (defun wisent-grammar-assocs ()
 200   "Return associativity and precedence level definitions."
 201   (mapcar
 202    #'(lambda (tag)
 203        (cons (intern (semantic-tag-name tag))
 204              (mapcar #'semantic-grammar-item-value
 205                      (semantic-tag-get-attribute tag :value))))
 206    (semantic-find-tags-by-class 'assoc (current-buffer))))
 207
 208 (defun wisent-grammar-terminals ()
 209   "Return the list of terminal symbols.
 210 Keep order of declaration in the WY file without duplicates."
 211   (let (terms)
 212     (mapcar
 213      #'(lambda (tag)
 214          (mapcar #'(lambda (name)
 215                      (add-to-list 'terms (intern name)))
 216                  (cons (semantic-tag-name tag)
 217                        (semantic-tag-get-attribute tag :rest))))
 218      (semantic--find-tags-by-function
 219       #'(lambda (tag)
 220           (memq (semantic-tag-class tag) '(token keyword)))
 221       (current-buffer)))
 222     (nreverse terms)))
 223
 224 ;; Cache of macro definitions currently in use.
 225 (defvar wisent--grammar-macros nil)
 226
 227 (defun wisent-grammar-expand-macros (expr)
 228   "Expand expression EXPR into a form without grammar macros.
 229 Return the expanded expression."
 230   (if (or (atom expr) (semantic-grammar-quote-p (car expr)))
 231       expr ;; Just return atom or quoted expression.
 232     (let* ((expr  (mapcar 'wisent-grammar-expand-macros expr))
 233            (macro (assq (car expr) wisent--grammar-macros)))
 234       (if macro ;; Expand Semantic built-in.
 235           (apply (cdr macro) (cdr expr))
 236         expr))))
 237
 238 (defun wisent-grammar-nonterminals ()
 239   "Return the list form of nonterminal definitions."
 240   (let ((nttags (semantic-find-tags-by-class
 241                  'nonterminal (current-buffer)))
 242         ;; Setup the cache of macro definitions.
 243         (wisent--grammar-macros (semantic-grammar-macros))
 244         rltags nterms rules rule elems elem actn sexp prec)
 245     (while nttags
 246       (setq rltags (semantic-tag-components (car nttags))
 247             rules  nil)
 248       (while rltags
 249         (setq elems (semantic-tag-get-attribute (car rltags) :value)
 250               prec  (semantic-tag-get-attribute (car rltags) :prec)
 251               actn  (semantic-tag-get-attribute (car rltags) :expr)
 252               rule  nil)
 253         (when elems ;; not an EMPTY rule
 254           (while elems
 255             (setq elem  (car elems)
 256                   elems (cdr elems))
 257             (setq elem (if (consp elem) ;; mid-rule action
 258                            (wisent-grammar-expand-macros (read (car elem)))
 259                          (semantic-grammar-item-value elem)) ;; item
 260                   rule (cons elem rule)))
 261           (setq rule (nreverse rule)))
 262         (if prec
 263             (setq prec (vector (semantic-grammar-item-value prec))))
 264         (if actn
 265             (setq sexp (wisent-grammar-expand-macros (read actn))))
 266         (setq rule (if actn
 267                        (if prec
 268                            (list rule prec sexp)
 269                          (list rule sexp))
 270                      (if prec
 271                          (list rule prec)
 272                        (list rule))))
 273         (setq rules (cons rule rules)
 274               rltags (cdr rltags)))
 275       (setq nterms (cons (cons (intern (semantic-tag-name (car nttags)))
 276                                (nreverse rules))
 277                          nterms)
 278             nttags (cdr nttags)))
 279     (nreverse nterms)))
 280
 281 (defun wisent-grammar-grammar ()
 282   "Return Elisp form of the grammar."
 283   (let* ((terminals    (wisent-grammar-terminals))
 284          (nonterminals (wisent-grammar-nonterminals))
 285          (assocs       (wisent-grammar-assocs)))
 286     (cons terminals (cons assocs nonterminals))))
 287
 288 (defun wisent-grammar-parsetable-builder ()
 289   "Return the value of the parser table."
 290   `(progn
 291      ;; Ensure that the grammar [byte-]compiler is available.
 292      (eval-when-compile (require 'semantic/wisent/comp))
 293      (wisent-compile-grammar
 294       ',(wisent-grammar-grammar)
 295       ',(semantic-grammar-start))))
 296
 297 (defun wisent-grammar-setupcode-builder ()
 298   "Return the parser setup code."
 299   (format
 300    "(semantic-install-function-overrides\n\
 301       '((parse-stream . wisent-parse-stream)))\n\
 302     (setq semantic-parser-name \"LALR\"\n\
 303           semantic--parse-table %s\n\
 304           semantic-debug-parser-source %S\n\
 305           semantic-flex-keywords-obarray %s\n\
 306           semantic-lex-types-obarray %s)\n\
 307     ;; Collect unmatched syntax lexical tokens\n\
 308     (semantic-make-local-hook 'wisent-discarding-token-functions)\n\
 309     (add-hook 'wisent-discarding-token-functions\n\
 310               'wisent-collect-unmatched-syntax nil t)"
 311    (semantic-grammar-parsetable)
 312    (buffer-name)
 313    (semantic-grammar-keywordtable)
 314    (semantic-grammar-tokentable)))
 315
 316 (defvar wisent-grammar-menu
 317   '("WY Grammar"
 318     ["LALR Compiler Verbose" wisent-toggle-verbose-flag
 319      :style toggle :active (boundp 'wisent-verbose-flag)
 320      :selected (and (boundp 'wisent-verbose-flag)
 321                     wisent-verbose-flag)]
 322     )
 323   "WY mode specific grammar menu.
 324 Menu items are appended to the common grammar menu.")
 325
 326 (define-derived-mode wisent-grammar-mode semantic-grammar-mode "WY"
 327   "Major mode for editing Wisent grammars."
 328   (semantic-grammar-setup-menu wisent-grammar-menu)
 329   (semantic-install-function-overrides
 330    '((grammar-parsetable-builder . wisent-grammar-parsetable-builder)
 331      (grammar-setupcode-builder  . wisent-grammar-setupcode-builder)
 332      )))
 333
 334 (add-to-list 'auto-mode-alist '("\\.wy$" . wisent-grammar-mode))
 335
 336 (defvar-mode-local wisent-grammar-mode semantic-grammar-macros
 337   '(
 338     (ASSOC          . semantic-grammar-ASSOC)
 339     (EXPAND         . wisent-grammar-EXPAND)
 340     (EXPANDFULL     . wisent-grammar-EXPANDFULL)
 341     (TAG            . wisent-grammar-TAG)
 342     (VARIABLE-TAG   . wisent-grammar-VARIABLE-TAG)
 343     (FUNCTION-TAG   . wisent-grammar-FUNCTION-TAG)
 344     (TYPE-TAG       . wisent-grammar-TYPE-TAG)
 345     (INCLUDE-TAG    . wisent-grammar-INCLUDE-TAG)
 346     (PACKAGE-TAG    . wisent-grammar-PACKAGE-TAG)
 347     (EXPANDTAG      . wisent-grammar-EXPANDTAG)
 348     (CODE-TAG       . wisent-grammar-CODE-TAG)
 349     (ALIAS-TAG      . wisent-grammar-ALIAS-TAG)
 350     (AST-ADD        . wisent-grammar-AST-ADD)
 351     (AST-PUT        . wisent-grammar-AST-PUT)
 352     (AST-GET        . wisent-grammar-AST-GET)
 353     (AST-GET1       . wisent-grammar-AST-GET1)
 354     (AST-GET-STRING . wisent-grammar-AST-GET-STRING)
 355     (AST-MERGE      . wisent-grammar-AST-MERGE)
 356     (SKIP-BLOCK     . wisent-grammar-SKIP-BLOCK)
 357     (SKIP-TOKEN     . wisent-grammar-SKIP-TOKEN)
 358     )
 359   "Semantic grammar macros used in wisent grammars.")
 360
 361 ;;; wisent-grammar.el ends here