(in-package "CL-USER")
 


(defun make-reader-file (fname)
  (let ((ifstream (open fname :direction :input)))
    (let ((chq nil))
      (return-from make-reader-file #'(lambda ()
                                        (setf chq
                                              (if (and (null (car chq)) (not (null (cdr chq))))
                                                  (cons nil nil)
                                                (if (and (null (car chq)) (null (cdr chq)) (consp chq))
                                                    (cons nil nil)
                                                  (cons (read-char ifstream nil nil) (car chq)))))
                                        (if (null (car chq))
                                            (close ifstream))
                                        chq)))))


(defun make-reader-string (str)
  (let ((isstream (make-string-input-stream str)))
    (let ((chq nil))
      (return-from make-reader-string #'(lambda ()
                                          (setf chq (cons (read-char isstream nil nil) (car chq)))
                                          (if (null (car chq))
                                              (close isstream))
                                          chq)))))

; Test-area

(setq rr (make-reader-file "/home/juergen/lisp/micasm/microprogram.mic"))
(setq rrs (make-reader-string "123+287.15-33.2*48.0072206;"))


(defun lex ()
  (let ((res (car (funcall rrs))))
    (values res res)))


; help functions

(defun test-union (lis1 lis2)
  (cond ((null lis1) (values lis2 nil))
        (t (multiple-value-bind (uni sec-enlarged) (test-union (cdr lis1) lis2)
             (if (member (car lis1) lis2)
                 (values uni sec-enlarged)
               (values (cons (car lis1) uni) t))))))


(defun fold (fun lis start)
  (cond ((null (cdr lis)) (funcall fun (car lis) start))
        (t (funcall fun (car lis) (fold fun (cdr lis) start)))))

(defun listify (str)
  (map 'list #'(lambda (x) x) str))

; parser generator

(defun extract-grammar-name (args)
  (car args))

(defun is-rule-p (lis)
  (eq (car lis) 'defrule))

(defun is-lexer-p (lis)
  (eq (car lis) 'deflexer))

(defun build-prod-db (args)
  (let ((prod-db (make-hash-table)))
    (setf (gethash '&prods prod-db) (make-hash-table))
    (loop for lis in (cdr args) do
      (cond ((is-rule-p lis)    
             (process-defrule lis prod-db))
            ((is-lexer-p lis)
             (process-lexer lis prod-db)))
          finally (return prod-db))))


(defun get-bodys (entry)
  (gethash 'bodys entry))

(defun (setf get-bodys) (val entry)
  (setf (gethash 'bodys entry) val))

(defun get-infos (entry)
  (gethash 'infos entry))

(defun (setf get-infos) (val entry)
  (setf (gethash 'infos entry) val))

(defun get-prods (entry)
  (gethash 'prods entry))

(defun (setf get-prods) (val entry)
  (setf (gethash 'prods entry) val))

(defun get-firsts (entry)
  (gethash 'firsts entry))

(defun (setf get-firsts) (val entry)
  (setf (gethash 'firsts entry) val))

(defun get-follows (entry)
  (gethash 'follows entry))

(defun (setf get-follows) (val entry)
  (setf (gethash 'follows entry) val))


(defun prod-db-entry-init ()
  (let ((entry (make-hash-table)))
    (setf (get-prods entry) nil)
    (setf (get-firsts entry) nil)
    (setf (get-follows entry) nil)
    (setf (get-infos entry) nil)
    (setf (get-bodys entry) nil)
    entry))

(defun process-defrule (rule prod-db)
  (let ((prods-t (gethash '&prods prod-db)))
    (setf (gethash '&non-terms prod-db)
          (union (gethash '&non-terms prod-db) (list (cadr rule))))
;    (format t "*** ~%~%")
;    (show-hash prods-t #'(lambda (x) x)) 
    (if (null (gethash (cadr rule) prods-t))
        (setf (gethash (cadr rule) prods-t) (prod-db-entry-init)))
    (setf (get-prods (gethash (cadr rule) prods-t)) 
          (cons (caddr rule) (get-prods (gethash (cadr rule) prods-t))))
    (setf (get-bodys (gethash (cadr rule) prods-t))
          (cons (cdddr rule) (get-bodys (gethash (cadr rule) prods-t))))
    (setf (gethash '&prods prod-db) prods-t)))

(defun process-lexer (lis prod-db)
  (setf (gethash '&lexer prod-db) (cadr lis)))


(defun add-firsts (prod-db)
  (let ((prods-t (gethash '&prods prod-db)))
    (with-hash-table-iterator (term prods-t)
      (let ((found nil)
            (ntermsym nil)
            (entry nil))
        (loop 
         do
         (multiple-value-setq (found ntermsym entry) (term))
         (if found
             (let ((prods (get-prods entry))
                   (uni nil)
                   (sec-enlarged))
               (loop 
                for pr in prods do
                (multiple-value-setq (uni sec-enlarged) (test-union (prod-first pr ntermsym prod-db) (get-firsts entry)))
                (if sec-enlarged
                    (setf (get-infos entry) (union (list 'added) (get-infos entry))))
                (setf (get-firsts entry) uni))))
         until (null found))))))


(defun empty-term-p (x)
  (and (symbolp x) (eq x 'eps)))

(defun non-termsym-p (x prod-db)
  (and (symbolp x) (not (empty-term-p x)) (member x (gethash '&non-terms prod-db))))
 
(defun prod-first (pr ntermsym prod-db)
  (let ((pr-start (car pr)))
    (sym-first-1 pr-start ntermsym prod-db)))


(defun sym-first-1 (pr-start ntermsym prod-db)
  (cond ((symbolp pr-start)
         (cond ((empty-term-p pr-start)
                (get-follows (gethash ntermsym (gethash '&prods prod-db))))
               ((non-termsym-p pr-start prod-db) (get-firsts (gethash pr-start (gethash '&prods prod-db))))
               (t (list pr-start))))
        ((stringp pr-start)
         (list (char pr-start 0)))
        ((listp pr-start)
         (cond ((eq (car pr-start) 'choose)
                (listify (cadr pr-start)))))
        (t nil)))

        
                  
(defun firsts-added (prod-db)
  (let ((prods-t (gethash '&prods prod-db)))
    (with-hash-table-iterator (term prods-t)
      (let ((found nil)
            (ntermsym nil)
            (entry nil))
        (loop
         with res-flag = nil
         do
         (multiple-value-setq (found ntermsym entry) (term))
         (if found
             (if (member 'added (get-infos entry))
                 (progn
                   (setf (get-infos entry) (remove 'added (get-infos entry)))
                   (setf res-flag t))))
         until (null found)
         finally return res-flag)))))
     

(defun follows-added (prod-db)
  (firsts-added prod-db))


(defun add-follows (prod-db)
  (let ((prods-t (gethash '&prods prod-db)))
    (with-hash-table-iterator (term prods-t)
      (let ((found nil)
            (ntermsym nil)
            (entry nil))
        (loop 
         do
         (multiple-value-setq (found ntermsym entry) (term))
         (if found
             (let ((prods (get-prods entry)))
               (loop 
                for pr in prods do
                (prod-follow pr ntermsym prod-db))))
         until (null found))))))

(defun prod-follow (pr ntermsym prod-db)
  (loop
   with pr-1 = pr
   with entry = nil
   with new-follows = nil
   with uni = nil
   with sec-enlarged = nil
   do
;   (format t "pr = ~A~%~%" pr)
   (if (non-termsym-p (car pr-1) prod-db)
       (progn
         (setf entry (gethash (car pr-1) (gethash '&prods prod-db)))
         (if (not (null (cdr pr-1)))
             (setf new-follows (sym-first-1 (cadr pr-1) 'error prod-db))
           (setf new-follows (get-follows (gethash ntermsym (gethash '&prods prod-db)))))
;         (format t "new-follows = ~A / ~A~%" new-follows (car pr-1))
         (multiple-value-setq (uni sec-enlarged) (test-union new-follows (get-follows entry)))
         (if sec-enlarged
             (setf (get-infos entry) (union (list 'added) (get-infos entry))))
         (setf (get-follows entry) uni)
         (setf (gethash (car pr-1) (gethash '&prods prod-db)) entry)))
   (setf pr-1 (cdr pr-1))
   until (null pr-1)
   finally return nil))
   



(defun compute-first-and-follow (prod-db)
  (loop 
   with firsts-a = nil
   with follows-a = nil
   do
   (add-firsts prod-db)
   (setf firsts-a (firsts-added prod-db))
   (format t "Firsts-a = ~A~%~%" firsts-a)
   (if (or firsts-a follows-a)
       (add-follows prod-db))
   (setf follows-a (follows-added prod-db))
   while (or firsts-a follows-a)
   finally (return prod-db)))


(defun check-disjoint (lis)
  (cond ((null lis) t)
        (t (and (check-disjoint (cdr lis))
                (fold #'(lambda (a b) (and (null a) b))
                      (mapcar #'(lambda (x) (intersection x (car lis))) (cdr lis)) t)))))

       
(defun check-prods (prod-db)
  (let ((is-ok t)
        (prods-t (gethash '&prods prod-db)))
    (with-hash-table-iterator (term prods-t)
      (let ((found nil)
            (ntermsym nil)
            (entry nil))
        (loop 
         do
         (multiple-value-setq (found ntermsym entry) (term))
         (if found
             (let ((prods (get-prods entry))
                   (prod-inis nil))
               (loop 
                for pr in (reverse prods) do
                (push (sym-first-1 (car pr) ntermsym prod-db) prod-inis))
               (if (not (check-disjoint prod-inis))
                   (setf is-ok nil))
               (setf (get-infos entry) (union (get-infos entry) (list (list 'prod-inis prod-inis))))))
         until (null found))))
    is-ok))
  

(defun build-parser (prod-db)
  (let ((non-term-list (gethash '&non-terms prod-db))
        (labels-defuns nil)
        (res nil))
    (setf labels-defuns
          (loop
           with res = nil
           for nterm in non-term-list do
           (push (compile-nt-sym nterm prod-db) res)
           finally
           return res))
    (setf res
          (list 'labels labels-defuns 
                `(multiple-value-bind (insym insym-val) (funcall lexer)
;                   (format t "insym = ~A * insym-val = ~A~%" insym insym-val)
                   (S insym insym-val lexer))))))

(defun get-prod-inis (nterm prod-db)
  (let ((prods-t (gethash '&prods prod-db)))
    (let ((nterm-infos (get-infos (gethash nterm prods-t))))
      (cadr (find 'prod-inis nterm-infos :key #'(lambda (x) (car x)))))))
      

(defun compile-nt-sym (nterm prod-db)
  (let ((prod-inis (get-prod-inis nterm prod-db))
        (lexer-fun 'lex))
    (list nterm (list 'insym 'insym-val lexer-fun)
;          `(format t "~a~%" ',nterm)
          (cons 'cond
                (append
                 (mapcar #'(lambda (x y z) (list (list 'member 'insym (list 'quote x)) (compile-prod y z lexer-fun prod-db)))
                        prod-inis
                        (get-prods (gethash nterm (gethash '&prods prod-db)))
                        (get-bodys (gethash nterm (gethash '&prods prod-db))))
                (list `(t (format t "error at: line = ~S : Production nterm = ~S : insym = ~S : insym-val = ~S ~%" 
                                  (funcall ,lexer-fun :line-number) ',nterm insym insym-val)))))))) 

(defun compile-prod (prod body lexer-fun prod-db)
  (let ((res nil)
        (dollar-args nil))
    (setf dollar-args
          (loop
           with i = 0
           for sym in prod do
           (setf i (+ 1 i))
           collect (intern (concatenate 'string "$" (format nil "~A" i)))))
    (setf dollar-args (append dollar-args (list 'out-val)))
    (setf res
          (loop
           with i = 1
           for sym in prod do
           (if (non-termsym-p sym prod-db)
               (progn
                 (push (list 'multiple-value-setq (list 'insym 'insym-val 'out-val)
                             (compile-prod-sym sym lexer-fun (= i 1) prod-db)) res)
                 (push (list 'setq  (nth (- i 1) dollar-args) 'out-val) res))
             (if (not (empty-term-p sym))
                 (progn
                   (push (list 'setq (nth (- i 1) dollar-args) 'insym-val) res)
                   (push (list 'multiple-value-setq (list 'insym 'insym-val) (list 'funcall lexer-fun)) res))
               (progn
                 nil)))
           (setf i (+ i 1))
           finally
           return res))
    (append (list
             'let
             (mapcar #'(lambda (x) (list x nil)) dollar-args))
            (append (reverse res) (list (list 'values 'insym 'insym-val (cons 'progn body))))))) 
                                                                  
(defun compile-prod-sym (sym lexer-fun is-first prod-db)
  (let ((lex-fun-call (if is-first
                          (list 'values 'insym 'insym-val 'insym-val)
                        (list 'funcall lexer-fun))))
    (cond ((symbolp sym)
           (cond ((empty-term-p sym)
                  (list 'values 'insym 'insym-val nil))
                 ((non-termsym-p sym prod-db)
                  (list sym 'insym 'insym-val lexer-fun))
                 (t lex-fun-call)))
          ((stringp sym)
           lex-fun-call)
          ((listp sym)
           lex-fun-call)
          (t nil))))



(defun show-hash (ht g)
  (maphash #'(lambda (x y) (format t "~A * ~A~%" x (funcall g y))) ht))

(defun show-db (prod-db)
  (show-hash prod-db #'(lambda (x) 
                         (cond ((listp x) x)
                               ((hash-table-p x)(show-hash x #'(lambda (y) (show-db y))))
                               (t x)))))
 

(defmacro defgrammar (&rest args)
  (let ((grammar-name nil)
        (prod-db nil))
    (setf grammar-name (extract-grammar-name args))
    (setf prod-db (build-prod-db args))
 ;   (show-db prod-db)
    (compute-first-and-follow prod-db)
    (format t "Prods ok = ~A ~%" (check-prods prod-db))
;    (show-db prod-db)
    (setf res (build-parser prod-db))
;    (list 'quote `(defun ,grammar-name ()
;       ,res))))
;    (pprint res)
    `(defun ,grammar-name (lexer)
       (multiple-value-bind (x y r) ,res
         r))))




(setq tst 
      
      (defgrammar arith
                  
                  (defrule S (TRM ER ";") (append (list $1) $2))
            
                  (defrule ER (eps) nil)
            
                  (defrule ER ((choose "+-") TRM ER) (append (list $1) (list $2) $3))
            
                  (defrule TRM (NUMBER TRMR) (append (list $1) $2))

                  (defrule TRMR (eps) nil)
                  (defrule TRMR ((choose "*/") NUMBER TRMR) (append (list $1) (list $2) $3))
                  
                  (defrule NUMBER (PRESIGN  MAINNUMBER) (if (null $1) $2
                                                          (list $1 $2)))
                  (defrule PRESIGN ((choose "+-")) $1)
                  (defrule PRESIGN (eps) nil)

                  (defrule MAINNUMBER (INTNUM MAINNUMBERR) (list $1 $2))

                  (defrule MAINNUMBERR ("." INTNUM) (cons $1 $2))
                  (defrule MAINNUMBERR (eps) nil)

                  (defrule INTNUM (DIGIT INTNUMR) (append (list $1) $2))
                  (defrule INTNUMR (DIGIT INTNUMR) (append (list $1) $2))
                  (defrule INTNUMR (eps) nil)

                  (defrule DIGIT ((choose "0123456789")) $1)))





(defun split-string (str delims)
  (let ((spos 0)
        (spos-new 0)
        (len (length str))
        (res nil))
    (loop
      do      
      (setf spos (position-if #'(lambda (c) (not (member c delims))) str :start spos))
      (when (null spos)
        (return-from split-string (reverse res)))
      (setf spos-new (position-if #'(lambda (c) (member c delims)) str :start spos))
      (when (null spos-new)
        (return-from split-string (reverse (push (subseq str spos len) res))))
      (push (subseq str spos spos-new) res)
      (setf spos spos-new))))