;;; MLEX 21 support 41 lex 36 tokenizer 98 total
(defmacro aif (cond then &optional else)
  `(let ((-it- ,cond))
     (if -it- ,then ,else)))

(defmacro awhen (cond &body body)
  `(aif ,cond (progn ,@body)))

(defconstant +eof-character+ (code-char 26))
(defun space-char? (c) (or (eql c #\space) (eql c #\tab) (eql c #\newline)))
(defun ! (s) (read-char s nil +eof-character+))
(defun un! (c s) (unread-char c s))

(defun d+ (d N) (+ (* N 10) (digit-char-p d)))

(defun f+ ()
  (let ((scale 1.0))
    (lambda (d N)
      (setq scale (* scale 0.1))
      (+ N (* (digit-char-p d) scale)))))

(defun bclear (b) 
  (setf (fill-pointer b) 0)
  b)

(defun bpush (c b)
  (vector-push (char-upcase c) b)
  b)

#||
;;; MLEX - macro based lexer.

-c- current character
-s- stream
-r- buffer of results

(is c) - (eql -c- c) returns c, input is advanced.
(satisfies f) - (f -c-) is nonnil, returns result of (f -c-), input is advanced.
(either <pattern> ...) returns the result of the first pattern that 
begins to match.  There is no backtracking.
(seq <pattern> ...) input must match each pattern sequentially,
returns a list of the resulting matches
(opt <pattern>) same as (either (seq <pattern>) (seq)).
(many <pattern> init accumulator)
(cook <pattern> . <action>)
||#

(defmacro s++ () `(setq -c- (! -s-)))

(defmacro is (c)
  `(let ((c ,c))
     (when (eql -c- c)
       (s++)
       c)))

(defmacro either (&body args)
  (if (null args) '()
      (if (null (cdr args)) (car args)
          `(or ,(car args) (either ,@(cdr args))))))

(defmacro seq (&body args)
  `(let ((-r- '()))
     (seq-1 ,@args)))

(defmacro seq-1 (&body args)
  (cond ((null args) '(reverse -r-))
        ((eq (car args) 'drop)
         `(let ((-r- (cdr -r-)))
            (seq-1 ,@(cdr args))))
        (t`(awhen ,(car args)
             (push -it- -r-)
             (seq-1 ,@(cdr args))))))

(defmacro opt (what) 
  `(list ,what))

(defmacro satisfies (what) 
  `(let ((-it- -c-))
     (when (,what -c-) (s++) -it-)))
        
(defmacro many (what init how)
  `(let ((sum ,init)
         (how ,how))
     (loop
       (aif ,what
            (setq sum (funcall how -it- sum))
            (return sum)))))

(defmacro cook (what &body how) `(awhen ,what ,@how))
           
(defmacro defreader (name args &body forms)
  `(defun ,name (-s- ,@args)
     (let* ((-c- (! -s-))
            (-it- (progn ,@forms)))
       (un! -c- -s-)
       -it-)))

(defun cook-number (x)
  (destructuring-bind ((sign) n (f) (e)) x
    (if e (destructuring-bind ((es) exp) e
            (cook-number-1 (eq sign #\-) n f (if (eq es #\-) (- exp) exp)))
        (cook-number-1 (eq sign #\-) n f 0))))

(defun cook-number-1 (s n f e)
  (cond ((or (null f) (and (= f 0.0) (= e 0)))
         (if s (- n) n))
        (t  (let ((n (* (+ n f) (expt 10.0 e))))
              (if s (- n) n)))))

(defmacro sign () `(opt (either (is #\+) (is #\-))))

(defmacro digits () 
  `(cook 
    (seq (satisfies digit-char-p)
         (many (satisfies digit-char-p) (digit-char-p (pop -r-)) #'d+))
    (first -it-)))

(defmacro skip (what)
  `(many ,what t #'(lambda (a b) a b)))

'(catch give
  (either (seq (is #\<) (either (seq (is #\-) (throw give '<-))
                                (seq (is #\=) (throw give '<=))
                                (seq (is #\<) (trhow give '<<))
                                (throw give '<)))))


(let ((b (make-array 300 :element-type 'character :fill-pointer t)))
  (defreader read-token ()
    (skip (satisfies space-char?))
    (either 
      (cook
        (seq (sign) 
             (digits)
             (opt (cook
                    (seq (is #\.) drop (many (satisfies digit-char-p) 0.0 (f+)))
                    (first -it-)))
             (opt (seq (either (is #\e) (is #\E)) drop
                       (sign)
                       (digits))))
        (cook-number -it-))
      (cook 
        (seq (satisfies alpha-char-p) 
             (many (satisfies alphanumericp)
                   (bpush (pop -r-) (bclear b)) #'bpush))
        (intern (first -it-))))))