; -*- Mode: LISP; Package: GPSG; Base: 10; Syntax: Common-Lisp -*-
;; (in-package 'gpsg :use '(lisp))

(defun translate-cfg-to-rtn (cfg)
 (let ((rule-head-table (make-hash-table :test #'eq))
       (rule-tail-array nil)
       (headno 0))
   (do ((rules cfg (cdr rules)))
       ((null rules)
	(setq rule-tail-array (make-array headno :initial-element nil)))
     (if (not (gethash (caar rules) rule-head-table))
	 (progn (setf (gethash (caar rules) rule-head-table) headno)
		(incf headno))))

   (do ((rules cfg (cdr rules)))
       ((null rules))
     (let* ((head (caar rules)) (tail (cddar rules))
	    (headno (gethash head rule-head-table)))
       (push tail (aref rule-tail-array headno))))

  (append
   (mapcar #'(lambda (element)
	       (list (car element)
		     (mapcar #'(lambda (tail)
				 (cond ((null tail) '(pop))
				       ((gethash (first tail) rule-head-table)
					(list 'push (first tail)
					      (make-state-name (car element)
							       (list (first tail))
							       (rest tail))))
				       (t (list 'category
						(first tail)
						(make-state-name (car element)
								 (list (first tail))
								 (rest tail))))))
			     (aref rule-tail-array (second element)))))
	   (list-hash-table rule-head-table))
 
   (do ((elements (list-hash-table rule-head-table) (cdr elements))
	(l nil l))
       ((null elements) l)
     (let ((element (car elements)))
       (setq l (append l
		       (do ((tails (aref rule-tail-array (second element)) (cdr tails))
			    (m nil m))
			   ((null tails) m)
			 (let ((tail (car tails)))
			   (if tail
			       (setq m (append m
		      (do ((pre (list (first tail)) (append pre (list (first post))))
			   (post (rest tail) (rest post))
			   (stop nil stop)
			   (n nil n))
			  (stop n)
			(if (null post) (setq stop t))
			(push
			 (cond
			  ((null post)
			   `(,(make-state-name (car element) pre post)
			     ((pop))))
			  ((gethash (first post) rule-head-table)
			   `(,(make-state-name (car element) pre post)
			     ((push
			       ,(first post)
			       ,(make-state-name
				 (car element)
				 (append pre (list (first post)))
				 (rest post))))))
			  (t `(,(make-state-name (car element) pre post)
			       ((category
				 ,(first post)
				 ,(make-state-name
				   (car element)
				   (append pre (list (first post)))
				   (rest post)))))))
			 n))))))))))))))