lisp/cedet/semantic/wisent.el: New file.

lisp/cedet/semantic/wisent.el

@@ -0,0 +1,346 @@
+;;; semantic/wisent.el --- Wisent - Semantic gateway
+
+;;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007
+;;; Free Software Foundation, Inc.
+
+;; Author: David Ponce <david@dponce.com>
+;; Maintainer: David Ponce <david@dponce.com>
+;; Created: 30 Aug 2001
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Here are functions necessary to use the Wisent LALR parser from
+;; Semantic environment.
+
+;;; History:
+;;
+
+;;; Code:
+
+(require 'semantic)
+(require 'semantic/wisent/wisent)
+
+;;; Lexical analysis
+;;
+(defvar wisent-lex-istream nil
+  "Input stream of `semantic-lex' syntactic tokens.")
+
+(defvar wisent-lex-lookahead nil
+  "Extra lookahead token.
+When non-nil it is directly returned by `wisent-lex-function'.")
+
+;; Maintain this alias for compatibility until all WY grammars have
+;; been translated again to Elisp code.
+(semantic-alias-obsolete 'wisent-lex-make-token-table
+                         'semantic-lex-make-type-table)
+
+(defmacro wisent-lex-eoi ()
+  "Return an End-Of-Input lexical token.
+The EOI token is like this: ($EOI "" POINT-MAX . POINT-MAX)."
+  `(cons ',wisent-eoi-term
+         (cons ""
+               (cons (point-max) (point-max)))))
+
+(defmacro define-wisent-lexer (name doc &rest body)
+  "Create a new lexical analyzer with NAME.
+DOC is a documentation string describing this analyzer.
+When a token is available in `wisent-lex-istream', eval BODY forms
+sequentially.  BODY must return a lexical token for the LALR parser.
+
+Each token in input was produced by `semantic-lex', it is a list:
+
+  (TOKSYM START . END)
+
+TOKSYM is a terminal symbol used in the grammar.
+START and END mark boundary in the current buffer of that token's
+value.
+
+Returned tokens must have the form:
+
+  (TOKSYM VALUE START . END)
+
+where VALUE is the buffer substring between START and END positions."
+  `(defun
+     ,name () ,doc
+     (cond
+      (wisent-lex-lookahead
+       (prog1 wisent-lex-lookahead
+         (setq wisent-lex-lookahead nil)))
+      (wisent-lex-istream
+       ,@body)
+      ((wisent-lex-eoi)))))
+
+(define-wisent-lexer wisent-lex
+  "Return the next available lexical token in Wisent's form.
+The variable `wisent-lex-istream' contains the list of lexical tokens
+produced by `semantic-lex'.  Pop the next token available and convert
+it to a form suitable for the Wisent's parser."
+  (let* ((tk (car wisent-lex-istream)))
+    ;; Eat input stream
+    (setq wisent-lex-istream (cdr wisent-lex-istream))
+    (cons (semantic-lex-token-class tk)
+          (cons (semantic-lex-token-text tk)
+                (semantic-lex-token-bounds tk)))))
+
+;;; Syntax analysis
+;;
+(defvar wisent-error-function nil
+  "Function used to report parse error.
+By default use the function `wisent-message'.")
+(make-variable-buffer-local 'wisent-error-function)
+
+(defvar wisent-lexer-function 'wisent-lex
+  "Function used to obtain the next lexical token in input.
+Should be a lexical analyzer created with `define-wisent-lexer'.")
+(make-variable-buffer-local 'wisent-lexer-function)
+
+;; Tag production
+;;
+(defsubst wisent-raw-tag (semantic-tag)
+  "Return raw form of given Semantic tag SEMANTIC-TAG.
+Should be used in semantic actions, in grammars, to build a Semantic
+parse tree."
+  (nconc semantic-tag
+         (if (or $region
+                 (setq $region (nthcdr 2 wisent-input)))
+             (list (car $region) (cdr $region))
+           (list (point-max) (point-max)))))
+
+(defsubst wisent-cook-tag (raw-tag)
+  "From raw form of Semantic tag RAW-TAG, return a list of cooked tags.
+Should be used in semantic actions, in grammars, to build a Semantic
+parse tree."
+  (let* ((cooked (semantic--tag-expand raw-tag))
+         (l cooked))
+    (while l
+      (semantic--tag-put-property (car l) 'reparse-symbol $nterm)
+      (setq l (cdr l)))
+    cooked))
+
+;; Unmatched syntax collector
+;;
+(defun wisent-collect-unmatched-syntax (nomatch)
+  "Add lexical token NOMATCH to the cache of unmatched tokens.
+See also the variable `semantic-unmatched-syntax-cache'.
+
+NOMATCH is in Wisent's form: (SYMBOL VALUE START . END)
+and will be collected in `semantic-lex' form: (SYMBOL START . END)."
+  (let ((region (cddr nomatch)))
+    (and (number-or-marker-p (car region))
+         (number-or-marker-p (cdr region))
+         (setq semantic-unmatched-syntax-cache
+               (cons (cons (car nomatch) region)
+                     semantic-unmatched-syntax-cache)))))
+
+;; Parser plug-ins
+;;
+;; The following functions permit to plug the Wisent LALR parser in
+;; Semantic toolkit.  They use the standard API provided by Semantic
+;; to plug parsers in.
+;;
+;; Two plug-ins are available, BUT ONLY ONE MUST BE USED AT A TIME:
+;;
+;; - `wisent-parse-stream' designed to override the standard function
+;;   `semantic-parse-stream'.
+;;
+;; - `wisent-parse-region' designed to override the standard function
+;;   `semantic-parse-region'.
+;;
+;; Maybe the latter is faster because it eliminates a lot of function
+;; call.
+;;
+(defun wisent-parse-stream (stream goal)
+  "Parse STREAM using the Wisent LALR parser.
+GOAL is a nonterminal symbol to start parsing at.
+Return the list (STREAM SEMANTIC-STREAM) where STREAM are those
+elements of STREAM that have not been used.  SEMANTIC-STREAM is the
+list of semantic tags found.
+The LALR parser automaton must be available in buffer local variable
+`semantic--parse-table'.
+
+Must be installed by `semantic-install-function-overrides' to override
+the standard function `semantic-parse-stream'."
+  (let (wisent-lex-istream wisent-lex-lookahead la-elt cache)
+
+    ;; IMPLEMENTATION NOTES:
+    ;; `wisent-parse' returns a lookahead token when it stopped
+    ;; parsing before encountering the end of input.  To re-enter the
+    ;; parser it is necessary to push back in the lexical input stream
+    ;; the last lookahead token issued.  Because the format of
+    ;; lookahead tokens and tokens in STREAM can be different the
+    ;; lookahead token is put in the variable `wisent-lex-lookahead'
+    ;; before calling `wisent-parse'.  Wisent's lexers always pop the
+    ;; next lexical token from that variable when non nil, then from
+    ;; the lexical input stream.
+    ;;
+    ;; The first element of STREAM is used to keep lookahead tokens
+    ;; across successive calls to `wisent-parse-stream'.  In fact
+    ;; what is kept is a stack of lookaheads encountered so far.  It
+    ;; is cleared when `wisent-parse' returns a valid semantic tag,
+    ;; or twice the same lookahead token!  The latter indicates that
+    ;; there is a syntax error on that token.  If so, tokens currently
+    ;; in the lookahead stack have not been used, and are moved into
+    ;; `semantic-unmatched-syntax-cache'.  When the parser will be
+    ;; re-entered, a new lexical token will be read from STREAM.
+    ;;
+    ;; The first element of STREAM that contains the lookahead stack
+    ;; has this format (compatible with the format of `semantic-lex'
+    ;; tokens):
+    ;;
+    ;; (LOOKAHEAD-STACK START . END)
+    ;;
+    ;; where LOOKAHEAD-STACK is a list of lookahead tokens.  And
+    ;; START/END are the bounds of the lookahead at top of stack.
+
+    ;; Retrieve lookahead token from stack
+    (setq la-elt (car stream))
+    (if (consp (car la-elt))
+        ;; The first elt of STREAM contains a lookahead stack
+        (setq wisent-lex-lookahead (caar la-elt)
+              stream (cdr stream))
+      (setq la-elt nil))
+    ;; Parse
+    (setq wisent-lex-istream stream
+          cache (semantic-safe "wisent-parse-stream: %s"
+                  (condition-case error-to-filter
+                      (wisent-parse semantic--parse-table
+                                    wisent-lexer-function
+                                    wisent-error-function
+                                    goal)
+                    (args-out-of-range
+                     (if (and (not debug-on-error)
+                              (= wisent-parse-max-stack-size
+                                 (nth 2 error-to-filter)))
+                         (progn
+                           (message "wisent-parse-stream: %s"
+                                    (error-message-string error-to-filter))
+                           (message "wisent-parse-max-stack-size \
+might need to be increased"))
+                       (apply 'signal error-to-filter))))))
+    ;; Manage returned lookahead token
+    (if wisent-lookahead
+        (if (eq (caar la-elt) wisent-lookahead)
+            ;; It is already at top of lookahead stack
+            (progn
+              (setq cache nil
+                    la-elt (car la-elt))
+              (while la-elt
+                ;; Collect unmatched tokens from the stack
+                (run-hook-with-args
+                 'wisent-discarding-token-functions (car la-elt))
+                (setq la-elt (cdr la-elt))))
+          ;; New lookahead token
+          (if (or (consp cache) ;; Clear the stack if parse succeeded
+                  (null la-elt))
+              (setq la-elt (cons nil nil)))
+          ;; Push it into the stack
+          (setcar la-elt (cons wisent-lookahead (car la-elt)))
+          ;; Update START/END
+          (setcdr la-elt (cddr wisent-lookahead))
+          ;; Push (LOOKAHEAD-STACK START . END) in STREAM
+          (setq wisent-lex-istream (cons la-elt wisent-lex-istream))))
+    ;; Return (STREAM SEMANTIC-STREAM)
+    (list wisent-lex-istream
+          (if (consp cache) cache '(nil))
+          )))
+
+(defun wisent-parse-region (start end &optional goal depth returnonerror)
+  "Parse the area between START and END using the Wisent LALR parser.
+Return the list of semantic tags found.
+Optional arguments GOAL is a nonterminal symbol to start parsing at,
+DEPTH is the lexical depth to scan, and RETURNONERROR is a flag to
+stop parsing on syntax error, when non-nil.
+The LALR parser automaton must be available in buffer local variable
+`semantic--parse-table'.
+
+Must be installed by `semantic-install-function-overrides' to override
+the standard function `semantic-parse-region'."
+  (if (or (< start (point-min)) (> end (point-max)) (< end start))
+      (error "Invalid bounds [%s %s] passed to `wisent-parse-region'"
+             start end))
+  (let* ((case-fold-search semantic-case-fold)
+         (wisent-lex-istream (semantic-lex start end depth))
+         ptree tag cooked lstack wisent-lex-lookahead)
+    ;; Loop while there are lexical tokens available
+    (while wisent-lex-istream
+      ;; Parse
+      (setq wisent-lex-lookahead (car lstack)
+            tag (semantic-safe "wisent-parse-region: %s"
+                    (wisent-parse semantic--parse-table
+                                  wisent-lexer-function
+                                  wisent-error-function
+                                  goal)))
+      ;; Manage returned lookahead token
+      (if wisent-lookahead
+          (if (eq (car lstack) wisent-lookahead)
+              ;; It is already at top of lookahead stack
+              (progn
+                (setq tag nil)
+                (while lstack
+                  ;; Collect unmatched tokens from lookahead stack
+                  (run-hook-with-args
+                   'wisent-discarding-token-functions (car lstack))
+                  (setq lstack (cdr lstack))))
+            ;; Push new lookahead token into the stack
+            (setq lstack (cons wisent-lookahead lstack))))
+      ;; Manage the parser result
+      (cond
+       ;; Parse succeeded, cook result
+       ((consp tag)
+        (setq lstack nil ;; Clear the lookahead stack
+              cooked (semantic--tag-expand tag)
+              ptree (append cooked ptree))
+        (while cooked
+          (setq tag    (car cooked)
+                cooked (cdr cooked))
+          (or (semantic--tag-get-property tag 'reparse-symbol)
+              (semantic--tag-put-property tag 'reparse-symbol goal)))
+        )
+       ;; Return on error if requested
+       (returnonerror
+        (setq wisent-lex-istream nil)
+        ))
+      ;; Work in progress...
+      (if wisent-lex-istream
+	  (and (eq semantic-working-type 'percent)
+	       (boundp 'semantic--progress-reporter)
+	       semantic--progress-reporter
+	       (progress-reporter-update
+		semantic--progress-reporter
+		(/ (* 100 (semantic-lex-token-start
+			   (car wisent-lex-istream)))
+		   (point-max))))))
+    ;; Return parse tree
+    (nreverse ptree)))
+
+;;; Interfacing with edebug
+;;
+(add-hook
+ 'edebug-setup-hook
+ #'(lambda ()
+
+     (def-edebug-spec define-wisent-lexer
+       (&define name stringp def-body)
+       )
+
+     ))
+
+(provide 'semantic/wisent)
+
+;;; semantic/wisent.el ends here