(require 'cl)

(autoload 'define-parser "parser-ext" "Define parser" nil 'macro)
(autoload 'define-lexer  "parser-ext" "Define lexer"  nil 'macro)

(eval-when-compile
  (defconst parser-bad-chars 
    (eval-when-compile
      (let ((i 256)
	    (obarray (make-vector 13 nil)) ;; don't clutter up the real obarray
	    e)
	(while (>= (decf i) 0)
	  (if (string=  (prin1-to-string (intern (char-to-string i)))
			(char-to-string i)) nil
	    (push i e)))
	;; ensure ] is at the start if present
	;; ensure - is at the start if present
	;; ensure ^ is _not_ at the start if present
	(if (eq (car e) ?^)
	    (setq e (nconc (delq ?^ e) (list ?^)))) ;; don't make that '(?^) or nconc will shoot you in the foot
	(if (memq ?-  e)
	    (setq e (cons ?- (delq ?- e))))
	(if (memq ?\] e)
	    (setq e (cons ?\] (delq ?\] e))))
	e))
    "A list of characters that may have to be escaped to be read in a symbol
Tries to put ] and - at the beginning and ^ at the end so it can be easily
used to construct character sets and strings for skip-chars-forward")
  )

(eval-and-compile  
;;  (defconst parser-bad-chars-str
;;    (eval-when-compile
;;      (mapconcat (function (lambda (c)
;;			     (if (memq c '(?^ ?- ?\\))
;;				 (format "\\%c" c)
;;			       (char-to-string c))))
;;		 parser-bad-chars
;;		 ""))
;;    "A skip-chars-forward string of characters that should be escaped before reading")
;;  
;;  (defconst parser-bad-chars-charset
;;    (eval-when-compile
;;      (concat "["
;;	      (mapconcat 'char-to-string parser-bad-chars "")
;;	      "]"))
;;    "A regexp character set of characters that should be escaped before reading")

  (defconst parser-except-bad-chars-str 
    (eval-when-compile (concat "^" parser-bad-chars))
    "A inverse set of parser-bad-chars, just that with a ^ prepended")

;;  (defconst parser-except-bad-charset
;;    (eval-when-compile
;;      (concat "[^"
;;	      (mapconcat 'char-to-string parser-bad-chars "")
;;	      "]"))
;;    "A regexp character set of characters that should not escaped before reading")
  )


;;; The functions that actually form the lexer
(defun parser-quoted-read nil
  "Read a token using read to return a symbol, quoting any characters needed.
Must be called with match-beginning...match-end across the token to read"
  (narrow-to-region (match-beginning 0) (match-end 0))
  (goto-char (point-min))
  (while (progn
	   (skip-chars-forward parser-except-bad-chars-str (point-max))
	   (not (eobp)))
    (insert-char ?\\ 1)
    (forward-char 1))
  (goto-char (point-min))
  (prog1 (read (current-buffer))
    (assert (eobp) )
    (widen)))

(defun parser-unquoted-read nil
  "Read a token using read to return whatever data type is in the buffer.
Must be called with match-beginning...match-end across the token to read"
  (narrow-to-region (match-beginning 0) (match-end 0))
  (goto-char (point-min))
  (prog1
      (read (current-buffer))
    (assert (eobp))
    (widen)))



;;; PARSER  


(defun parser-token-lookup (parser tok)
  (cond ((symbolp tok)
	 (cdr (assq  tok (get parser 'tokens))))
	((numberp tok)
	 (aref (get parser 'yytranslate) tok))
	(t
	 tok)))

(eval-and-compile
  (defconst parser-defines '(YYFINAL YYNTBASE YYNTOKENS YYFLAG
				     YYNNTS YYNRULES YYNSTATES YYLAST YYMAXUTOK))
  (defconst parser-arrays  '(yytranslate yyprhs yyrhs yyrline ;; don't put yytname in!
					 yyr1 yyr2 yydefact yydefgoto yypact yypgoto
					 yytable yycheck))
  (defconst parser-vars (append parser-defines
				parser-arrays 
				'(yylex
				  actions
				  tokens
				  yytname)))
  )
(eval-when-compile
  (defvar yydebug nil
    "*If this is t then message every shift and reduction in yyparse")
  
  (defmacro parser-token-name (val)
    `(aref yytname ,val))
  
  (defmacro parser-rule (rulen)
    `(let ((i (1- (aref yyprhs ,rulen)))
	   l)
       (while (/= 0 (aref yyrhs (incf i)))
	 (push (parser-token-name (aref yyrhs i)) l))
       (push "->" l)
       (push (parser-token-name (aref yyr1 ,rulen)) l)
       (format "Rule %d (line %d): %s" ,rulen (aref yyrline ,rulen) (mapconcat 'identity (nreverse l) " "))))
  
  (defmacro with-parser-variables (parser &rest forms)
    `(let ,(mapcar '(lambda (v)
		      (list v (list 'get
				    parser
				    (list 'quote v))))
		   parser-vars)
       ,@forms))
  
  
  (defmacro yydebug (msg &rest args)
    (if yydebug
	(cons 'message (cons msg args))))
  
  (defmacro yycheck (yyn yychar)
    `(and (numberp ,yyn)
	  (>= ,yyn 0)
	  (< ,yyn YYLAST)
	  (= (aref yycheck ,yyn) ,yychar)))
  )

;;;###autoload
(defvar parser-cycles nil "Number of cycles last parse took")
(defvar parser-tokens nil "Number of tokens last parse read")
(defvar yylval nil "variable lexer uses to return token")

(defun yyparse (parser)
  (with-parser-variables parser
    (let ((yystate 0) yyn yyssp yyvsp yychar yyval yylval yylen yyact)
      (setq parser-cycles 0 parser-tokens 0)
      (push nil yyvsp)
      (push yystate yyssp)
      (message "Beginning parse")
      ;; yynewstate:
      (while (/= yystate YYFINAL)
	(yydebug "Entering state: %d" yystate)

	(incf parser-cycles)

	(when (setq yyn (aref yypact yystate))
	  (incf parser-tokens)
	  (setq yychar (or yychar (funcall yylex) 0))
	  (yydebug "Read token: %s" (parser-token-name yychar))
	  (setq yyn (+ yyn yychar)))

	(if (yycheck yyn yychar)
	    (setq yyn (aref yytable yyn))
	  (setq yyn (- (aref yydefact yystate))))

	;; if we're going to shift it discard the lookahead character
	(and (numberp yyn) (> yyn 0) 
	     (setq yychar nil))
	;; error handling XXX this only handles simple cases
	(when (or (null yyn)
		  (zerop yyn))
	  (setq yyn (aref yypact yystate))
	  (unless (and yyn
		       (incf yyn)
		       (yycheck yyn 1)
		       (setq yyn (aref yytable yyn))
		       (/= 0 yyn))
	    (error "Parse error")))
	  
	(if (< yyn 0);; REDUCE
	    (progn
	      (setq yyn (- yyn)
		    yylen (aref yyr2 yyn)
		    ;; default value of actions
		    yyact (aref actions yyn))
	      (yydebug "Reducing using %s { %s }"
		       (parser-rule yyn)
		       ;;yylen
		       (cond ((null yyact)
			      "Default action ($1)")
			     ((byte-code-function-p yyact)
			      "Byte compiled action")
			     (t
			      yyact)))
	      (if yyact
		  (setq yyval (funcall yyact))
		(setq yyval (nth (1- yylen) yyvsp)))
	      
	      (setq yyvsp (nthcdr yylen yyvsp)
		    yyssp (nthcdr yylen yyssp))
	      
	      (yydebug "Action result: %s" yyval)
	      (yydebug "Value stack now: %s" yyvsp)
	      (yydebug "State stack now: %s" yyssp)
	  
	      (setq yyn (aref yyr1 yyn)
		    yystate (aref yypgoto (- yyn YYNTBASE)))
	      (if yystate
		  (incf yystate (car yyssp)))
	      
	      (if (or (null yystate)
		      (< yystate 0)
		      (> yystate YYLAST)
		      (/= (aref yycheck yystate) (car yyssp)))
		  (push (setq yystate (aref yydefgoto (- yyn YYNTBASE))) yyssp)
		(push (setq yystate (aref yytable yystate)) yyssp))
	      (push yyval yyvsp)
	      nil)
	  ;; SHIFT
	  (yydebug "Shifting token")
	  (push yylval yyvsp)
	  (push yyn    yyssp)
	  (yydebug "Value stack now: %s" yyvsp)
	  (yydebug "State stack now: %s" yyssp)
	  (setq yystate yyn)
	  nil
	  ))
      (message "Parse Finished (%d tokens, %d cycles)" parser-tokens parser-cycles)
      yyval)))


(provide 'parser)

;;; Local Variables:
;;; eval: (put 'with-parser-variables 'lisp-indent-function 1)  
;;; End: