(defpackage #:clex
  (:use #:common-lisp #:cutil)
  (:export
   #:<lint>
   #:<lsymbol>
   #:<lstring>
   #:<lend>
   #:<lident>
   #:ident
   #:lexer))
(in-package #:clex)

(defclass <lexeme> () () (:metaclass <abstract-class>))
(defclass <lint> (<lexeme>) ((int :reader int)))
(defclass <lident> (<lexeme>) ((ident :reader ident)))
(defclass <lsymbol> (<lexeme>) ((lsymbol :reader lsymbol)))
(defclass <lstring> (<lexeme>) ((lstring :reader lstring)))
(defclass <lend> (<lexeme>) ())

(defclass <string-lexer> () ((lstring :initarg :s :accessor lstring)
                             (current :initform 0 :accessor current)
                             (size :accessor size)))

(defmethod initialize-object :after ((self <string-lexer>) initargs)
   (setf (size self) (length (lstring self))))

(defgeneric forward (cl &rest args))
(defmethod forward ((cl <string-lexer>) &rest args)
   (let ((incr (if (null args)
                   1
                   (car args))))
        (setf (current cl) (+ (current cl) incr))))

(defgeneric extract (pred cl))
(defmethod extract (pred (cl <string-lexer>))
   (let* ((st (lstring cl))
          (pos (current cl))
          (res nil))
     (labels ((ext (n)
		(if (and (< n (size cl)) (funcall pred (elt st n)))
                    (ext (+ n 1))
                    n)))
       (setq res (ext pos))
       (setf (current cl) res)
       (subseq (lstring cl) pos (- res pos)))))

(defgeneric extract-int (cl))
(defmethod extract-int ((cl <string-lexer>))
  (flet ((is-int (x)
           (and (char>= x #\0) (char<= x #\9))))
    (parse-integer (extract #'is-int cl))))

(defgeneric extract-ident (cl))
(defmethod extract-ident ((cl <string-lexer>))
  (flet ((is-alpha-num (x)
           (or (and (char>= x #\a) (char<= x #\z))
               (and (char>= x #\A) (char<= x #\Z))
               (and (char>= x #\0) (char<= x #\9))
               (char= x #\_))))
    (extract #'is-alpha-num cl)))

(defgeneric lexer (cl))
(defmethod lexer ((cl <string-lexer>))
  (flet ((lexer-char (c)
	   (cond ((member c '(#\space #\tab))
		  (forward cl)
		  (lexer cl))		; NB: tail recursion. ok?
		 ((or (and (char>= c #\a) (char<= c #\z))
		      (and (char>= c #\A) (char<= c #\Z)))
		  (make-instance (find-class '<lident>) 'i (extract-ident cl)))
		 ((char= c #\")
		  (forward cl)
		  (let ((res (make-instance (find-class '<lstring>) 's (extract (lambda (c) (char/= c #\")) cl))))
		    (forward cl)
		    res))
		 ((member c '(#\+ #\- #\* #\/ #\% #\& #\| #\! #\= #\( #\)))
		  (forward cl)
		  (make-instance (find-class '<lsymbol>) 's (string c)))
		 ((member c '(#\< #\>))
		  (forward cl)
		  
  ))))))
(provide "clex")