code.delx.au - gnu-emacs/blob - lisp/cedet/semantic/bovine.el

   1 ;;; semantic/bovine.el --- LL Parser/Analyzer core.
   2
   3 ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007
   4 ;;; Free Software Foundation, Inc.
   5
   6 ;; Author: Eric M. Ludlam <eric@siege-engine.com>
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24 ;;
  25 ;; Semantix 1.x uses an LL parser named the "bovinator".  This parser
  26 ;; had several conveniences in it which made for parsing tags out of
  27 ;; languages with list characters easy.  This parser lives on as one
  28 ;; of many available parsers for semantic the tool.
  29 ;;
  30 ;; This parser should be used when the language is simple, such as
  31 ;; makefiles or other data-declaritive langauges.
  32
  33 ;;; Code:
  34 (require 'semantic)
  35 (require 'semantic/bovine/debug)
  36
  37 ;;; Variables
  38 ;;
  39 (defvar semantic-bovinate-nonterminal-check-obarray nil
  40   "Obarray of streams already parsed for nonterminal symbols.
  41 Use this to detect infinite recursion during a parse.")
  42 (make-variable-buffer-local 'semantic-bovinate-nonterminal-check-obarray)
  43
  44
  45 \f
  46 ;; These are functions that can be called from within a bovine table.
  47 ;; Most of these have code auto-generated from other construct in the
  48 ;; bovine input grammar.
  49 (defmacro semantic-lambda (&rest return-val)
  50   "Create a lambda expression to return a list including RETURN-VAL.
  51 The return list is a lambda expression to be used in a bovine table."
  52   `(lambda (vals start end)
  53      (append ,@return-val (list start end))))
  54
  55 ;;; Semantic Bovination
  56 ;;
  57 ;; Take a semantic token stream, and convert it using the bovinator.
  58 ;; The bovinator takes a state table, and converts the token stream
  59 ;; into a new semantic stream defined by the bovination table.
  60 ;;
  61 (defsubst semantic-bovinate-symbol-nonterminal-p (sym table)
  62   "Return non-nil if SYM is in TABLE, indicating it is NONTERMINAL."
  63   ;; sym is always a sym, so assq should be ok.
  64   (if (assq sym table) t nil))
  65
  66 (defmacro semantic-bovinate-nonterminal-db-nt ()
  67   "Return the current nonterminal symbol.
  68 Part of the grammar source debugger.  Depends on the existing
  69 environment of `semantic-bovinate-stream'."
  70   `(if nt-stack
  71        (car (aref (car nt-stack) 2))
  72      nonterminal))
  73
  74 (defun semantic-bovinate-nonterminal-check (stream nonterminal)
  75   "Check if STREAM not already parsed for NONTERMINAL.
  76 If so abort because an infinite recursive parse is suspected."
  77   (or (vectorp semantic-bovinate-nonterminal-check-obarray)
  78       (setq semantic-bovinate-nonterminal-check-obarray
  79             (make-vector 13 nil)))
  80   (let* ((nt (symbol-name nonterminal))
  81          (vs (symbol-value
  82               (intern-soft
  83                nt semantic-bovinate-nonterminal-check-obarray))))
  84     (if (memq stream vs)
  85         ;; Always enter debugger to see the backtrace
  86         (let ((debug-on-signal t)
  87               (debug-on-error  t))
  88           (setq semantic-bovinate-nonterminal-check-obarray nil)
  89           (error "Infinite recursive parse suspected on %s" nt))
  90       (set (intern nt semantic-bovinate-nonterminal-check-obarray)
  91            (cons stream vs)))))
  92
  93 ;;;###autoload
  94 (defun semantic-bovinate-stream (stream &optional nonterminal)
  95   "Bovinate STREAM, starting at the first NONTERMINAL rule.
  96 Use `bovine-toplevel' if NONTERMINAL is not provided.
  97 This is the core routine for converting a stream into a table.
  98 Return the list (STREAM SEMANTIC-STREAM) where STREAM are those
  99 elements of STREAM that have not been used.  SEMANTIC-STREAM is the
 100 list of semantic tokens found."
 101   (if (not nonterminal)
 102       (setq nonterminal 'bovine-toplevel))
 103
 104   ;; Try to detect infinite recursive parse when doing a full reparse.
 105   (or semantic--buffer-cache
 106       (semantic-bovinate-nonterminal-check stream nonterminal))
 107
 108   (let* ((table semantic--parse-table)
 109          (matchlist (cdr (assq nonterminal table)))
 110          (starting-stream stream)
 111          (nt-loop  t)             ;non-terminal loop condition
 112          nt-popup                 ;non-nil if return from nt recursion
 113          nt-stack                 ;non-terminal recursion stack
 114          s                        ;Temp Stream Tracker
 115          lse                      ;Local Semantic Element
 116          lte                      ;Local matchlist element
 117          tev                      ;Matchlist entry values from buffer
 118          val                      ;Value found in buffer.
 119          cvl                      ;collected values list.
 120          out                      ;Output
 121          end                      ;End of match
 122          result
 123          )
 124     (condition-case debug-condition
 125         (while nt-loop
 126           (catch 'push-non-terminal
 127             (setq nt-popup nil
 128                   end (semantic-lex-token-end (car stream)))
 129             (while (or nt-loop nt-popup)
 130               (setq nt-loop nil
 131                     out     nil)
 132               (while (or nt-popup matchlist)
 133                 (if nt-popup
 134                     ;; End of a non-terminal recursion
 135                     (setq nt-popup nil)
 136                   ;; New matching process
 137                   (setq s   stream      ;init s from stream.
 138                         cvl nil     ;re-init the collected value list.
 139                         lte (car matchlist) ;Get the local matchlist entry.
 140                         )
 141                   (if (or (byte-code-function-p (car lte))
 142                           (listp (car lte)))
 143                       ;; In this case, we have an EMPTY match!  Make
 144                       ;; stuff up.
 145                       (setq cvl (list nil))))
 146
 147                 (while (and lte
 148                             (not (byte-code-function-p (car lte)))
 149                             (not (listp (car lte))))
 150
 151                   ;; GRAMMAR SOURCE DEBUGGING!
 152                   (if semantic-debug-enabled
 153                       (let* ((db-nt   (semantic-bovinate-nonterminal-db-nt))
 154                              (db-ml   (cdr (assq db-nt table)))
 155                              (db-mlen (length db-ml))
 156                              (db-midx (- db-mlen (length matchlist)))
 157                              (db-tlen (length (nth db-midx db-ml)))
 158                              (db-tidx (- db-tlen (length lte)))
 159                              (frame (semantic-bovine-debug-create-frame
 160                                      db-nt db-midx db-tidx cvl (car s)))
 161                              (cmd (semantic-debug-break frame))
 162                              )
 163                         (cond ((eq 'fail cmd) (setq lte '(trash 0 . 0)))
 164                               ((eq 'quit cmd) (signal 'quit "Abort"))
 165                               ((eq 'abort cmd) (error "Abort"))
 166                               ;; support more commands here.
 167
 168                               )))
 169                   ;; END GRAMMAR SOURCE DEBUGGING!
 170
 171                   (cond
 172                    ;; We have a nonterminal symbol.  Recurse inline.
 173                    ((setq nt-loop (assq (car lte) table))
 174
 175                     (setq
 176                      ;; push state into the nt-stack
 177                      nt-stack (cons (vector matchlist cvl lte stream end
 178                                             )
 179                                     nt-stack)
 180                      ;; new non-terminal matchlist
 181                      matchlist   (cdr nt-loop)
 182                      ;; new non-terminal stream
 183                      stream      s)
 184
 185                     (throw 'push-non-terminal t)
 186
 187                     )
 188                    ;; Default case
 189                    (t
 190                     (setq lse (car s)   ;Get the local stream element
 191                           s   (cdr s))  ;update stream.
 192                     ;; Do the compare
 193                     (if (eq (car lte) (semantic-lex-token-class lse)) ;syntactic match
 194                         (let ((valdot (semantic-lex-token-bounds lse)))
 195                           (setq val (semantic-lex-token-text lse))
 196                           (setq lte (cdr lte))
 197                           (if (stringp (car lte))
 198                               (progn
 199                                 (setq tev (car lte)
 200                                       lte (cdr lte))
 201                                 (if (string-match tev val)
 202                                     (setq cvl (cons
 203                                                (if (memq (semantic-lex-token-class lse)
 204                                                          '(comment semantic-list))
 205                                                    valdot val)
 206                                                cvl)) ;append this value
 207                                   (setq lte nil cvl nil))) ;clear the entry (exit)
 208                             (setq cvl (cons
 209                                        (if (memq (semantic-lex-token-class lse)
 210                                                  '(comment semantic-list))
 211                                            valdot val) cvl))) ;append unchecked value.
 212                           (setq end (semantic-lex-token-end lse))
 213                           )
 214                       (setq lte nil cvl nil)) ;No more matches, exit
 215                     )))
 216                 (if (not cvl)           ;lte=nil;  there was no match.
 217                     (setq matchlist (cdr matchlist)) ;Move to next matchlist entry
 218                   (let ((start (semantic-lex-token-start (car stream))))
 219                     (setq out (cond
 220                                ((car lte)
 221                                 (funcall (car lte) ;call matchlist fn on values
 222                                          (nreverse cvl) start end))
 223                                ((and (= (length cvl) 1)
 224                                      (listp (car cvl))
 225                                      (not (numberp (car (car cvl)))))
 226                                 (append (car cvl) (list start end)))
 227                                (t
 228                                 ;;(append (nreverse cvl) (list start end))))
 229                                 ;; MAYBE THE FOLLOWING NEEDS LESS CONS
 230                                 ;; CELLS THAN THE ABOVE?
 231                                 (nreverse (cons end (cons start cvl)))))
 232                           matchlist nil) ;;generate exit condition
 233                     (if (not end)
 234                         (setq out nil)))
 235                   ;; Nothin?
 236                   ))
 237               (setq result
 238                     (if (eq s starting-stream)
 239                         (list (cdr s) nil)
 240                       (list s out)))
 241               (if nt-stack
 242                   ;; pop previous state from the nt-stack
 243                   (let ((state (car nt-stack)))
 244
 245                     (setq nt-popup    t
 246                           ;; pop actual parser state
 247                           matchlist   (aref state 0)
 248                           cvl         (aref state 1)
 249                           lte         (aref state 2)
 250                           stream      (aref state 3)
 251                           end         (aref state 4)
 252                           ;; update the stack
 253                           nt-stack    (cdr nt-stack))
 254
 255                     (if out
 256                         (let ((len (length out))
 257                               (strip (nreverse (cdr (cdr (reverse out))))))
 258                           (setq end (nth (1- len) out) ;reset end to the end of exp
 259                                 cvl (cons strip cvl) ;prepend value of exp
 260                                 lte (cdr lte)) ;update the local table entry
 261                           )
 262                       ;; No value means that we need to terminate this
 263                       ;; match.
 264                       (setq lte nil cvl nil)) ;No match, exit
 265                     )))))
 266       (error
 267        ;; On error just move forward the stream of lexical tokens
 268        (setq result (list (cdr starting-stream) nil))
 269        (if semantic-debug-enabled
 270            (let ((frame (semantic-create-bovine-debug-error-frame
 271                          debug-condition)))
 272              (semantic-debug-break frame)
 273              ))
 274        ))
 275     result))
 276
 277 ;; Make it the default parser
 278 ;;;###autoload
 279 (defalias 'semantic-parse-stream-default 'semantic-bovinate-stream)
 280
 281 (provide 'semantic/bovine)
 282
 283 ;; Local variables:
 284 ;; generated-autoload-file: "loaddefs.el"
 285 ;; generated-autoload-feature: semantic/loaddefs
 286 ;; generated-autoload-load-name: "semantic/bovine"
 287 ;; End:
 288
 289 ;;; semantic/bovine.el ends here