code.delx.au - gnu-emacs-elpa/blob - packages/wisi/wisi-parse.el

   1 ;;; wisi-parse.el --- Wisi parser
   2
   3 ;; Copyright (C) 2013  Free Software Foundation, Inc.
   4
   5 ;; This file is part of GNU Emacs.
   6
   7 ;; GNU Emacs is free software: you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation, either version 3 of the License, or
  10 ;; (at your option) any later version.
  11
  12 ;; GNU Emacs is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  19
  20
  21 ;;; Commentary:
  22
  23 ;; An extended LALR parser, that handles shift/reduce and
  24 ;; reduce/reduce conflicts by spawning parallel parsers to follow each
  25 ;; path.
  26
  27 ;;; Code:
  28
  29 (require 'semantic/wisent)
  30 (eval-when-compile (require 'cl-lib))
  31
  32 (cl-defstruct (wisi-parser-state
  33             (:copier nil))
  34   label ;; integer identifying parser for debug
  35
  36   active
  37   ;; 'shift  - need new token
  38   ;; 'reduce - need reduce
  39   ;; 'accept - parsing completed
  40   ;; 'error  - failed, error not reported yet
  41   ;; nil     - terminated
  42   ;;
  43   ;; 'pending-shift, 'pending-reduce - newly created parser; see wisi-parse
  44
  45   stack
  46   ;; Each stack item takes two slots: (token-symbol token-text (token-start . token-end)), state
  47   ;; token-text is nil for nonterminals.
  48   ;; this is _not_ the same as the wisent-parse stack; that leaves out token-symbol.
  49
  50   sp ;; stack pointer
  51
  52   pending
  53   ;; list of (action-symbol stack-fragment)
  54   )
  55
  56 (defun wisi-error-msg (message &rest args)
  57   (let ((line (line-number-at-pos))
  58         (col (- (point) (line-beginning-position))))
  59     (format
  60      "%s:%d:%d: %s"
  61        (file-name-nondirectory (buffer-name)) ;; buffer-file-name is sometimes nil here!?
  62        line col
  63        (apply 'format message args))))
  64
  65 (defvar wisi-parse-error nil)
  66 (put 'wisi-parse-error
  67      'error-conditions
  68      '(error wisi-parse-error))
  69 (put 'wisi-parse-error
  70      'error-message
  71      "wisi parse error")
  72
  73 (defvar wisi-parse-max-parallel 15
  74   "Maximum number of parallel parsers for acceptable performance.
  75 If a file needs more than this, it's probably an indication that
  76 the grammar is excessively redundant.")
  77
  78 (defvar wisi-debug 0
  79   "wisi debug mode:
  80 0 : normal - ignore parse errors, for indenting new code
  81 1 : report parse errors (for running tests)
  82 2 : show parse states, position point at parse errors, debug-on-error works in parser
  83 3 : also show top 10 items of parser stack.")
  84
  85 (defun wisi-parse (automaton lexer)
  86   "Parse input using the automaton specified in AUTOMATON.
  87
  88 - AUTOMATON is the parse table generated by `wisi-compile-grammar'.
  89
  90 - LEXER is a function with no argument called by the parser to
  91   obtain the next token in input, as a list (symbol text start
  92   . end), where `symbol' is the terminal symbol, `text' is the
  93   token string, `start . end' is the range in the buffer."
  94   (let* ((actions (aref automaton 0))
  95          (gotos   (aref automaton 1))
  96          (parser-states ;; vector of parallel parser states
  97           (vector
  98            (make-wisi-parser-state
  99             :label 0
 100             :active  'shift
 101             :stack   (make-vector wisent-parse-max-stack-size nil)
 102             ;; FIXME: better error message when stack overflows, so
 103             ;; user can set wisent-parse-max-stack-size in file-local
 104             ;; vars.
 105             :sp      0
 106             :pending nil)))
 107          (active-parser-count 1)
 108          active-parser-count-prev
 109          (active 'shift)
 110          (token (funcall lexer))
 111          some-pending)
 112
 113     (aset (wisi-parser-state-stack (aref parser-states 0)) 0 0) ;; Initial state
 114
 115     (while (not (eq active 'accept))
 116       (setq active-parser-count-prev active-parser-count)
 117       (setq some-pending nil)
 118       (dotimes (parser-index (length parser-states))
 119         (when (eq active (wisi-parser-state-active (aref parser-states parser-index)))
 120           (let* ((parser-state (aref parser-states parser-index))
 121                  (result (wisi-parse-1 token parser-state (> active-parser-count 1) actions gotos)))
 122             (when result
 123               ;; spawn a new parser
 124               (when (= active-parser-count wisi-parse-max-parallel)
 125                 (signal 'wisi-parse-error
 126                         (wisi-error-msg (concat "too many parallel parsers required;"
 127                                                 " simplify grammar, or increase `wisi-parse-max-parallel'"))))
 128               (let ((j (wisi-free-parser parser-states)))
 129                 (cond
 130                  ((= j -1)
 131                   ;; Add to parser-states; the new parser won't be executed
 132                   ;; again in this parser-index loop.
 133                   (setq parser-states (vconcat parser-states (vector nil)))
 134                   (setq j (1- (length parser-states))))
 135                  ((< j parser-index)
 136                   ;; The new parser won't be executed again in this
 137                   ;; parser-index loop; nothing to do.
 138                   )
 139                  (t
 140                   ;; Don't let the new parser execute again in this
 141                   ;; parser-index loop.
 142                   (setq some-pending t)
 143                   (setf (wisi-parser-state-active result)
 144                         (cl-case (wisi-parser-state-active result)
 145                           (shift 'pending-shift)
 146                           (reduce 'pending-reduce)
 147                          )))
 148                   )
 149                 (setq active-parser-count (1+ active-parser-count))
 150                 (setf (wisi-parser-state-label result) j)
 151                 (aset parser-states j result))
 152               (when (> wisi-debug 1)
 153                 (message "spawn parser (%d active)" active-parser-count)))
 154
 155             (when (eq 'error (wisi-parser-state-active parser-state))
 156               (setq active-parser-count (1- active-parser-count))
 157               (when (> wisi-debug 1)
 158                 (message "terminate parser (%d active)" active-parser-count))
 159               (cl-case active-parser-count
 160                 (0
 161                  (cond
 162                   ((= active-parser-count-prev 1)
 163                    ;; We were not in a parallel parse; report the error.
 164                    (let ((state (aref (wisi-parser-state-stack parser-state)
 165                                       (wisi-parser-state-sp parser-state))))
 166                      (signal 'wisi-parse-error
 167                              (wisi-error-msg "syntax error in grammar state %d; unexpected %s, expecting one of %s"
 168                                              state
 169                                              (nth 1 token)
 170                                              (mapcar 'car (aref actions state))))
 171                      ))
 172                   (t
 173                    ;; Report errors from all parsers that failed on this token.
 174                    (let ((msg))
 175                      (dotimes (_ (length parser-states))
 176                        (let* ((parser-state (aref parser-states parser-index))
 177                               (state (aref (wisi-parser-state-stack parser-state)
 178                                            (wisi-parser-state-sp parser-state))))
 179                          (when (eq 'error (wisi-parser-state-active parser-state))
 180                            (setq msg
 181                                  (concat msg
 182                                          (when msg "\n")
 183                                          (wisi-error-msg
 184                                           "syntax error in grammar state %d; unexpected %s, expecting one of %s"
 185                                           state
 186                                           (nth 1 token)
 187                                           (mapcar 'car (aref actions state)))))
 188                            )))
 189                      (signal 'wisi-parse-error msg)))
 190                   ))
 191
 192                 (1
 193                  (setf (wisi-parser-state-active parser-state) nil); Don't save error for later.
 194                  (wisi-execute-pending (wisi-parser-state-pending
 195                                         (aref parser-states (wisi-active-parser parser-states))))
 196                  (setf (wisi-parser-state-pending
 197                         (aref parser-states (wisi-active-parser parser-states)))
 198                        nil))
 199                 (t
 200                  ;; We were in a parallel parse, and this parser
 201                  ;; failed; mark it inactive, don't save error for
 202                  ;; later.
 203                  (setf (wisi-parser-state-active parser-state) nil)
 204                  )))
 205             )));; end dotimes
 206
 207       (when some-pending
 208         ;; Change pending-* parsers to *.
 209         (dotimes (parser-index (length parser-states))
 210           (cond
 211            ((eq (wisi-parser-state-active (aref parser-states parser-index)) 'pending-shift)
 212             (setf (wisi-parser-state-active (aref parser-states parser-index)) 'shift))
 213            ((eq (wisi-parser-state-active (aref parser-states parser-index)) 'pending-reduce)
 214             (setf (wisi-parser-state-active (aref parser-states parser-index)) 'reduce))
 215            )))
 216
 217       (setq active (wisi-parsers-active parser-states active-parser-count))
 218       (when (eq active 'shift)
 219         (when (> active-parser-count 1)
 220           (setq active-parser-count (wisi-parse-elim-identical parser-states active-parser-count)))
 221         (setq token (funcall lexer)))
 222     )
 223     (when (> active-parser-count 1)
 224       (error "ambiguous parse result"))))
 225
 226 (defun wisi-parsers-active (parser-states active-count)
 227   "Return the type of parser cycle to execute.
 228 PARSER-STATES[*].active is the last action a parser took. If it
 229 was 'shift, that parser used the input token, and should not be
 230 executed again until another input token is available, after all
 231 parsers have shifted the current token or terminated.
 232
 233 'accept : all PARSER-STATES have active set to nil or 'accept -
 234 done parsing
 235
 236 'shift : all PARSER-STATES have active set to nil, 'accept, or
 237 'shift - get a new token, execute 'shift parsers.
 238
 239 'reduce : some PARSER-STATES have active set to 'reduce - no new
 240 token, execute 'reduce parsers."
 241   (let ((result nil)
 242         (i 0)
 243         (shift-count 0)
 244         (accept-count 0)
 245         active)
 246     (while (and (not result)
 247                 (< i (length parser-states)))
 248       (setq active (wisi-parser-state-active (aref parser-states i)))
 249       (cond
 250         ((eq active 'shift) (setq shift-count (1+ shift-count)))
 251         ((eq active 'reduce) (setq result 'reduce))
 252         ((eq active 'accept) (setq accept-count (1+ accept-count)))
 253         )
 254       (setq i (1+ i)))
 255
 256     (cond
 257      (result )
 258      ((= accept-count active-count)
 259       'accept)
 260      ((= (+ shift-count accept-count) active-count)
 261       'shift)
 262      (t (error "unexpected result in wisi-parsers-active"))
 263      )))
 264
 265 (defun wisi-free-parser (parser-states)
 266   "Return index to a non-active parser in PARSER-STATES, -1 if there is none."
 267   (let ((result nil)
 268         (i 0))
 269     (while (and (not result)
 270                 (< i (length parser-states)))
 271       (when (not (wisi-parser-state-active (aref parser-states i)))
 272         (setq result i))
 273       (setq i (1+ i)))
 274     (if result result -1)))
 275
 276 (defun wisi-active-parser (parser-states)
 277   "Return index to the first active parser in PARSER-STATES."
 278   (let ((result nil)
 279         (i 0))
 280     (while (and (not result)
 281                 (< i (length parser-states)))
 282       (when (wisi-parser-state-active (aref parser-states i))
 283         (setq result i))
 284       (setq i (1+ i)))
 285     (unless result
 286       (error "no active parsers"))
 287     result))
 288
 289 (defun wisi-parse-elim-identical (parser-states active-parser-count)
 290   "Check for parsers in PARSER-STATES that have reached identical states eliminate one.
 291 Return new ACTIVE-PARSER-COUNT. Assumes all parsers have active
 292 nil, 'shift, or 'accept."
 293   ;; parser-states passed by reference; active-parser-count by copy
 294   ;; see test/ada_mode-slices.adb for example
 295   (dotimes (parser-i (1- (length parser-states)))
 296     (when (wisi-parser-state-active (aref parser-states parser-i))
 297       (dotimes (parser-j (- (length parser-states) parser-i 1))
 298         (when (wisi-parser-state-active (aref parser-states (+ parser-i parser-j 1)))
 299           (when (eq (wisi-parser-state-sp (aref parser-states parser-i))
 300                      (wisi-parser-state-sp (aref parser-states (+ parser-i parser-j 1))))
 301             (let ((compare t))
 302               (dotimes (stack-i (wisi-parser-state-sp (aref parser-states parser-i)))
 303                 (setq
 304                  compare
 305                  (and compare
 306                       (equal (aref (wisi-parser-state-stack (aref parser-states parser-i)) stack-i)
 307                              (aref (wisi-parser-state-stack (aref parser-states (+ parser-i parser-j 1))) stack-i)))))
 308               (when compare
 309                 ;; parser stacks are identical
 310                 (setq active-parser-count (1- active-parser-count))
 311                 (when (> wisi-debug 1)
 312                   (message "terminate identical parser %d (%d active)"
 313                            (+ parser-i parser-j 1) active-parser-count))
 314                 (when (= active-parser-count 1)
 315                   ;; the actions for the two parsers are not
 316                   ;; identical, but either is good enough for
 317                   ;; indentation and navigation, so we just do one.
 318                   (when (> wisi-debug 1) (message "executing actions for %d" (+ parser-i parser-j 1)))
 319                   (wisi-execute-pending (wisi-parser-state-pending (aref parser-states (+ parser-i parser-j 1))))
 320                   (setf (wisi-parser-state-pending (aref parser-states (+ parser-i parser-j 1))) nil)
 321
 322                   ;; clear pending of other parser so it can be reused
 323                   (setf (wisi-parser-state-pending (aref parser-states parser-i)) nil))
 324
 325                 (setf (wisi-parser-state-active (aref parser-states (+ parser-i parser-j 1))) nil))
 326               )))
 327         )))
 328   active-parser-count)
 329
 330 (defun wisi-execute-pending (pending)
 331   (while pending
 332     (when (> wisi-debug 1) (message "%s" (car pending)))
 333     (apply (pop pending))))
 334
 335 (defun wisi-parse-1 (token parser-state pendingp actions gotos)
 336   "Perform one shift or reduce on PARSER-STATE.
 337 If PENDINGP, push actions onto PARSER-STATE.pending; otherwise execute them.
 338 See `wisi-parse' for full details.
 339 Return nil or new parser (a wisi-parse-state struct)."
 340   (let* ((state (aref (wisi-parser-state-stack parser-state)
 341                 (wisi-parser-state-sp parser-state)))
 342          (parse-action (wisent-parse-action (car token) (aref actions state)))
 343          new-parser-state)
 344
 345     (when (> wisi-debug 1)
 346       ;; output trace info
 347       (if (> wisi-debug 2)
 348           (progn
 349             ;; put top 10 stack items
 350             (let* ((count (min 20 (wisi-parser-state-sp parser-state)))
 351                    (msg (make-vector (+ 1 count) nil)))
 352               (dotimes (i count)
 353                 (aset msg (- count i)
 354                       (aref (wisi-parser-state-stack parser-state) (- (wisi-parser-state-sp parser-state) i)))
 355                 )
 356               (message "%d: %s: %d: %s"
 357                        (wisi-parser-state-label parser-state)
 358                        (wisi-parser-state-active parser-state)
 359                        (wisi-parser-state-sp parser-state)
 360                        msg))
 361             (message "   %d: %s: %s" state token parse-action))
 362         (message "%d: %d: %s: %s" (wisi-parser-state-label parser-state) state token parse-action)))
 363
 364     (when (and (listp parse-action)
 365                (not (symbolp (car parse-action))))
 366       ;; Conflict; spawn a new parser.
 367       (setq new-parser-state
 368             (make-wisi-parser-state
 369              :active  nil
 370              :stack   (vconcat (wisi-parser-state-stack parser-state))
 371              :sp      (wisi-parser-state-sp parser-state)
 372              :pending (wisi-parser-state-pending parser-state)))
 373
 374       (wisi-parse-2 (cadr parse-action) token new-parser-state t gotos)
 375       (setq pendingp t)
 376       (setq parse-action (car parse-action))
 377       );; when
 378
 379     ;; current parser
 380     (wisi-parse-2 parse-action token parser-state pendingp gotos)
 381
 382     new-parser-state))
 383
 384 (defun wisi-parse-2 (action token parser-state pendingp gotos)
 385   "Execute parser ACTION (must not be a conflict).
 386 Return nil."
 387   (cond
 388    ((eq action 'accept)
 389     (setf (wisi-parser-state-active parser-state) 'accept))
 390
 391    ((eq action 'error)
 392     (setf (wisi-parser-state-active parser-state) 'error))
 393
 394    ((natnump action)
 395     ;; Shift token and new state (= action) onto stack
 396     (let ((stack (wisi-parser-state-stack parser-state)); reference
 397           (sp (wisi-parser-state-sp parser-state))); copy
 398       (setq sp (+ sp 2))
 399       (aset stack (1- sp) token)
 400       (aset stack sp action)
 401       (setf (wisi-parser-state-sp parser-state) sp))
 402     (setf (wisi-parser-state-active parser-state) 'shift))
 403
 404    (t
 405     (wisi-parse-reduce action parser-state pendingp gotos)
 406     (setf (wisi-parser-state-active parser-state) 'reduce))
 407    ))
 408
 409 (defun wisi-nonterm-bounds (stack i j)
 410   "Return a pair (START . END), the buffer region for a nonterminal.
 411 STACK is the parser stack.  I and J are the indices in STACK of
 412 the first and last tokens of the nonterminal."
 413   (let ((start (cl-caddr (aref stack i)))
 414         (end   (cl-cdddr (aref stack j))))
 415     (while (and (or (not start) (not end))
 416                 (/= i j))
 417       (cond
 418        ((not start)
 419         ;; item i is an empty production
 420         (setq start (cl-caddr (aref stack (setq i (+ i 2))))))
 421
 422        ((not end)
 423         ;; item j is an empty production
 424         (setq end (cl-cdddr (aref stack (setq j (- j 2))))))
 425
 426        (t (setq i j))))
 427     (and start end (cons start end))))
 428
 429 (defun wisi-parse-reduce (action parser-state pendingp gotos)
 430   "Reduce PARSER-STATE.stack, and execute or pend ACTION."
 431   (let* ((stack (wisi-parser-state-stack parser-state)); reference
 432          (sp (wisi-parser-state-sp parser-state)); copy
 433          (token-count (or (nth 2 action) 0))
 434          (nonterm (nth 0 action))
 435          (nonterm-region (when (> token-count 0)
 436                            (wisi-nonterm-bounds stack (- sp (* 2 (1- token-count)) 1) (1- sp))))
 437          (post-reduce-state (aref stack (- sp (* 2 token-count))))
 438          (new-state (cdr (assoc nonterm (aref gotos post-reduce-state))))
 439          tokens)
 440     (when (not new-state)
 441       (error "no goto for %s %d" nonterm post-reduce-state))
 442     (if (= 1 token-count)
 443         (setq tokens (list (aref stack (1- sp))))
 444       (dotimes (i token-count)
 445         (push (aref stack (- sp (* 2 i) 1)) tokens)))
 446     (setq sp (+ 2 (- sp (* 2 token-count))))
 447     (aset stack (1- sp) (cons nonterm (cons nil nonterm-region)))
 448     (aset stack sp new-state)
 449     (setf (wisi-parser-state-sp parser-state) sp)
 450     (if pendingp
 451         (if (wisi-parser-state-pending parser-state)
 452             (setf (wisi-parser-state-pending parser-state)
 453                   (append (wisi-parser-state-pending parser-state)
 454                           (list (list (nth 1 action) tokens))))
 455           (setf (wisi-parser-state-pending parser-state)
 456                 (list (list (nth 1 action) tokens))))
 457       (funcall (nth 1 action) tokens))
 458     ))
 459
 460 (provide 'wisi-parse)
 461 ;;; wisi-parse.el ends here