;;;
;;; tokenizer.lisp
;;;
;;; Tokenizer for smalltalk source.
;;;

;;; FIXME: BSD license header goes here.

(in-package "SMALLTALK-PARSER")

(defvar *next-token* nil
  "The next token in the input stream, or NIL if one hasn't been parsed yet.")

(defun reset-tokenizer ()
  "Reset the tokenizer to its initial state."
  (setf *next-token* nil))

(defun get-next-token ()
  "Returns the next token parsed from *STANDARD-INPUT* or NIL if there are no more tokens."
  (prog1
      (peek-next-token)
    (setf *next-token* nil)))

(defun peek-next-token ()
  (or *next-token*
      (setf *next-token* (parse-next-token))))

(defparameter *special-characters* '(#\+ #\/ #\\ #\* #\~ #\< #\> #\= #\@ #\% #\| #\& #\? #\!))

(defun parse-identifier-token ()
  (let* ((token-chars
	  (loop for char = (peek-char nil nil nil #\%)
		;; The #\% above is a random non-alphabetic character.
		while (alphanumericp char)
		do (read-char)
		collect char)))
    (coerce token-chars 'string)))

(defun parse-string-body ()
  (let ((string-chars
	  (loop for char = (read-char)
		unless (eql char #\')
		collect char
		else
		when (eql (peek-char nil nil nil) #\')
		do (read-char)
		and collect char
		else
		do (loop-finish))))
     (coerce string-chars 'string)))

(defun parse-array-element ()
  (let ((next-char (peek-char nil nil nil)))
    (cond
      ((eql next-char #\$)
       (read-char)
       (read-char))

      ((eql next-char #\')
       (read-char)
       (parse-string-body))

      ((and (characterp next-char)
	    (digit-char-p next-char))
       (parse-number-token (read-char)))

      (t
       (parse-array-or-symbol)))))

(defun parse-array ()
  `(:array
    ,@(loop for char = (peek-char t nil nil)
	    while char
	    until (eql char #\))
	    collect (parse-array-element)
	    finally (read-char nil nil))))

(defun parse-array-or-symbol ()
  (let ((next-char (peek-char nil nil nil)))
    (cond
      ((eql next-char #\()
       (read-char)
       (parse-array))

      ((and (characterp next-char)
	    (alpha-char-p next-char))
       (let* ((token-list
	       (loop for token = (parse-identifier-token)
		     collect token
		     while (eql (peek-char nil nil nil) #\:)
		     do (read-char)
		     collect ":"
		     while (let ((next-char (peek-char nil nil nil)))
			     (and (characterp next-char)
				  (alpha-char-p next-char)))))
	      (token (apply #'concatenate 'string token-list)))
	 `(:symbol ,token)))

      ;; Cheap hack: if it's a binary selector symbol, reuse parse-next-token.
      ((member next-char *special-characters*)
       `(:symbol ,(second (parse-next-token))))
      
      (t
       ;; FIXME: Signal an error here.
       ))))

(defun parse-number-token (first-char)
  (let ((base 10)
	(accumulated-number 0)
	(sign-weight 1)
	(saw-sign nil)
	(saw-radix nil)
	(accumulated-digits nil))
    (loop with digit
	  for char = first-char then (read-char nil nil nil)
	  while char
	  do (setf digit
		   (or (digit-char-p char)
		       (and (upper-case-p char)
			    (digit-char-p char base))))
	  when digit
	  do (setf accumulated-number (+ digit (* accumulated-number base))
		   accumulated-digits t)
	  else when (and (eql char #\-)
			 (not saw-sign))
	  do (setf sign-weight -1
		   saw-sign t
		   saw-radix t)
	  (assert (not accumulated-digits))
	  else when (and (eql char #\r)
			 (not saw-radix))
	  do (assert accumulated-digits)
	  (setf saw-radix t
		base accumulated-number
		accumulated-number 0
		accumulated-digits nil)
	  else do (unread-char char) (loop-finish))
    `(:number ,(* sign-weight accumulated-number))))

(defun parse-next-token ()
  (peek-char t nil nil)
  (let ((next-char (read-char nil nil)))
    (cond
      ((and (characterp next-char)
	    (alpha-char-p next-char))
       ;; Unread the first char to avoid silliness collecting the token.
       (unread-char next-char)
       (let ((token (parse-identifier-token)))
	 (if (eql (peek-char nil nil nil) #\:)
	     (progn
	       (read-char)
	       `(:keyword ,(format nil "~A:" token)))
	     `(:identifier ,token))))

      ((and (characterp next-char)
	    (digit-char-p next-char))
       `(:literal ,(parse-number-token next-char)))
      
      ((eql next-char #\:)
       `(:block-arg ,(parse-identifier-token)))

      ((eql next-char #\$)
       `(:literal ,(read-char)))

      ((eql next-char #\#)
       `(:literal ,(parse-array-or-symbol)))

      ((eql next-char #\')
       `(:literal ,(parse-string-body)))

      ((eql next-char #\")
       (loop for char = (read-char)
	     until (eql char #\"))
       (parse-next-token))

      ((eql next-char #\-)
       ;; #\% below is an arbitrary non-digit character.
       (if (digit-char-p (peek-char nil nil nil #\%))
	   `(:literal ,(parse-number-token next-char))
	   '(:binary-selector "-")))

      ((member next-char *special-characters*)
       (let* ((second-char (peek-char nil nil nil))
	      (char-list (or (and (member second-char *special-characters*)
				  (read-char)
				  (list next-char second-char))
			     (list next-char))))
	 `(:binary-selector ,(coerce char-list 'string))))

      ((member next-char '(#\( #\) #\[ #\] #\^ #\; #\, #\. #\_))
       next-char))))

;;; EOF
