;;; 8 support 26 lex 36 tokenizer 70 total.

#||
A version of Henry Baker's META parse.  See:

Henry G. Baker, Pragmatic Parsing in Common Lisp; or, putting defmacro 
on Steroids,
Lisp Pointers, IV, 2, 1991, p. IV-2.3 - IV-2.15.

Rather than extending the reader to have META syntax we simply use LISP forms
instead.

(match-it <pattern>) returns T if characters read using meta-read-char and
meta-peek-char match the pattern, <pattern>.  The pattern can contain 
expressions that perform side effects to get some real work done, such as 
parsing.

Pattern language:
<char> - matches that character, input is advanced.
variable - matches that variable, input is advanced.
(class test) - satisfies the function named test input is advanced.  The 
variable it is bound to the matching character.
lisp expression - the lisp expression is executed, and matches if it
 returns nonnil
(seq <pattern> ...)  - matches if all patterns match sequentially.

(either <pattern> ...) - matches if one pattern matches.  There is no 
backtracking.  

(opt <pattern>) - same as (either <pattern> (seq))
(many <pattern>) - matches 0 or more occurances of <pattern>

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

(defun space-char? (c) (or (eql c #\space) (eql c #\tab) (eql c #\newline)))

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

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

(defmacro match-it (form)
  (labels
    ((compile-it (form)
       (typecase form
         (cons form
               (case (car form)
                 (seq `(and ,@(mapcar #'compile-it (cdr form))))
                 (either `(or  ,@(mapcar #'compile-it (cdr form))))
                 (opt (compile-it `(either ,(cadr form) (seq))))
                 (many `(loop (if (not ,(compile-it (cadr form)))
                                (return T))))
                 (class `(when (,(cadr form) (meta-peek-char))
                           (setq it (meta-read-char))
                           t))
                 (t form)))		; Escape to lisp, must return nonnil.
         (t `(when (eql (meta-peek-char) ,form)         ; Constant or variable.
               (meta-read-char))))))
    `(let ((current-char (peek-char nil))
	   (it NIL))		; The character just matched.
       (macrolet
         ((meta-peek-char () `current-char)
          (meta-read-char ()
            `(prog1 (read-char)
	       (setq current-char (peek-char nil)))))
         it
	 ,(compile-it form)))))

(let ((b (make-array 300 :element-type 'character :fill-pointer t)))
  (defun read-token-meta (s)
    (let ((*standard-input* s)
          (neg? nil)
          (n 0)
          (eneg? nil)
          (e 0)
          (scale 1.0))
      (match-it 
       (seq
        (many (class space-char?))
        (either
         (seq 
          (opt (either #\+ (seq #\- (setq neg? t))))
          (class digit-char-p)
          (setq n (dd+ it n))
          (many (seq (class digit-char-p)
                     (setq n (dd+ it n))))
          (opt (seq #\. 
                    (many (seq (class digit-char-p)
                               (setq scale (* scale 0.1))
                               (setq N (+ N (* (digit-char-p it) scale)))))))
          (opt (seq (either #\e #\E)
                    (opt (either #\+ (seq #\- (setq eneg? t))))
                    (many (seq (class digit-char-p)
                               (setq e (dd+ it e))))))
          (let ((e (if eneg? (- e) e)))
            (if (zerop e) (if neg? (- n) n)
                (let ((n (* n (expt 10.0 e))))
                  (if neg? (- n) n)))))
         (seq (class alpha-char-p)
              (bpush it (bclear b))
              (many (seq (class alphanumericp) (bpush it b)))
              (intern b))))))))