(in-package "CL-USER")


(defun put-field (n a b)
  (let ((mask (- (expt 2 (+ (- a b) 1)) 1)))
    (ash (logand mask n) b)))


(defun make-micro-store ()
  (with-open-file (fin "micro.input" :direction :input)
    (with-open-file (fout "micro.data" :direction :output :if-exists :overwrite :if-does-not-exist :create)
      (loop
       with akt-line = nil
       with addr = -1
       with addr-new = nil
       with val = nil
       do
       (setf akt-line (read-line fin nil nil))
       (if (null akt-line)
           (return-from nil nil))
       (setf akt-line (split-string akt-line '(#\Space #\Tab #\Newline)))
       (setf akt-line (mapcar #'(lambda (x) (read-from-string x)) akt-line))
;       (format t "**** ~a~%" akt-line)
       (setf addr-new (car akt-line))
       (setf val
             (+
              (put-field (nth 1 akt-line) 31 27)
              (put-field (nth 2 akt-line) 26 22)
              (put-field (nth 3 akt-line) 21 17)
              (put-field (nth 4 akt-line) 16 14)
              (put-field (nth 5 akt-line) 13 11)
              (put-field (nth 6 akt-line) 10 9)
              (put-field (nth 7 akt-line) 8 6)
              (put-field (nth 8 akt-line) 5 0)))
       (if (/= addr-new (+ addr 1))
           (format fout "@~4,'0X ~%" addr-new))
       (format fout "~32,'0B~%" val)
       (setf addr addr-new)))))


(defparameter *letters* (loop for i from 0 to 25 collect (code-char (+ (char-code #\A) i))
                              collect (code-char (+ (char-code #\a) i))))


(defparameter *digits-list*  '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
  

(defparameter *white-space-list* '(#\Space #\Tab #\Newline))

(defparameter *ident-delims* (union (union *white-space-list* '(#\, #\; #\= #\: #\[)) '(nil)))

(defparameter *key-words* (make-hash-table))

(mapcar #'(lambda (x) 
              (setf (gethash (intern (string-upcase (string x))) *key-words*) 
                    (intern (concatenate 'string (string-upcase (string x)) "-SYM"))))
          '(mask endmask values endvalues end default))


(defun check-hash ()
  (maphash #'(lambda (k v) (format t "~S ~S~%"  k v)) *key-words*))


(defun is-start (ch)
  (and (not (null (car ch))) (null (cdr ch))))

(defun is-end (ch)
  (and (null (car ch)) (null (cdr ch))))

(defun comment-start-p (ch)
  (and (eql (car ch) #\*) (eql (cdr ch) #\/)))

(defun comment-end-p (ch)
  (or (is-end ch) (and (eql (car ch) #\/) (eql (cdr ch) #\*))))

(defun skip-comment (ch cread)
  (let ((ch1 ch))
    (loop while (not (comment-end-p ch1)) do 
          (setf ch1 (funcall cread))
          finally
          (funcall cread))))
    

(let ((line-num 1))

(defun lexmic (cread &optional line-req)
  (let ((ident nil)
        (ch (funcall cread)))
    (when (not (null line-req))
      (return-from lexmic line-num))
    (when (is-end ch)
      (return-from lexmic (values nil nil)))
    (loop
     named skip-blank
     do
     (loop
      while (or (member (cdr ch) *white-space-list*) (is-start ch))
      do
      (if (eq (cdr ch) #\newline)
          (setf line-num (+ line-num 1)))
      (setf ch (funcall cread)))
     (when (is-end ch)
       (return-from lexmic (values nil nil)))
     (if (comment-start-p ch)
         (progn (skip-comment ch cread) (setf ch (funcall cread)))
       (return-from skip-blank)))
    (cond
     ((digit-char-p (cdr ch))
      (values 'number (read-from-string (parse-number ch cread))))
     ((alpha-char-p (cdr ch))
      (setf ident (string-upcase (parse-ident ch cread)))
      (values (gethash (intern ident) *key-words* 'ident) ident))
     (t
      (case (cdr ch)
        (#\, (values 'comma 'comma))
        (#\; (values 'semicolon 'semicolon))
        (#\= (values 'equalsign 'equalsign))
        (#\: (values 'colon 'colon))
        (#\. (values 'period 'period))
        (#\[ (values 'lbracket 'lbracket))
        (#\] (values 'rbracket 'rbracket))
        (t (values 'character (cdr ch)))))))))


(defun parse-number (ch cread)
  (let ((resl "")
        (ch1 ch))
    (loop until (or (null (car ch1)) (not (digit-char-p (car ch1)))) do (setf resl (concatenate 'string resl (string (cdr ch1))))
          (setf ch1 (funcall cread))
          finally return (concatenate 'string resl (string (cdr ch1))))))

    
(defun parse-ident (ch cread)
  (let ((resl "")
        (ch1 ch))
    (loop until (member (car ch1) *ident-delims*) do (setf resl (concatenate 'string resl (string (cdr ch1))))
          (setf ch1 (funcall cread))              
          finally return (concatenate 'string resl (string (cdr ch1))))))



(defgrammar micprog
            
            (defrule s (inits instructions endsym) (list $1 $2))

            (defrule inits (eps) nil)

            (defrule inits (initelem inits) (append (list $1) $2))

            (defrule initelem (mask-sym ident maskline endmask-sym) (list 'mask (intern $2) $3))

            (defrule maskline (masklinea semicolon) $1)

            (defrule masklinea (masklineelem masklinerest) (append (list $1) $2))

            (defrule masklineelem (ident lbracket number colon number rbracket)
                    (list (intern $1) $3 $5))

            (defrule masklinerest (eps) nil)
            
            (defrule masklinerest (masklineelem masklinerest) (append (list $1) $2))

            (defrule initelem (values-sym ident valuesline endvalues-sym) (list 'value (intern $2) $3)) 

            (defrule valuesline (eps) nil)
            
            (defrule valuesline (valuespair valuesline) (append (list $1) $2))

            (defrule valuespair (number ident) (list $1 (intern $2)))

            (defrule valuespair (default-sym number ident) (list 'default $2 (intern $3)))

            (defrule instructions (eps) nil)

            (defrule instructions (instrblock instructions) (append (list $1) $2))

            (defrule instrblock (instrlabel instrlines) (list $1 $2))

            (defrule instrlabel (colon ident colon number colon) (list 'ilabel (intern $2) $4))

            (defrule instrlines (eps) nil)

            (defrule instrlines (instrline instrlines) (append (list $1) $2))

            (defrule instrline (instrlinepair instrlinerest) (append (list $1) $2))

            (defrule instrlinerest (semicolon) nil)

            (defrule instrlinerest (comma instrlinepair instrlinerest) (append (list $2) $3))

            (defrule instrlinepair (ident equalsign rvalue) (list 'eq (intern $1) $3))

            (defrule rvalue (ident) (intern $1))

            (defrule rvalue (character) (string $1))

            (defrule rvalue (number) $1)

            (defrule endsym (end-sym) nil))


            
(setf rrq (make-reader-string "mask mm a[23:22]; endmask values v1 22 b default 21 a  endvalues end")) 

(defun lll (&optional line-req)
  (if line-req
      (lexmic rrf line-req)
    (lexmic rrf)))


(setq rr (make-reader-file "/home/juergen/lisp/micasm/test.mic"))
(setq rrf (make-reader-file "/home/juergen/lisp/micasm/microprogram.mic"))


(defun mp-get-masks (stat)
  (gethash '&masks stat))

(defun get-mask-fields (stat)
  (gethash '&mask-fields stat))

(defun mp-add-mask (mask stat)
  (let ((masks (mp-get-masks stat))
        (mask-lefts (gethash '&mask-fields stat)))
    (loop
     for mask-field in (caddr mask) do
     (setf mask-lefts (union mask-lefts (list (car mask-field)))))
    (setf (gethash '&mask-fields stat) mask-lefts)
    (setf (gethash '&masks stat) (cons mask masks))))


(defun init-stat (stat)
  (setf (gethash '&mask-fields stat) nil)
  (setf (gethash '&init-vals stat) (make-hash-table)))


(defun mic-file-out (stat)
  (loop
   for mask in (mp-get-masks stat)
   do
   (mic-file-out-mask (cadr mask) stat)))

(defun mic-file-out-mask (mask stat)
  (let ((fname (concatenate 'string (string-downcase (string mask)) ".micdata")))
    (with-open-file (fo fname :direction :output :if-exists :supersede :if-does-not-exist :create)
      (let ((val-lis (gethash mask stat)))
        (loop
         for vv in val-lis do
         (cond 
          ((numberp vv)
             (format fo "~32,'0B~%" vv))
          ((listp vv)
           (format fo "@~8,'0X~%" (cadr vv)))
          (t (error "malformed element ~a at output of mask ~a~%" vv mask))))))))


(defun mic-comp (mprog)
  (let ((stat (make-hash-table)))
    (init-stat stat)
    (mic-comp-inits (car mprog) stat)
    (mic-comp-instrs (car (cdr mprog)) stat)
    (mic-file-out stat)
    stat))

(defun is-mask-p (e)
  (eq (car e) 'mask))

(defun is-value-p (e)
  (eq (car e) 'value))

(defun mic-comp-inits (mp-inits stat)
  (loop
   for ee in mp-inits do
   (cond ((is-mask-p ee)
          (do-mask ee stat))
         ((is-value-p ee)
          (do-value ee stat)))))

(defun do-mask (ee stat)
  (mp-add-mask ee stat)
  (setf (gethash (cadr ee) stat) nil))


(defun set-init-vals (id stat val)
  (setf (gethash id (gethash '&init-vals stat)) val))

(defun get-init-val (id stat)
  (gethash id (gethash '&init-vals stat)))


(defun do-value (ee stat)
  (let ((id (cadr ee)))
    (set-init-vals id stat (make-hash-table))
    (loop 
     for pp in (caddr ee) do
     (when (eq (car pp) 'default)
         (setf (gethash (car pp) (get-init-val id stat)) (cadr pp))
         (setf pp (cdr pp)))
     (setf (gethash (cadr pp) (get-init-val id stat)) (car pp)))))





(defun print-stats (stat)
  (show-db stat))

    
(defun tst ()
  (setq rrf (make-reader-file "/home/juergen/cedar/lisp/micasm/microprogram.mic"))
  (mic-comp (micprog 'lll)))

(defun get-mic-prog ()
  (setq rrf (make-reader-file "/home/juergen/cedar/lisp/micasm/microprogram.mic"))
  (micprog 'lll))

(defun analyze (field value)
  (let ((mp (get-mic-prog)))
    (loop 
     with addr-0 = nil
     with addr = nil
     with resa = nil
     with resla = nil
     for x in (cadr mp) do
     (setf addr (* *mp-pagesize* (caddr (car x))))
     (setf addr-0 addr)
     (setf resa
           (loop
            with res = nil
            with resl = nil
            for line in (cadr x) do
            (setf res 
                  (loop
                   for pair in line do
                   (if (and
                        (eq (cadr pair) field)
                        (eq (caddr pair) value))
                       (return (list addr line)))))
            (setf addr (1+ addr))
            (if res 
                (setf resl (cons res resl)))
            finally return (reverse resl)))
     (format t "addr-diff = ~a ~a ~%" (cadar x) (- addr addr-0))
     (if resa
         (setf resla (append resla resa)))
     finally return resla)))
     
(defun analyze-follows (field-1 value-1 field-2 value-2)
  (let ((lis-1 (analyze field-1 value-1))
        (lis-2 (analyze field-2 value-2)))
    (setf lis-1 (mapcar #'car lis-1))
    (setf lis-2 (mapcar #'car lis-2))
    (loop
     with resl = nil
     for line in lis-1 do
     (if (member (1+ line) lis-2)
         (push line resl))
     finally return (reverse resl))))
     
      
      

(defun mic-comp-instrs (mp-instrs stat)
  (loop
   for lblock in mp-instrs do
   (do-mic-block lblock stat)))


(defparameter *mp-pagesize* 8)

(defun do-mic-block (lblock stat)
  (let ((mpc (caddr (car lblock))))
    (setf mpc (* mpc *mp-pagesize*))
    (loop
     with is-first-line = t
     for line in (cadr lblock) do
     (process-masks (mp-get-masks stat) line mpc stat is-first-line)
     (when is-first-line
       (setf is-first-line nil))
     (setf mpc (+ mpc 1)))))

(defun process-masks (masks line mpc stat is-first)
  (loop
   with mask-fields = (get-mask-fields stat)
   for line-eq in line do
   (if (not (member (cadr line-eq) mask-fields))
       (error "illegal left side ~a in line ~a: no such field in masks~%" (cadr line-eq) line)))
  (loop
   for mm in masks do
   (when is-first 
     (setf (gethash (cadr mm) stat) (append (gethash (cadr mm) stat) (list (list 'mpc mpc)))))
   (add-mask-line mm line mpc stat))) 

(defun add-mask-line (mask line mpc stat)
  (let ((mask-name (cadr mask)))
    (let ((line-assoc (mapcar #'(lambda (x) (cons (cadr x) (caddr x))) line)))
      (let ((res (gethash mask-name stat))
            (val nil))
        (setf val
              (loop
               with val = 0
               with nn = 0
               with line-eq = nil
               for mask-el in (caddr mask) 
               do
               (setf line-eq (assoc (car mask-el) line-assoc))
               (if (null line-eq)
                   (setf line-eq (cons (car mask-el) 'default))
                 (progn
                   (setf line-assoc (remove-if #'(lambda (x) (eq (car x) (car line-eq))) line-assoc))))
               (cond
                ((numberp (cdr line-eq)) (setf nn (cdr line-eq)))
                ((stringp (cdr line-eq))
                 (if (string= (cdr line-eq) "+")
                     (setf nn (+ mpc 1))
                   (setf nn nil)))
                (t
                 (setf nn (gethash (cdr line-eq) (get-init-val (car mask-el) stat)))))
               (if (null nn)
                   (error "could not resolve: ~a in line: ~a~%" (car mask-el) line))
               (format t "nn= ~a + " nn)
               (setf val (+ val (put-field nn (cadr mask-el) (caddr mask-el))))
               finally
               return val))
        (format t "val = ~a~%" val)
        (setf (gethash mask-name stat) (append res (list val)))))))