[bpt/emacs.git] / lisp / cedet / semantic / bovine.el

;;; semantic/bovine.el --- LL Parser/Analyzer core.

;; Copyright (C) 1999-2004, 2006-2007, 2009-2012
;;   Free Software Foundation, Inc.

;; Author: Eric M. Ludlam <eric@siege-engine.com>

;; 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:
;;
;; Semantic 1.x uses an LL parser named the "bovinator".  This parser
;; had several conveniences in it which made for parsing tags out of
;; languages with list characters easy.  This parser lives on as one
;; of many available parsers for semantic the tool.
;;
;; This parser should be used when the language is simple, such as
;; makefiles or other data-declarative languages.

;;; Code:
(require 'semantic)

(declare-function semantic-create-bovine-debug-error-frame
		  "semantic/bovine/debug")
(declare-function semantic-bovine-debug-create-frame
		  "semantic/bovine/debug")
(declare-function semantic-debug-break "semantic/debug")

;;; Variables
;;
(defvar semantic-bovinate-nonterminal-check-obarray nil
  "Obarray of streams already parsed for nonterminal symbols.
Use this to detect infinite recursion during a parse.")
(make-variable-buffer-local 'semantic-bovinate-nonterminal-check-obarray)


\f
;; These are functions that can be called from within a bovine table.
;; Most of these have code auto-generated from other construct in the
;; bovine input grammar.
(defmacro semantic-lambda (&rest return-val)
  "Create a lambda expression to return a list including RETURN-VAL.
The return list is a lambda expression to be used in a bovine table."
  `(lambda (vals start end)
     (append ,@return-val (list start end))))

;;; Semantic Bovination
;;
;; Take a semantic token stream, and convert it using the bovinator.
;; The bovinator takes a state table, and converts the token stream
;; into a new semantic stream defined by the bovination table.
;;
(defsubst semantic-bovinate-symbol-nonterminal-p (sym table)
  "Return non-nil if SYM is in TABLE, indicating it is NONTERMINAL."
  ;; sym is always a sym, so assq should be ok.
  (if (assq sym table) t nil))

(defmacro semantic-bovinate-nonterminal-db-nt ()
  "Return the current nonterminal symbol.
Part of the grammar source debugger.  Depends on the existing
environment of `semantic-bovinate-stream'."
  `(if nt-stack
       (car (aref (car nt-stack) 2))
     nonterminal))

(defun semantic-bovinate-nonterminal-check (stream nonterminal)
  "Check if STREAM not already parsed for NONTERMINAL.
If so abort because an infinite recursive parse is suspected."
  (or (vectorp semantic-bovinate-nonterminal-check-obarray)
      (setq semantic-bovinate-nonterminal-check-obarray
            (make-vector 13 nil)))
  (let* ((nt (symbol-name nonterminal))
         (vs (symbol-value
              (intern-soft
               nt semantic-bovinate-nonterminal-check-obarray))))
    (if (memq stream vs)
        ;; Always enter debugger to see the backtrace
        (let ((debug-on-signal t)
              (debug-on-error  t))
          (setq semantic-bovinate-nonterminal-check-obarray nil)
          (error "Infinite recursive parse suspected on %s" nt))
      (set (intern nt semantic-bovinate-nonterminal-check-obarray)
           (cons stream vs)))))

;;;###autoload
(defun semantic-bovinate-stream (stream &optional nonterminal)
  "Bovinate STREAM, starting at the first NONTERMINAL rule.
Use `bovine-toplevel' if NONTERMINAL is not provided.
This is the core routine for converting a stream into a table.
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 tokens found."
  (if (not nonterminal)
      (setq nonterminal 'bovine-toplevel))

  ;; Try to detect infinite recursive parse when doing a full reparse.
  (or semantic--buffer-cache
      (semantic-bovinate-nonterminal-check stream nonterminal))

  (let* ((table semantic--parse-table)
	 (matchlist (cdr (assq nonterminal table)))
	 (starting-stream stream)
	 (nt-loop  t)		  ;non-terminal loop condition
	 nt-popup                 ;non-nil if return from nt recursion
	 nt-stack		  ;non-terminal recursion stack
	 s			  ;Temp Stream Tracker
	 lse			  ;Local Semantic Element
	 lte			  ;Local matchlist element
	 tev			  ;Matchlist entry values from buffer
	 val			  ;Value found in buffer.
	 cvl			  ;collected values list.
	 out			  ;Output
	 end			  ;End of match
	 result
	 )
    (condition-case debug-condition
        (while nt-loop
          (catch 'push-non-terminal
            (setq nt-popup nil
                  end (semantic-lex-token-end (car stream)))
            (while (or nt-loop nt-popup)
              (setq nt-loop nil
                    out     nil)
              (while (or nt-popup matchlist)
                (if nt-popup
                    ;; End of a non-terminal recursion
                    (setq nt-popup nil)
                  ;; New matching process
                  (setq s   stream      ;init s from stream.
                        cvl nil     ;re-init the collected value list.
                        lte (car matchlist) ;Get the local matchlist entry.
                        )
                  (if (or (byte-code-function-p (car lte))
                          (listp (car lte)))
                      ;; In this case, we have an EMPTY match!  Make
                      ;; stuff up.
                      (setq cvl (list nil))))

                (while (and lte
                            (not (byte-code-function-p (car lte)))
                            (not (listp (car lte))))

                  ;; GRAMMAR SOURCE DEBUGGING!
                  (if (and (boundp 'semantic-debug-enabled)
			   semantic-debug-enabled)
                      (let* ((db-nt   (semantic-bovinate-nonterminal-db-nt))
                             (db-ml   (cdr (assq db-nt table)))
                             (db-mlen (length db-ml))
                             (db-midx (- db-mlen (length matchlist)))
                             (db-tlen (length (nth db-midx db-ml)))
                             (db-tidx (- db-tlen (length lte)))
			     (frame (progn
				      (require 'semantic/bovine/debug)
				      (semantic-bovine-debug-create-frame
				       db-nt db-midx db-tidx cvl (car s))))
			     (cmd (semantic-debug-break frame))
			     )
                        (cond ((eq 'fail cmd) (setq lte '(trash 0 . 0)))
			      ((eq 'quit cmd) (signal 'quit "Abort"))
			      ((eq 'abort cmd) (error "Abort"))
			      ;; support more commands here.

			      )))
                  ;; END GRAMMAR SOURCE DEBUGGING!

                  (cond
                   ;; We have a nonterminal symbol.  Recurse inline.
                   ((setq nt-loop (assq (car lte) table))

                    (setq
                     ;; push state into the nt-stack
                     nt-stack (cons (vector matchlist cvl lte stream end
                                            )
                                    nt-stack)
                     ;; new non-terminal matchlist
                     matchlist   (cdr nt-loop)
                     ;; new non-terminal stream
                     stream      s)

                    (throw 'push-non-terminal t)

                    )
                   ;; Default case
                   (t
                    (setq lse (car s)   ;Get the local stream element
                          s   (cdr s))  ;update stream.
                    ;; Do the compare
                    (if (eq (car lte) (semantic-lex-token-class lse)) ;syntactic match
                        (let ((valdot (semantic-lex-token-bounds lse)))
                          (setq val (semantic-lex-token-text lse))
                          (setq lte (cdr lte))
                          (if (stringp (car lte))
                              (progn
                                (setq tev (car lte)
                                      lte (cdr lte))
                                (if (string-match tev val)
                                    (setq cvl (cons
                                               (if (memq (semantic-lex-token-class lse)
                                                         '(comment semantic-list))
                                                   valdot val)
                                               cvl)) ;append this value
                                  (setq lte nil cvl nil))) ;clear the entry (exit)
                            (setq cvl (cons
                                       (if (memq (semantic-lex-token-class lse)
                                                 '(comment semantic-list))
                                           valdot val) cvl))) ;append unchecked value.
                          (setq end (semantic-lex-token-end lse))
                          )
                      (setq lte nil cvl nil)) ;No more matches, exit
                    )))
                (if (not cvl)           ;lte=nil;  there was no match.
                    (setq matchlist (cdr matchlist)) ;Move to next matchlist entry
                  (let ((start (semantic-lex-token-start (car stream))))
                    (setq out (cond
                               ((car lte)
                                (funcall (car lte) ;call matchlist fn on values
                                         (nreverse cvl) start end))
                               ((and (= (length cvl) 1)
                                     (listp (car cvl))
                                     (not (numberp (car (car cvl)))))
                                (append (car cvl) (list start end)))
                               (t
                                ;;(append (nreverse cvl) (list start end))))
                                ;; MAYBE THE FOLLOWING NEEDS LESS CONS
                                ;; CELLS THAN THE ABOVE?
                                (nreverse (cons end (cons start cvl)))))
                          matchlist nil) ;;generate exit condition
                    (if (not end)
                        (setq out nil)))
                  ;; Nothing?
                  ))
              (setq result
                    (if (eq s starting-stream)
                        (list (cdr s) nil)
                      (list s out)))
              (if nt-stack
                  ;; pop previous state from the nt-stack
                  (let ((state (car nt-stack)))

                    (setq nt-popup    t
                          ;; pop actual parser state
                          matchlist   (aref state 0)
                          cvl         (aref state 1)
                          lte         (aref state 2)
                          stream      (aref state 3)
                          end         (aref state 4)
                          ;; update the stack
                          nt-stack    (cdr nt-stack))

                    (if out
                        (let ((len (length out))
                              (strip (nreverse (cdr (cdr (reverse out))))))
                          (setq end (nth (1- len) out) ;reset end to the end of exp
                                cvl (cons strip cvl) ;prepend value of exp
                                lte (cdr lte)) ;update the local table entry
                          )
                      ;; No value means that we need to terminate this
                      ;; match.
                      (setq lte nil cvl nil)) ;No match, exit
                    )))))
      (error
       ;; On error just move forward the stream of lexical tokens
       (setq result (list (cdr starting-stream) nil))
       (when (and (boundp 'semantic-debug-enabled)
		  semantic-debug-enabled)
	 (require 'semantic/bovine/debug)
	 (let ((frame (semantic-create-bovine-debug-error-frame
		       debug-condition)))
	   (semantic-debug-break frame)))))
    result))

;; Make it the default parser
;;;###autoload
(defalias 'semantic-parse-stream-default 'semantic-bovinate-stream)

(provide 'semantic/bovine)

;; Local variables:
;; generated-autoload-file: "loaddefs.el"
;; generated-autoload-load-name: "semantic/bovine"
;; End:

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