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

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