(cl:in-package #:sod)

(defun play-fetch-token (string)
  (with-parser-context (string-parser :string string)
    (labels ((digit (radix)
	       (parse (filter (lambda (ch)
				(digit-char-p ch radix)))))
	     (number (radix &optional (initial 0))
	       (parse (many (a initial (+ (* radix a) it))
			(digit radix))))
	     (numeric (radix sigil)
	       (parse (seq ((first (peek (seq ((nil (funcall sigil))
					       (d (digit radix)))
					   d)))
			    (result (number radix first)))
			result))))
 (multiple-value-call #'values
    (loop
       (parse :whitespace)

       (cond-parse ()

	 ;; Give up at end-of-file.
	 (:eof
	  (return (values :eof nil)))

	 ;; Pick out comments.
	 ((peek (and #\/ #\*))
	  (parse (skip-many ()		; this may fail at eof; don't worry
		   (and (skip-many () (not #\*))
			(skip-many (:min 1) #\*))
		   (not #\/)))
	  (if-parse :eof ()
	    (cerror* "Unterminated comment")
	    (parse :any)))
	 ((and (peek (seq (#\/ #\/)))
	       (skip-many () (not #\newline))
	       (or :eof #\newline)))

	 ;; Quoted strings and characters.
	 ((or #\' #\")
	  (let ((quote it)
		(out (make-string-output-stream)))
	    (parse (skip-many ()
		     (or (seq ((ch (satisfies (lambda (ch)
						(and (char/= ch #\\)
						     (char/= ch quote))))))
			   (write-char ch out))
			 (seq (#\\ (ch :any))
			   (write-char ch out)))))
	    (if-parse :eof ()
	      (cerror* "Unterminated ~:[string~;character~] constant"
		       (char= quote #\'))
	      (parse :any))
	    (let ((string (get-output-stream-string out)))
	      (ecase quote
		(#\" (return (values :string string)))
		(#\' (case (length string)
		       (0 (cerror* "Empty character constant")
			  (return (values :char #\?)))
		       (1 (return (values :char (char string 0))))
		       (t (cerror* "Multiple characters in ~
				    character constant")
			  (return (values :char (char string 0))))))))))

	 ;; Identifiers.
	 ((seq ((first (satisfies (lambda (ch)
				    (or (char= ch #\_)
					(alpha-char-p ch)))))
		(ident (many (out (let ((s (make-string-output-stream)))
				    (write-char first s)
				    s)
				  (progn (write-char it out) out)
			      :final (get-output-stream-string out))
			 (satisfies (lambda (ch)
				      (or (char= ch #\_)
					  (alphanumericp ch)))))))
	    (return (values :id ident))))

	 ;; Numbers -- uses the machinery in the labels above.
	 ((or (seq (#\0
		    (i (or (numeric 8 (parser () (or #\o #\O)))
			   (numeric 16 (parser () (or #\x #\X)))
			   (number 8))))
		i)
	      (seq ((first (digit 10))
		    (rest (number 10 first)))
		rest))
	  (return (values :integer it)))

	 ;; Special separator tokens.
	 ("..."
	  (return (values :ellipsis :ellipsis)))

	 ;; Anything else is a standalone delimiter character.
	 (:any
	  (return (values it it)))))
    (parse (list () :any))))))