(require 'parser)

;;; LEXER

(eval-when-compile
 (defmacro lex-var (symbol)
   `(intern (concat (symbol-name name) "-" (symbol-name ',symbol))))
 )

(defmacro define-lexer (name token-list &optional pretoken-hook obarray-len)
  (let ((token-list (eval token-list)) regexp subexps
	toks tok regexp1 regs strs kwds)
    (setq toks token-list)
    (while (setq tok (pop toks))
      (when (eq t (third tok))
	(setf (third tok) 'parser-unquoted-read))
      (if (third tok)
	  (push tok regs)
	(push tok strs)))
    (setq regs (nreverse regs)
	  regexp1 (concat "\\`\\(" (mapconcat 'car regs "\\|") "\\)")
	  kwds (remove-if (function (lambda (tok) (string-match regexp1 (first tok)))) strs)
	  kwds (sort kwds (function (lambda (a b) (> (length (car a)) (length (car b))))))
	  regexp
	  (mapconcat (function (lambda (tok)
				 (if (third tok)
				     (concat "\\(" (first tok) "\\)")
				   (regexp-quote (first tok)))))
		     (append regs kwds) "\\|")
	  subexps
	  (mapcar (function (lambda (tok)
			      (cons (second tok) (third tok))))
		  regs)
	  )
    `(progn
       (defconst ,(lex-var tokens-regexp)   ,regexp)
       (defconst ,(lex-var tokens-re-list) ',subexps)
       ;; this one can't be inlined because you can't prin->read an obarray
       (defconst ,(lex-var tokens-obarray)  (let ((oba (make-vector ,(or obarray-len 13) nil)))
					      (mapcar (function (lambda (cell)
								  (fset (intern (car cell) oba)
									'keyword)
								  (set (intern (car cell) oba)
								       (cadr cell))))
						      ',strs)
					      oba))
       ;;XXX(defconst ,(lex-var real-obarray) obarray "obarry to restore to")
       (defconst ,(lex-var i) nil 	"lexer temporary variable")
       (defconst ,(lex-var subexps) nil 	"lexer-temporary variable")
       (defun ,(lex-var yylex) nil
	 (catch 'token
	   ,(if pretoken-hook
		(list pretoken-hook))
	   (when (looking-at ,(lex-var tokens-regexp))
	     (setq ,(lex-var i) 0
		   ,(lex-var subexps) ,(lex-var tokens-re-list))
	     (let ((obarray ,(lex-var tokens-obarray))) ;; XXX
	       (while (and ,(lex-var subexps) (null (match-beginning (incf ,(lex-var i)))))
		 (pop  ,(lex-var subexps)))
	       (cond ((null (car ,(lex-var subexps)))
		      (setq yylval (parser-quoted-read))
		      (symbol-value yylval))
		     (t
		      (setq yylval (funcall (cdar ,(lex-var subexps))))
		      (if (and (symbolp yylval)
			       (fboundp yylval)
			       (eq (symbol-function yylval) 'keyword)
			       (boundp yylval))
			  (symbol-value yylval)
			(caar ,(lex-var subexps)))))
	       ))))
       )))




;;; PARSER
(defmacro define-parser (name lexer file hfile action-file)
  "Define a parser function NAME based on bison output files to parser LEXER
This function just calls yyparse with its name as an argument,
it's name has a property list that contains the grammar tables and lexer"
  (save-excursion (parser-grab-data name file hfile action-file))
  `(progn
     (setplist ',name ',(symbol-plist name))
     (put ',name 'yylex ',lexer)
     (defun ,name nil
       ,(format "A parser generated from bison output files\n(lexer is %s bison files were %s, %s, %s)"
		(symbol-name lexer)
		file hfile action-file)
       (yyparse (quote ,name)))))

(defun parser-grab-data (name file hfile action-file)
  (let (tmp (buf (generate-new-buffer file)))
    (switch-to-buffer buf)
    (buffer-disable-undo buf)
    (insert-file-contents file)
	
    (mapcar '(lambda (v) (put name v (parser-grab-define v)))
	    parser-defines)
    (mapcar '(lambda (v) (put name v (parser-grab-array v)))
	    parser-arrays)
    
    (mapcar '(lambda (v) (parser-fix-array (get name v)
					   (get name 'YYFLAG)))
	    parser-arrays)
    
    (put name 'yytname (parser-grab-yytname (get name 'YYNTOKENS) 
					    (get name 'YYNNTS)))

    (insert-file-contents hfile nil nil nil t)
    (put name 'tokens (parser-grab-tokens (get name 'yytranslate)))
    
    (insert-file-contents action-file nil nil nil t)
    (put name 'actions (parser-grab-actions (get name 'YYNRULES) 
					    action-file))
    (kill-buffer buf)))


(defun parser-grab-define (def)
  (goto-char (point-min))
  (re-search-forward (concat "#define[ \t]+"
				 (regexp-quote (symbol-name def))
				 "[ \t]+"))
  (read (current-buffer)))

(defun parser-grab-array (arr)
  (goto-char (point-min))
  (re-search-forward (concat (regexp-quote (symbol-name arr))
				 (regexp-quote "[]")
				 "[ \t]*"
				 (regexp-quote "=")
				 "[ \t]*"
				 "\\([[{][^}]*[]}]\\)"
				 ))
  (subst-char-in-region (match-beginning 1)
			(match-end 1)
			?, ? t)
  (subst-char-in-region (match-beginning 1)
			(1+ (match-beginning 1))
			?{ ?\[ t)
  (subst-char-in-region (match-end 1)
			(1- (match-end 1))
			?} ?\] t)
  (goto-char (match-beginning 1))
  (read (current-buffer)))

(defun parser-fix-array (arr yyflag)
  (let ((i (length arr)))
    (while (>= (decf i) 0)
      (if (= (aref arr i) yyflag)
	  (aset arr i nil)))))

(defun parser-grab-actions (maxrule filename)
  (let (rule 
	(byte-compile-current-file filename)
	(byte-compile-current-form "Grammar Rules")
	(vars (append parser-vars '(yyvsp)))
	(acts (make-vector (1+ maxrule) nil)))
    (goto-char (point-min))
    (while (re-search-forward "yylsp\\[-1\\]" nil t)
      (replace-match "@"))
    (goto-char (point-min))
    (while (re-search-forward "yyvsp\\[-?\\([0-9]+\\)\\]" nil t)
      (replace-match "(nth \\1 yyvsp)"))
    (goto-char (point-min))
    (while (re-search-forward "^case \\([0-9]+\\):\n#line [0-9]+[^\n]*\n{\\([^}]*\\)break;}\n\\(case\\|\\'\\)" nil t)
      (aset acts
	    (progn
	      (subst-char-in-region (match-end 1) (1+ (match-end 1)) ?: ? )
	      (goto-char (match-beginning 1))
	      (setq rule (read (current-buffer))))
	    (progn
	      (goto-char (match-beginning 2))
	      (narrow-to-region (match-beginning 2) (match-end 2))
	      (goto-char (point-min))
					; (if yydebug
	      (list 'lambda nil (macroexpand (read (current-buffer))))
	      ;; this crud is to avoid turning off free-vars
	      ;; maybe i should just do that
					; (displaying-byte-compile-warnings
					; (byte-compile-close-variables
					; (setq byte-compile-bound-variables vars
					; byte-compile-current-form (format "Rule %d" rule))
					; (byte-compile-lambda (list 'lambda nil (read (current-buffer))))
	      ))
      (goto-char (point-max))
      (widen))
    acts))

(defun parser-grab-tokens (yytranslate)
  (goto-char (point-min))
  (flush-lines "YYSTYPE")
  (keep-lines  "^#define")
  (goto-char (point-min))
  (while (re-search-forward "^#define[\t ]+\\([a-zA-Z_0-9]+\\)[\t ]+\\([0-9]+\\)" nil t)
    (replace-match "(\\1 . \\2)"))
  (goto-char (point-min))
  (insert "(\n")
  (goto-char (point-max))
  (insert ")")
  (goto-char (point-min))
  (let ((tokens (read (current-buffer))) 
	(i (length yytranslate)))
    (setq tokens (mapcar (function (lambda (tok)
				     (cons (car tok)
					   (aref yytranslate (cdr tok)))))
			 tokens))
    (while (>= (decf i) 0)
      (or (rassq (aref yytranslate i) tokens)
	  (<= (aref yytranslate i) 2)
	  (push (cons (concat "'" (char-to-string i) "'")
		      (aref yytranslate i))
		tokens)))
    (push (cons "end-of-file" 0) tokens)
    tokens))

(defun parser-grab-yytname (yyntokens yynnts)
  (let ((yytname (make-vector (+ yyntokens yynnts) nil)) 
	(i -1))
    (goto-char (point-min))
    (re-search-forward "yytname\\[\\][ 	]*=[ 	]*{[^\"]*")
    (while (= (following-char) ?\")
      (aset yytname (incf i) (read (current-buffer)))
      (skip-chars-forward ", \n\t"))
    yytname))


(provide 'parser-ext)