lr0.lisp

(defparameter *grammar*
  '((accept   list nil)
    (list     list 'comma element)
    (list     element)
    (element  'a)
    (element  'b)))

(defvar *rules*)  ; vector of *grammar*
(defvar *sets*)
(defvar *goto*)

(defun find-rules (non-term)
  (remove-if-not #'(lambda (rule) (eq (car rule) non-term)) *grammar*))

(defun first-item (rule)
  (cons (car rule)
	(cons '* (cdr rule))))

;;; too complex maybe?
(defun advance-item (item)
  (if (eq (car item) '*)
      (cons (cadr item)
	    (cons '* (cddr item)))
      (cons (car item)
	    (advance-item (cdr item)))))

(defun next-in-item (item)
  (cadr (nthcdr (search '(*) item) item)))

(defun reduction-item-p (item)
  (eq (car (last item)) '*))

;;; same as set-difference really but preserve order (not necessary)
(defun remove-existing (items new)
  (remove-if #'(lambda (i) (member i items :test #'equal)) new))

(defun construct-closure (set)
  (let* ((non-terms (remove-duplicates (mapcar #'next-in-item set)))
	 (items (mapcar #'first-item (mapcan #'find-rules non-terms)))
	 (new-items (remove-existing set items)))
      (when new-items
	(nconc set new-items)
	(construct-closure set))
      set))

(defun construct-next-sets (set index)
  (let* ((items (mapcar #'(lambda (i) (cons (next-in-item i)
					    (advance-item i)))
			set))
	 (symbols (remove nil (remove-duplicates (mapcar #'car items))))
	 (nexts (mapcar #'(lambda (sym)
			    (mapcan #'(lambda (i)
					(if (equal (car i) sym)
					    (list (cdr i))
					    nil))
				    items))
			symbols)))
    (let* ((a nil)
	   (first (length *goto*))
	   ;; close new sets and check if they existed already
	   (newset (mapcar #'(lambda (set sym)
			       (construct-closure set)
			       (let ((pos (position set *sets* :test #'equal)))
				 (if pos
				     (progn (push (cons sym pos) a)
					    nil)
				     (progn (push (cons sym (length *sets*)) a)
					    (nconc *sets* (list set))
					    (vector-push-extend nil *goto*)))))
			   nexts symbols)))
      (setf (aref *goto* index) a)
      
      (do ((i first (1+ i))
	   (nexts nexts (cdr nexts))
	   (newset newset (cdr newset)))
	  ((null nexts))
	(when (car newset)
	  (construct-next-sets (car nexts) i))))))

(defun construct-sets ()
  (setq *sets* (list (list (first-item (car *grammar*))))
	*goto* (make-array 1 :initial-element nil :adjustable t :fill-pointer t))
  (construct-closure (car *sets*))
  (construct-next-sets (car *sets*) 0)
  (setq *sets* (apply #'vector *sets*))
  (setq *rules* (apply #'vector *grammar*)))

(defun generate-action (set goto)
  (let ((actions (remove-if #'atom goto :key #'car))
	(reductions (remove-if-not #'reduction-item-p set)))
    ;; find end
    (dolist (item set)
      (when (equal (last item 2) '(* nil))
	(push (cons nil 'done) actions)))
    ;; complain about conflicts
    (when (and actions reductions)
      (format t "shift-reduce conflict~%")
      (return-from generate-action nil))
    (when (cdr reductions)
      (format t "reduce-reduce conflict~%")
      (return-from generate-action nil))
    (cond (actions
	   `(case in
	      ,@(mapcar #'(lambda (action)
			    (let ((in (car action))
				 (state (cdr action)))
			     (if (null in)
				 '((nil) (return-from parse 'done))
				 `(,(if (and (consp in)
					     (eq (car in) 'quote))
					(cadr in)
					(progn (format t "unknown token")
					       (return-from generate-action nil)))
				    (shift ,state)))))
			actions)
	      (t (err "unexpected"))))
	  (reductions
	   `(reduc (aref *rules*
			   ,(position (butlast (car reductions))
				      *rules* :test #'equal))))
	  (t nil))))

(defun generate-actions ()
  (let ((i 0))
    (mapcar #'(lambda (x) (prog1 (list i x) (incf i)))
	    (map 'list #'generate-action *sets* *goto*))))

(defun generate-goto (symbol goto)
  (let ((targets (mapcar #'(lambda (x) (cdr (assoc symbol x))) goto))
	(i 0))
    `(,symbol (case state
		,@(mapcan #'(lambda (targ)
			      (prog1 (if targ (list (list i targ)) nil)
				(incf i)))
			  targets)
		(t (err "goto state"))))))

(defun generate-gotos ()
  (let* ((goto (map 'list #'(lambda (x)
			      (remove-if-not #'atom x :key #'car))
		    *goto*))
	 ;; extract all possible non-terminal symbols
	 (atoms (remove-duplicates
		 (apply #'append
			(remove nil (mapcar #'(lambda (x)
						(mapcar #'car x))
					    goto))))))
    (mapcar #'(lambda (x) (generate-goto x goto)) atoms)))


;; if *grammar* is defined, this should do the rest:
(construct-sets)
(eval `(defun parse (input)
	 (let ((stack nil))
	   (labels ((err (x)
		      (format t "error: ~A~%" x)
		      (return-from parse nil))
		    (shift (state)
		      (push (cons state (pop input)) stack))
		    (reduc (rule)
		      (let ((result (car rule))
			    (symbols (cdr rule)))
			;; pop elements on right side of rule
			(dolist (s symbols)
			  (pop stack))
			;; go to next state
			(push (cons (goto (caar stack) result)
				    result)
			      stack)))
		    (goto (state in)
		      (case in
			,@(generate-gotos)
			(t (err "goto state"))))
		    (action ()
		      (let ((in (car input)))
			(case (caar stack)
			  ,@(generate-actions)
			  (t (err "invalid state"))))))
	     (push (cons 0 'end) stack)
	     (do () (nil)
	       (action))))))