;;; -*-lisp-*-
;;;
;;; Implementation of lexical analysis protocol.
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensble Object Design, an object system for C.
;;;
;;; SOD is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; SOD is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with SOD; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

(cl:in-package #:sod)

;;;--------------------------------------------------------------------------
;;; Basic lexical analyser.

(defstruct (pushed-token
	     (:constructor make-pushed-token (type value location)))
  "A token that has been pushed back into a lexer for later processing."
  type value location)

;;; Class definition.

(export 'basic-lexer)
(defclass basic-lexer ()
  ((stream :initarg :stream :type stream :reader lexer-stream)
   (char :initform nil :type (or character null) :reader lexer-char)
   (pushback-chars :initform nil :type list)
   (token-type :initform nil :accessor token-type)
   (token-value :initform nil :accessor token-value)
   (location :initform nil :reader file-location)
   (pushback-tokens :initform nil :type list))
  (:documentation
   "Base class for lexical analysers.

   The lexer reads characters from STREAM, which, for best results, wants to
   be a POSITION-AWARE-INPUT-STREAM.

   The lexer provides one-character lookahead by default: the current
   lookahead character is available to subclasses in the slot CHAR.  Before
   beginning lexical analysis, the lookahead character needs to be
   established with NEXT-CHAR.  If one-character lookahead is insufficient,
   the analyser can push back an arbitrary number of characters using
   PUSHBACK-CHAR.

   The NEXT-TOKEN function scans and returns the next token from the STREAM,
   and makes it available as TOKEN-TYPE and TOKEN-VALUE, providing one-token
   lookahead.  A parser using the lexical analyser can push back tokens using
   PUSHBACK-TOKENS.

   For convenience, the lexer implements a FILE-LOCATION method (delegated to
   the underlying stream)."))

;;; Reading and pushing back characters.

(defmethod next-char ((lexer basic-lexer))
  (with-slots (stream char pushback-chars) lexer
    (setf char (if pushback-chars
		   (pop pushback-chars)
		   (read-char stream nil)))))

(defmethod pushback-char ((lexer basic-lexer) new-char)
  (with-slots (char pushback-chars) lexer
    (push char pushback-chars)
    (setf char new-char)))

(defmethod fixup-stream* ((lexer basic-lexer) thunk)
  (with-slots (stream char pushback-chars) lexer
    (when pushback-chars
      (error "Lexer has pushed-back characters."))
    (when (slot-boundp lexer 'char)
      (unread-char char stream))
    (unwind-protect
	 (funcall thunk stream)
      (setf char (read-char stream nil)))))

;;; Reading and pushing back tokens.

(defmethod next-token :around ((lexer basic-lexer))
  (unless (slot-boundp lexer 'char)
    (next-char lexer)))

(defmethod next-token ((lexer basic-lexer))
  (with-slots (pushback-tokens token-type token-value location) lexer
    (setf (values token-type token-value)
	  (if pushback-tokens
	      (let ((pushback (pop pushback-tokens)))
		(setf location (pushed-token-location pushback))
		(values (pushed-token-type pushback)
			(pushed-token-value pushback)))
	      (scan-token lexer)))))

(defmethod scan-token :around ((lexer basic-lexer))
  (with-default-error-location (lexer)
    (call-next-method)))

(defmethod pushback-token ((lexer basic-lexer) new-token-type
			   &optional new-token-value new-location)
  (with-slots (pushback-tokens token-type token-value location) lexer
    (push (make-pushed-token token-type token-value location)
	  pushback-tokens)
    (when new-location (setf location new-location))
    (setf token-type new-token-type
	  token-value new-token-value)))

;;; Utilities.

(defmethod skip-spaces ((lexer basic-lexer))
  (do ((ch (lexer-char lexer) (next-char lexer)))
      ((not (whitespace-char-p ch)) ch)))

;;;--------------------------------------------------------------------------
;;; Our main lexer.

(export 'sod-lexer)
(defclass sod-lexer (basic-lexer)
  ()
  (:documentation
   "Lexical analyser for the SOD lanuage.

   See the LEXER class for the gory details about the lexer protocol."))

(defmethod scan-token ((lexer sod-lexer))
  (with-slots (stream char keywords location) lexer
    (prog (ch)

     consider

       ;; Stash the position of this token so that we can report it later.
       (setf ch (skip-spaces lexer)
	     location (file-location stream))

       ;; Now work out what it is that we're dealing with.
       (cond

	 ;; End-of-file brings its own peculiar joy.
	 ((null ch) (return (values :eof t)))

	 ;; Strings.
	 ((or (char= ch #\") (char= ch #\'))
	  (let* ((quote ch)
		 (string
		  (with-output-to-string (out)
		    (loop
		      (flet ((getch ()
			       (setf ch (next-char lexer))
			       (when (null ch)
				 (cerror* "Unexpected end of file in ~
					   ~:[string~;character~] constant"
					  (char= quote #\'))
				 (return))))
			(getch)
			(cond ((char= ch quote) (return))
			      ((char= ch #\\) (getch)))
			(write-char ch out))))))
	    (setf ch (next-char lexer))
	    (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)))))))))

	 ;; Pick out identifiers and keywords.
	 ((or (alpha-char-p ch) (char= ch #\_))

	  ;; Scan a sequence of alphanumerics and underscores.  We could
	  ;; allow more interesting identifiers, but it would damage our C
	  ;; lexical compatibility.
	  (let ((id (with-output-to-string (out)
		      (loop
			(write-char ch out)
			(setf ch (next-char lexer))
			(when (or (null ch)
				  (not (or (alphanumericp ch)
					   (char= ch #\_))))
			  (return))))))

	    ;; Done.
	    (return (values :id id))))

	 ;; Pick out numbers.  Currently only integers, but we support
	 ;; multiple bases.
	 ((digit-char-p ch)

	  ;; Sort out the prefix.  If we're looking at `0b', `0o' or `0x'
	  ;; (maybe uppercase) then we've got a funny radix to deal with.
	  ;; Otherwise, a leading zero signifies octal (daft, I know), else
	  ;; we're left with decimal.
	  (multiple-value-bind (radix skip-char)
	      (if (char/= ch #\0)
		  (values 10 nil)
		  (case (and (setf ch (next-char lexer))
			     (char-downcase ch))
		    (#\b (values 2 t))
		    (#\o (values 8 t))
		    (#\x (values 16 t))
		    (t (values 8 nil))))

	    ;; If we last munched an interesting letter, we need to skip over
	    ;; it.  That's what the SKIP-CHAR flag is for.
	    ;;
	    ;; Danger, Will Robinson!  If we're just about to eat a radix
	    ;; letter, then the next thing must be a digit.  For example,
	    ;; `0xfatenning' parses as a hex number followed by an identifier
	    ;; `0xfa ttening', but `0xturning' is an octal number followed by
	    ;; an identifier `0 xturning'.
	    (when skip-char
	      (let ((peek (next-char lexer)))
		(unless (digit-char-p peek radix)
		  (pushback-char lexer ch)
		  (return-from scan-token (values :integer 0)))
		(setf ch peek)))

	    ;; Scan an integer.  While there are digits, feed them into the
	    ;; accumulator.
	    (do ((accum 0 (+ (* accum radix) digit))
		 (digit (and ch (digit-char-p ch radix))
			(and ch (digit-char-p ch radix))))
		((null digit) (return-from scan-token
				(values :integer accum)))
	      (setf ch (next-char lexer)))))

	 ;; A slash might be the start of a comment.
	 ((char= ch #\/)
	  (setf ch (next-char lexer))
	  (case ch

	    ;; Comment up to the end of the line.
	    (#\/
	     (loop
	       (setf ch (next-char lexer))
	       (when (or (null ch) (char= ch #\newline))
		 (go scan))))

	    ;; Comment up to the next `*/'.
	    (#\*
	     (tagbody
	      top
		(case (setf ch (next-char lexer))
		  (#\* (go star))
		  ((nil) (go done))
		  (t (go top)))
	      star
		(case (setf ch (next-char lexer))
		  (#\* (go star))
		  (#\/ (setf ch (next-char lexer))
		       (go done))
		  ((nil) (go done))
		  (t (go top)))
	      done)
	     (go consider))

	    ;; False alarm.  (The next character is already set up.)
	    (t
	     (return (values #\/ t)))))

	 ;; A dot: might be `...'.  Tread carefully!  We need more lookahead
	 ;; than is good for us.
	 ((char= ch #\.)
	  (setf ch (next-char lexer))
	  (cond ((eql ch #\.)
		 (setf ch (next-char lexer))
		 (cond ((eql ch #\.) (return (values :ellipsis nil)))
		       (t (pushback-char lexer #\.)
			  (return (values #\. t)))))
		(t
		 (return (values #\. t)))))

	 ;; Anything else is a lone delimiter.
	 (t
	  (return (multiple-value-prog1
		      (values ch t)
		    (next-char lexer)))))

     scan
       ;; Scan a new character and try again.
       (setf ch (next-char lexer))
       (go consider))))

;;;----- That's all, folks --------------------------------------------------