(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 (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 $2 $3))

            (defrule maskline (masklinea semicolon) nil)

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

            (defrule masklineelem (ident lbracket number colon number rbracket)
                    (list $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 $2 $3)) 

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

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

            (defrule valuespair (default-sym number ident) (list 'default $2 $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 $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 $1 $3))

            (defrule rvalue (ident) $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.txt"))