(defun read-main (read-ch)
  (let ((ini-ch nil)
        (next-ch (funcall read-ch 'next))
        (same-ch (funcall read-ch 'same)))
    (consume-whitespace read-ch)
    (setf ini-ch (funcall same-ch))
    (cond ((is-symbol-start ini-ch) (read-symbol read-ch))
          ((is-quote-start ini-ch) 
           (funcall next-ch)
           (list 'quote (read-main read-ch)))
          ((is-macro-start ini-ch) (read-macro read-ch))
          ((is-lparen ini-ch) 
           (let ((lv nil)
                 (rv nil))
             (funcall next-ch)
             (consume-whitespace read-ch)
             (cond ((is-rparen (funcall same-ch))
                    (let ()
                      (funcall next-ch)
                      nil))
                   (t (let ()
                        (setf lv (read-main read-ch))
                        (setf rv (read-rest-list read-ch))
                        (cons lv rv))))))
          (t (throw 'read-error "read:err:unknown form"))))) 
                      
(defun read-rest-list (read-ch)
  (let ((lv nil)
        (rv nil)
        (next-ch (funcall read-ch 'next))
        (same-ch (funcall read-ch 'same))
        (peek-ch (funcall read-ch 'peek)))
    (consume-whitespace read-ch)
    (cond ((is-dot (funcall same-ch))
           (let ()
             (cond ((is-whitespace (funcall peek-ch))
                    (funcall next-ch)
                    (setf rv (read-main read-ch))
                    (consume-whitespace read-ch)
                    (cond ((is-rparen (funcall same-ch))
                           (funcall next-ch)
                           rv)
                          (t (throw 'read-error "read:err:missing rparen:1"))))
                   (t 
                    (setf lv (read-main read-ch))
                    (setf rv (read-rest-list read-ch))
                    (cons lv rv)))))
          (t (cond ((is-rparen (funcall same-ch))
                    (funcall next-ch)
                    nil)
                   (t 
                    (setf lv (read-main read-ch))
                    (setf rv (read-rest-list read-ch))
                    (cons lv rv)))))))
                   

(defun is-quote-start (ch)
  (eq ch #\'))

(defun is-macro-start (ch)
  (eq ch #\#))

(defun is-atom-start (ch)
  (or (is-alpha ch) (is-digit ch) (member ch '( #\* #\\ #\+ #\- #\% #\&))))

(defun is-fixnum-start (ch)
  (or (is-digit ch) (member ch '(#\- #\+))))

(defun is-float-start (ch)
  (or (is-fixnum-start ch) (eq ch #\.)))

(defun is-symbol-start (ch)
  (or (is-fixnum-start ch) (is-float-start ch) (is-atom-start ch)))

(defun is-symbol-ch (ch)
  (or (is-alpha ch) (is-digit ch) (member ch '( #\* #\\ #\+ #\- #\. #\< #\> #\= #\? #\_ #\% #\:))))

(defun is-lparen (ch)
  (eq ch #\())

(defun is-rparen (ch)
  (eq ch #\)))

(defun is-dot (ch)
  (eq ch #\.))

(defun is-sign (ch)
  (or (eq ch #\+) (eq ch #\-)))

(defun is-whitespace (ch)
  (member ch '(#\Space)))

(defun is-atom-char (ch)
  (or (is-alpha ch) (is-digit ch) (member ch '(#\- #\+))))

(defun is-digit (ch)
  (and (>= (char-code ch) (char-code #\0)) (<= (char-code ch) (char-code #\9))))

(defun is-hex-digit (ch)
  (or (is-digit ch) (and (>= (char-code ch) (char-code #\a)) (<= (char-code ch) (char-code #\f))))) 

(defun is-alpha (ch)
  (and (>= (char-code ch) (char-code #\a)) (<= (char-code ch) (char-code #\z))))

(defun is-expo-init (ch)
  (member ch '( #\e #\E )))


(defun consume-whitespace (read-ch)
  (let ((next-ch (funcall read-ch 'next))
        (same-ch (funcall read-ch 'same)))
    (do ((akt-ch (funcall same-ch) (funcall next-ch)))
        ((not (is-whitespace akt-ch))))))


(defun read-symbol (read-ch)
  (let ((sym-cl nil)
        (num nil)
        (next-ch (funcall read-ch 'next))
        (same-ch (funcall read-ch 'same)))
    (do ((akt-ch (funcall same-ch) (funcall next-ch)))
        ((not (is-symbol-ch akt-ch)))
      (setf sym-cl (cons akt-ch sym-cl)))
    (setf sym-cl (reverse sym-cl))
    (setf num (read-cl-as-number sym-cl))
    (if num
        num
      (make-atom-str (make-string-cl sym-cl)))))
      



(defun make-string-cl (cl)
  (let ((s (make-string (length cl))))
    (do ((i 0 (1+ i))
         (clx cl (cdr clx)))
        ((null clx) s)
      (setf (char s i) (car clx)))))

(defun make-atom-str (str)
  (list 'atom str))

(defun read-macro (read-ch)
  (let ((next-ch (funcall read-ch 'next))
        (same-ch (funcall read-ch 'same))
        (akt-ch nil)
        (res nil))
    (setf akt-ch (funcall next-ch))
    (cond ((eq akt-ch #\')
           (let ()
             (funcall next-ch)
             (list 'function (read-main read-ch))))
          ((eq akt-ch #\Q)
           (let ()
             (setf res nil)
             (do ((i 0 (+ 1 i)))
                 ((> i 7))
               (setf akt-ch (funcall next-ch))
               (if (not (is-hex-digit akt-ch))
                   (throw 'read-error "read:err:Q malformed:001"))
               (setf res (cons akt-ch res)))
             (funcall next-ch)
             (setf res (reverse res))
             (make-q res)))
          ((eq akt-ch #\\)
           (setf akt-ch (funcall next-ch))
           (funcall next-ch)
           akt-ch)
          (t (throw 'read-error "read:err:undefined macro:001")))))

(defun make-q (hexl)
  (list 'Q hexl))


(defun digit-to-num (ch)
  (- (char-code ch) (char-code #\0)))

(defun read-cl-as-number (cl)
  (let ((sign +1)
        (sign-exp +1)
        (cll cl)
        (pre-dot 0)
        (post-dot 0)
        (exp-val 0)
        (dig-cnt 0)
        (akt-ch nil))
    (cond ((eq (car cll) #\+)
           (let ()
             (setf cll (cdr cll))))
          ((eq (car cll) #\-)
           (let ()
             (setf cll (cdr cll))
             (setf sign -1))))
    (setf dig-cnt 
          (do ((pre-digs 0 (+ pre-digs 1)))
              ((or (not cll) (not (is-digit (car cll)))) pre-digs)
            (setf akt-ch (car cll))
            (setf pre-dot (+ (* pre-dot 10) (digit-to-num akt-ch)))
            (setf cll (cdr cll))))
    (if (and (null cll) (> dig-cnt 0))
        (return-from read-cl-as-number (* sign pre-dot)))
    (if (eq (car cll) #\.)
        (let ()
          (setf cll (cdr cll))
          (do ((dez-fact 0.1 (* 0.1 dez-fact))
               (post-digs 0 (+ post-digs 1)))
              ((or (not cll) (not (is-digit (car cll)))))
            (setf akt-ch (car cll))
            (setf cll (cdr cll))
            (if (< post-digs 6)
                (setf post-dot (+ post-dot (* dez-fact (digit-to-num akt-ch))))))))
    (if (null cll)
        (return-from read-cl-as-number (* sign (+ pre-dot post-dot))))
    (if (is-expo-init (car cll))
        (let ()
          (setf cll (cdr cll))
          (if (is-sign (car cll))
              (let ()
                (if (eq (car cll) #\-)
                    (setf sign-exp -1))
                (setf cll (cdr cll))))
          (do ((exp-digs 0 (+ exp-digs 1)))
              ((or (not cll) (not (is-digit (car cll)))))
            (setf akt-ch (car cll))
            (setf exp-val (+ (* exp-val 10) (digit-to-num akt-ch)))
            (setf cll (cdr cll)))
          (setf exp-val (expt 10.0 (* sign-exp exp-val)))))
    (if (null cll)
        (return-from read-cl-as-number (* sign (+ pre-dot post-dot) exp-val)))
    nil))