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

   1 ;;; wisent.el --- GNU Bison for Emacs - Runtime
   2
   3 ;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 David Ponce
   4
   5 ;; Author: David Ponce <david@dponce.com>
   6 ;; Maintainer: David Ponce <david@dponce.com>
   7 ;; Created: 30 January 2002
   8 ;; Keywords: syntax
   9 ;; X-RCS: $Id: wisent.el,v 1.1 2007-11-26 15:12:35 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 program is distributed in the hope that it will be useful, but
  19 ;; 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 this program; see the file COPYING.  If not, write to
  25 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  26 ;; Boston, MA 02110-1301, USA.
  27
  28 ;;; Commentary:
  29 ;;
  30 ;; Parser engine and runtime of Wisent.
  31 ;;
  32 ;; Wisent (the European Bison ;-) is an Elisp implementation of the
  33 ;; GNU Compiler Compiler Bison.  The Elisp code is a port of the C
  34 ;; code of GNU Bison 1.28 & 1.31.
  35 ;;
  36 ;; For more details on the basic concepts for understanding Wisent,
  37 ;; read the Bison manual ;)
  38 ;;
  39 ;; For more details on Wisent itself read the Wisent manual.
  40
  41 ;;; History:
  42 ;;
  43
  44 ;;; Code:
  45 (provide 'wisent)
  46
  47 (defgroup wisent nil
  48   "
  49            /\\_.-^^^-._/\\     The GNU
  50            \\_         _/
  51             (     `o  `      (European ;-) Bison
  52              \\      ` /
  53              (   D  ,¨       for Emacs!
  54               ` ~ ,¨
  55                `\"\""
  56   :group 'semantic)
  57
  58 \f
  59 ;;;; -------------
  60 ;;;; Runtime stuff
  61 ;;;; -------------
  62
  63 ;;; Compatibility
  64 (if (fboundp 'char-valid-p)
  65     (eval-and-compile (defalias 'wisent-char-p 'char-valid-p))
  66   (eval-and-compile (defalias 'wisent-char-p 'char-or-char-int-p)))
  67
  68 ;;; Printed representation of terminals and nonterminals
  69 (defconst wisent-escape-sequence-strings
  70   '(
  71     (?\a . "'\\a'")                     ; C-g
  72     (?\b . "'\\b'")                     ; backspace, BS, C-h
  73     (?\t . "'\\t'")                     ; tab, TAB, C-i
  74     (?\n  . "'\\n'")                    ; newline, C-j
  75     (?\v . "'\\v'")                     ; vertical tab, C-k
  76     (?\f . "'\\f'")                     ; formfeed character, C-l
  77     (?\r . "'\\r'")                     ; carriage return, RET, C-m
  78     (?\e . "'\\e'")                     ; escape character, ESC, C-[
  79     (?\\ . "'\\'")                      ; backslash character, \
  80     (?\d . "'\\d'")                     ; delete character, DEL
  81     )
  82   "Printed representation of usual escape sequences.")
  83
  84 (defsubst wisent-item-to-string (item)
  85   "Return a printed representation of ITEM.
  86 ITEM can be a nonterminal or terminal symbol, or a character literal."
  87   (if (wisent-char-p item)
  88         (or (cdr (assq item wisent-escape-sequence-strings))
  89             (format "'%c'" item))
  90     (symbol-name item)))
  91
  92 (defsubst wisent-token-to-string (token)
  93   "Return a printed representation of lexical token TOKEN."
  94   (format "%s%s(%S)" (wisent-item-to-string (car token))
  95           (if (nth 2 token) (format "@%s" (nth 2 token)) "")
  96           (nth 1 token)))
  97
  98 ;;; Special symbols
  99 (defconst wisent-eoi-term '$EOI
 100   "End Of Input token.")
 101
 102 (defconst wisent-error-term 'error
 103   "Error recovery token.")
 104
 105 (defconst wisent-accept-tag 'accept
 106   "Accept result after input successfully parsed.")
 107
 108 (defconst wisent-error-tag 'error
 109   "Process a syntax error.")
 110
 111 ;;; Special functions
 112 (defun wisent-automaton-p (obj)
 113   "Return non-nil if OBJ is a LALR automaton.
 114 If OBJ is a symbol check its value."
 115   (and obj (symbolp obj) (boundp obj)
 116        (setq obj (symbol-value obj)))
 117   (and (vectorp obj) (= 4 (length obj))
 118        (vectorp (aref obj 0)) (vectorp (aref obj 1))
 119        (= (length (aref obj 0)) (length (aref obj 1)))
 120        (listp (aref obj 2)) (vectorp (aref obj 3))))
 121
 122 (defsubst wisent-region (&rest positions)
 123   "Return the start/end positions of the region including POSITIONS.
 124 Each element of POSITIONS is a pair (START-POS . END-POS) or nil.  The
 125 returned value is the pair (MIN-START-POS . MAX-END-POS) or nil if no
 126 POSITIONS are available."
 127   (let ((pl (delq nil positions)))
 128     (if pl
 129         (cons (apply #'min (mapcar #'car pl))
 130               (apply #'max (mapcar #'cdr pl))))))
 131
 132 ;;; Reporting
 133 ;;;###autoload
 134 (defvar wisent-parse-verbose-flag nil
 135   "*Non-nil means to issue more messages while parsing.")
 136
 137 ;;;###autoload
 138 (defun wisent-parse-toggle-verbose-flag ()
 139   "Toggle whether to issue more messages while parsing."
 140   (interactive)
 141   (setq wisent-parse-verbose-flag (not wisent-parse-verbose-flag))
 142   (when (interactive-p)
 143     (message "More messages while parsing %sabled"
 144              (if wisent-parse-verbose-flag "en" "dis"))))
 145
 146 (defsubst wisent-message (string &rest args)
 147   "Print a one-line message if `wisent-parse-verbose-flag' is set.
 148 Pass STRING and ARGS arguments to `message'."
 149   (and wisent-parse-verbose-flag
 150        (apply 'message string args)))
 151 \f
 152 ;;;; --------------------
 153 ;;;; The LR parser engine
 154 ;;;; --------------------
 155
 156 (defcustom wisent-parse-max-stack-size 500
 157   "The parser stack size."
 158   :type 'integer
 159   :group 'wisent)
 160
 161 (defcustom wisent-parse-max-recover 3
 162   "Number of tokens to shift before turning off error status."
 163   :type 'integer
 164   :group 'wisent)
 165
 166 (defvar wisent-discarding-token-functions nil
 167   "List of functions to be called when discarding a lexical token.
 168 These functions receive the lexical token discarded.
 169 When the parser encounters unexpected tokens, it can discards them,
 170 based on what directed by error recovery rules.  Either when the
 171 parser reads tokens until one is found that can be shifted, or when an
 172 semantic action calls the function `wisent-skip-token' or
 173 `wisent-skip-block'.
 174 For language specific hooks, make sure you define this as a local
 175 hook.")
 176
 177 (defvar wisent-pre-parse-hook nil
 178   "Normal hook run just before entering the LR parser engine.")
 179
 180 (defvar wisent-post-parse-hook nil
 181   "Normal hook run just after the LR parser engine terminated.")
 182
 183 (defvar wisent-loop nil
 184   "The current parser action.
 185 Stop parsing when set to nil.
 186 This variable only has meaning in the scope of `wisent-parse'.")
 187
 188 (defvar wisent-nerrs nil
 189   "The number of parse errors encountered so far.")
 190
 191 (defvar wisent-lookahead nil
 192   "The lookahead lexical token.
 193 This value is non-nil if the parser terminated because of an
 194 unrecoverable error.")
 195
 196 ;; Variables and macros that are useful in semantic actions.
 197 (defvar wisent-parse-lexer-function nil
 198   "The user supplied lexer function.
 199 This function don't have arguments.
 200 This variable only has meaning in the scope of `wisent-parse'.")
 201
 202 (defvar wisent-parse-error-function nil
 203   "The user supplied error function.
 204 This function must accept one argument, a message string.
 205 This variable only has meaning in the scope of `wisent-parse'.")
 206
 207 (defvar wisent-input nil
 208   "The last token read.
 209 This variable only has meaning in the scope of `wisent-parse'.")
 210
 211 (defvar wisent-recovering nil
 212   "Non-nil means that the parser is recovering.
 213 This variable only has meaning in the scope of `wisent-parse'.")
 214
 215 ;; Variables that only have meaning in the scope of a semantic action.
 216 ;; These global definitions avoid byte-compiler warnings.
 217 (defvar $region nil)
 218 (defvar $nterm  nil)
 219 (defvar $action nil)
 220
 221 (defmacro wisent-lexer ()
 222   "Obtain the next terminal in input."
 223   '(funcall wisent-parse-lexer-function))
 224
 225 (defmacro wisent-error (msg)
 226   "Call the user supplied error reporting function with message MSG."
 227   `(funcall wisent-parse-error-function ,msg))
 228
 229 (defmacro wisent-errok ()
 230   "Resume generating error messages immediately for subsequent syntax errors.
 231 This is useful primarily in error recovery semantic actions."
 232   '(setq wisent-recovering nil))
 233
 234 (defmacro wisent-clearin ()
 235   "Discard the current lookahead token.
 236 This will cause a new lexical token to be read.
 237 This is useful primarily in error recovery semantic actions."
 238   '(setq wisent-input nil))
 239
 240 (defmacro wisent-abort ()
 241   "Abort parsing and save the lookahead token.
 242 This is useful primarily in error recovery semantic actions."
 243   '(setq wisent-lookahead wisent-input
 244          wisent-loop nil))
 245
 246 (defmacro wisent-set-region (start end)
 247   "Change the region of text matched by the current nonterminal.
 248 START and END are respectively the beginning and end positions of the
 249 region.  If START or END values are not a valid positions the region
 250 is set to nil."
 251   `(setq $region (and (number-or-marker-p ,start)
 252                       (number-or-marker-p ,end)
 253                       (cons ,start ,end))))
 254
 255 (defun wisent-skip-token ()
 256   "Skip the lookahead token in order to resume parsing.
 257 Return nil.
 258 Must be used in error recovery semantic actions."
 259   (if (eq (car wisent-input) wisent-eoi-term)
 260       ;; Does nothing at EOI to avoid infinite recovery loop.
 261       nil
 262     (wisent-message "%s: skip %s" $action
 263                     (wisent-token-to-string wisent-input))
 264     (run-hook-with-args
 265      'wisent-discarding-token-functions wisent-input)
 266     (wisent-clearin)
 267     (wisent-errok)))
 268
 269 (defun wisent-skip-block (&optional bounds)
 270   "Safely skip a parenthesized block in order to resume parsing.
 271 Return nil.
 272 Must be used in error recovery semantic actions.
 273 Optional argument BOUNDS is a pair (START . END) which indicates where
 274 the parenthesized block starts.  Typically the value of a `$regionN'
 275 variable, where `N' is the the Nth element of the current rule
 276 components that match the block beginning.  It defaults to the value
 277 of the `$region' variable."
 278   (let ((start (car (or bounds $region)))
 279         end input block)
 280     (if (not (number-or-marker-p start))
 281         ;; No nonterminal region available, skip the lookahead token.
 282         (wisent-skip-token)
 283       ;; Try to skip a block.
 284       (if (not (setq end (save-excursion
 285                            (goto-char start)
 286                            (and (looking-at "\\s(")
 287                                 (condition-case nil
 288                                     (1- (scan-lists (point) 1 0))
 289                                   (error nil))))))
 290           ;; Not actually a block, skip the lookahead token.
 291           (wisent-skip-token)
 292         ;; OK to safely skip the block, so read input until a matching
 293         ;; close paren or EOI is encountered.
 294         (setq input wisent-input)
 295         (while (and (not (eq (car input) wisent-eoi-term))
 296                     (< (nth 2 input) end))
 297           (run-hook-with-args
 298            'wisent-discarding-token-functions input)
 299           (setq input (wisent-lexer)))
 300         (wisent-message "%s: in enclosing block, skip from %s to %s"
 301                         $action
 302                         (wisent-token-to-string wisent-input)
 303                         (wisent-token-to-string input))
 304         (if (eq (car wisent-input) wisent-eoi-term)
 305             ;; Does nothing at EOI to avoid infinite recovery loop.
 306             nil
 307           (wisent-clearin)
 308           (wisent-errok))
 309         ;; Set end of $region to end of block.
 310         (wisent-set-region (car $region) (1+ end))
 311         nil))))
 312
 313 ;;; Core parser engine
 314 (defsubst wisent-production-bounds (stack i j)
 315   "Determine the start and end locations of a production value.
 316 Return a pair (START . END), where START is the first available start
 317 location, and END the last available end location, in components
 318 values of the rule currently reduced.
 319 Return nil when no component location is available.
 320 STACK is the parser stack.
 321 I and J are the indices in STACK of respectively the value of the
 322 first and last components of the current rule.
 323 This function is for internal use by semantic actions' generated
 324 lambda-expression."
 325   (let ((f (cadr (aref stack i)))
 326         (l (cddr (aref stack j))))
 327     (while (/= i j)
 328       (cond
 329        ((not f) (setq f (cadr (aref stack (setq i (+ i 2))))))
 330        ((not l) (setq l (cddr (aref stack (setq j (- j 2))))))
 331        ((setq i j))))
 332     (and f l (cons f l))))
 333
 334 (defmacro wisent-parse-action (i al)
 335   "Return the next parser action.
 336 I is a token item number and AL is the list of (item . action)
 337 available at current state.  The first element of AL contains the
 338 default action for this state."
 339   `(cdr (or (assq ,i ,al) (car ,al))))
 340
 341 (defsubst wisent-parse-start (start starts)
 342   "Return the first lexical token to shift for START symbol.
 343 STARTS is the table of allowed start symbols or nil if the LALR
 344 automaton has only one entry point."
 345   (if (null starts)
 346       ;; Only one entry point, return the first lexical token
 347       ;; available in input.
 348       (wisent-lexer)
 349     ;; Multiple start symbols defined, return the internal lexical
 350     ;; token associated to START.  By default START is the first
 351     ;; nonterminal defined in STARTS.
 352     (let ((token (cdr (if start (assq start starts) (car starts)))))
 353       (if token
 354           (list token (symbol-name token))
 355         (error "Invalid start symbol %s" start)))))
 356
 357 (defun wisent-parse (automaton lexer &optional error start)
 358   "Parse input using the automaton specified in AUTOMATON.
 359
 360 - AUTOMATON is an LALR(1) automaton generated by
 361   `wisent-compile-grammar'.
 362
 363 - LEXER is a function with no argument called by the parser to obtain
 364   the next terminal (token) in input.
 365
 366 - ERROR is an optional reporting function called when a parse error
 367   occurs.  It receives a message string to report.  It defaults to the
 368   function `wisent-message'.
 369
 370 - START specify the start symbol (nonterminal) used by the parser as
 371   its goal.  It defaults to the start symbol defined in the grammar
 372   \(see also `wisent-compile-grammar')."
 373   (run-hooks 'wisent-pre-parse-hook)
 374   (let* ((actions (aref automaton 0))
 375          (gotos   (aref automaton 1))
 376          (starts  (aref automaton 2))
 377          (stack (make-vector wisent-parse-max-stack-size nil))
 378          (sp 0)
 379          (wisent-loop t)
 380          (wisent-parse-error-function (or error 'wisent-message))
 381          (wisent-parse-lexer-function lexer)
 382          (wisent-recovering nil)
 383          (wisent-input (wisent-parse-start start starts))
 384          state tokid choices choice)
 385     (setq wisent-nerrs     0 ;; Reset parse error counter
 386           wisent-lookahead nil) ;; and lookahead token
 387     (aset stack 0 0) ;; Initial state
 388     (while wisent-loop
 389       (setq state (aref stack sp)
 390             tokid (car wisent-input)
 391             wisent-loop (wisent-parse-action tokid (aref actions state)))
 392       (cond
 393
 394        ;; Input successfully parsed
 395        ;; -------------------------
 396        ((eq wisent-loop wisent-accept-tag)
 397         (setq wisent-loop nil))
 398
 399        ;; Syntax error in input
 400        ;; ---------------------
 401        ((eq wisent-loop wisent-error-tag)
 402         ;; Report this error if not already recovering from an error.
 403         (setq choices (aref actions state))
 404         (or wisent-recovering
 405             (wisent-error
 406              (format "Syntax error, unexpected %s, expecting %s"
 407                      (wisent-token-to-string wisent-input)
 408                      (mapconcat 'wisent-item-to-string
 409                                 (delq wisent-error-term
 410                                       (mapcar 'car (cdr choices)))
 411                                 ", "))))
 412         ;; Increment the error counter
 413         (setq wisent-nerrs (1+ wisent-nerrs))
 414         ;; If just tried and failed to reuse lookahead token after an
 415         ;; error, discard it.
 416         (if (eq wisent-recovering wisent-parse-max-recover)
 417             (if (eq tokid wisent-eoi-term)
 418                 (wisent-abort) ;; Terminate if at end of input.
 419               (wisent-message "Error recovery: skip %s"
 420                               (wisent-token-to-string wisent-input))
 421               (run-hook-with-args
 422                'wisent-discarding-token-functions wisent-input)
 423               (setq wisent-input (wisent-lexer)))
 424
 425           ;; Else will try to reuse lookahead token after shifting the
 426           ;; error token.
 427
 428           ;; Each real token shifted decrements this.
 429           (setq wisent-recovering wisent-parse-max-recover)
 430           ;; Pop the value/state stack to see if an action associated
 431           ;; to special terminal symbol 'error exists.
 432           (while (and (>= sp 0)
 433                       (not (and (setq state   (aref stack sp)
 434                                       choices (aref actions state)
 435                                       choice  (assq wisent-error-term choices))
 436                                 (natnump (cdr choice)))))
 437             (setq sp (- sp 2)))
 438
 439           (if (not choice)
 440               ;; No 'error terminal was found.  Just terminate.
 441               (wisent-abort)
 442             ;; Try to recover and continue parsing.
 443             ;; Shift the error terminal.
 444             (setq state (cdr choice)    ; new state
 445                   sp    (+ sp 2))
 446             (aset stack (1- sp) nil)    ; push value
 447             (aset stack sp state)       ; push new state
 448             ;; Adjust input to error recovery state.  Unless 'error
 449             ;; triggers a reduction, eat the input stream until an
 450             ;; expected terminal symbol is found, or EOI is reached.
 451             (if (cdr (setq choices (aref actions state)))
 452                 (while (not (or (eq (car wisent-input) wisent-eoi-term)
 453                                 (assq (car wisent-input) choices)))
 454                   (wisent-message "Error recovery: skip %s"
 455                                   (wisent-token-to-string wisent-input))
 456                   (run-hook-with-args
 457                    'wisent-discarding-token-functions wisent-input)
 458                   (setq wisent-input (wisent-lexer)))))))
 459
 460        ;; Shift current token on top of the stack
 461        ;; ---------------------------------------
 462        ((natnump wisent-loop)
 463         ;; Count tokens shifted since error; after
 464         ;; `wisent-parse-max-recover', turn off error status.
 465         (setq wisent-recovering (and (natnump wisent-recovering)
 466                                      (> wisent-recovering 1)
 467                                      (1- wisent-recovering)))
 468         (setq sp (+ sp 2))
 469         (aset stack (1- sp) (cdr wisent-input))
 470         (aset stack sp wisent-loop)
 471         (setq wisent-input (wisent-lexer)))
 472
 473        ;; Reduce by rule (call semantic action)
 474        ;; -------------------------------------
 475        (t
 476         (setq sp (funcall wisent-loop stack sp gotos))
 477         (or wisent-input (setq wisent-input (wisent-lexer))))))
 478     (run-hooks 'wisent-post-parse-hook)
 479     (car (aref stack 1))))
 480
 481 ;;; wisent.el ends here