(defvar *line-number* 1)
(defvar *block-number* 0)
(defvar *file-name* "")

(defstruct token-stream
  (stream *standard-input* :type stream)
  (source (make-array 64 :adjustable t :fill-pointer 0) :type vector)
  (token-buffer (make-array 8 :adjustable t :fill-pointer 0) :type vector)
  (char-buffer (make-array 8 :element-type 'character :adjustable t :fill-pointer 0) :type vector))

(defmacro with-line-number ((line-number start) &body body)
  `(let ((,line-number *line-number*)) 
     (setf *line-number* ,start)
     (unwind-protect
       (progn ,@body)
       (setf *line-number* ,line-number))))

(defmacro with-file-name ((file-name name) &body body)
  `(let ((,file-name *file-name*))
     (setf *file-name* ,name)
     (unwind-protect
       (progn ,@body)
       (setf *file-name* ,file-name))))

(defconstant +space-chars+ '(#\Space #\Newline #\Tab))
(defconstant +special-chars+ '(#\( #\) #\[ #\] #\{ #\} #\@ #\. #\| :eof))
(defconstant +special-char-keywords+
  '((#\( . :begin-parenthesis)
    (#\) . :end-parenthesis)
    (#\[ . :begin-method)
    (#\] . :end-method)
    (#\{ . :begin-array)
    (#\} . :end-array)
    (#\@ . :at)
    (#\. . :end-statement)
    (#\| . :variables)))

(defun push-source (stream source &optional clean)
  (let ((stack (token-stream-source stream)))
    (when (> (fill-pointer stack) 0)
      (let ((top (aref stack (1- (fill-pointer stack)))))
        (loop for c across (reverse source)
              while (and (> (fill-pointer top) 0)
                         (eq c (aref top (1- (fill-pointer top)))))
          do (vector-pop top))))
    (vector-push-extend 
      (make-array (length source) 
        :element-type 'character 
        :initial-contents source 
        :adjustable t 
        :fill-pointer (length source)) 
      (token-stream-source stream))))

(defun pop-source (stream)
  (let ((stack (token-stream-source stream))
        (source (vector-pop (token-stream-source stream))))
    (when (> (fill-pointer stack) 0)
      (loop for c across source 
            with top = (aref stack (1- (fill-pointer stack)))
        do (vector-push-extend c top)))
    (coerce source 'string)))
     
(defun add-source (stream c)
  (let ((stack (token-stream-source stream)))
    (when (> (fill-pointer stack) 0)
      (let ((source (aref stack (1- (fill-pointer stack)))))
        (vector-push-extend c source)))))

(defun get-char (stream)
  (let ((c
         (if (> (fill-pointer (token-stream-char-buffer stream)) 0)
             (vector-pop (token-stream-char-buffer stream))
             (let ((c (read-char (token-stream-stream stream))))
               (add-source stream c)
               c))))
    (when (eq c #\Newline)
      (incf *line-number*))
    c))

(defun unget-char (c stream)
  (when (eq c #\Newline)
    (decf *line-number*))
  (vector-push-extend c (token-stream-char-buffer stream))
  stream)

(defun spy-char (stream)
  (when (zerop (fill-pointer (token-stream-char-buffer stream)))
    (return-from spy-char (peek-char nil (token-stream-stream stream) nil :eof)))
  (aref (token-stream-char-buffer stream)
    (1- (fill-pointer (token-stream-char-buffer stream)))))

(defun read-number (stream)
  (let ((value 0)
        radix
        negative)
    (when (member (spy-char stream) '(#\+ #\-))
      (let ((c (get-char stream)))
        (unless (digit-char-p (spy-char stream))
          (return-from read-number (read-symbol stream (list c))))
        (setf negative (eq c #\-))))
    (loop
      while (digit-char-p (spy-char stream))
        do
          (setf value
            (+ (* value 10) (digit-char-p (get-char stream)))))
    (when (member (spy-char stream) '(#\r #\R))
      (get-char stream)
      (setf radix value)
      (setf value 0)
      (loop
        while (digit-char-p (spy-char stream) radix)
          do
            (setf value
              (+ (* value radix) (digit-char-p (get-char stream) radix))))
      (return-from read-number (if negative (- value) value)))
    (when (eq (spy-char stream) #\.)
      (get-char stream)
      (unless (digit-char-p (spy-char stream))
        (unget-char #\. stream)
        (return-from read-number (if negative (- value) value)))
      (setf value (coerce value 'float))
      (loop for place = 0.1 then (* place 0.1)
        while (digit-char-p (spy-char stream))
          do
            (incf value
              (* place (digit-char-p (get-char stream))))))
    (when (member (spy-char stream) '(#\e #\E))
      (let ((exponent 0)
            negative)
        (get-char stream)
        (when (member (spy-char stream) '(#\+ #\-))
          (setf negative (eq (get-char stream) #\-)))
        (setf value (coerce value 'float))
        (loop
          while (digit-char-p (spy-char stream))
            do
              (setf exponent
                (+ (* exponent 10) (digit-char-p (get-char stream)))))
        (setf value 
          (* value 
            (expt 10 
              (if negative (- exponent) exponent))))))
    (if negative (- value) value)))

(defun read-string (stream)
  (let ((buffer 
         (make-array 128 
           :element-type 'character 
           :adjustable t 
           :fill-pointer 0)))
    (get-char stream)
    (loop for c = (get-char stream)
      until (eq c #\')
        do
          (when (eq c #\\)
            (setf c (get-char stream))
            (setf c
              (case c
                (#\n #\Newline)
                (#\t #\Tab)
                (#\r #\Return)
                (#\b #\Backspace)
                (#\s #\Space)
		#-ecl
                (#\e #\Escape)
                (#\a (code-char 7))
                (#\v (code-char 11))
                (#\f (code-char 12))
                (#\0 #\Null)
                (t c))))
          (vector-push-extend c buffer))
    (make-array (fill-pointer buffer) :element-type 'character :initial-contents buffer)))
 
(defun read-comment (stream)
  (let ((buffer
         (make-array 128
           :element-type 'character
           :adjustable t
           :fill-pointer 0)))
    (get-char stream)
    (loop for c = (get-char stream)
      until (eq c #\")
        do
          (vector-push-extend c buffer))
    (make-array (fill-pointer buffer) :element-type 'character :initial-contents buffer)))
 
(defun read-symbol (stream &optional initial-contents)
  (let ((buffer
         (make-array 128
           :element-type 'character
           :adjustable t
           :fill-pointer 0)))
    (dolist (c initial-contents)
      (vector-push-extend c buffer))
    (loop for c = (spy-char stream)
      until (or (member c +space-chars+)
                (member c +special-chars+))
        do
          (vector-push-extend (get-char stream) buffer))
    (intern buffer)))

(defun read-token (stream)
  (loop for c = (spy-char stream)
    while (member c +space-chars+)
      do (get-char stream)
    finally
      (return
        (cond
          ((eq c :eof)
            :eof)
          ((or (member c '(#\+ #\-)) (digit-char-p c)) 
            (read-number stream))
          ((eq c #\')
            (read-string stream))
          ((eq c #\")
            (read-comment stream)
            (read-token stream))
          ((eq c #\$)
            (get-char stream)
            (let ((c (get-char stream)))
              (if (eq c #\\)
                  (case (get-char stream)
                    (#\n #\Newline)
                    (#\t #\Tab)
                    (#\r #\Return)
                    (#\b #\Backspace)
                    (#\s #\Space)
		    #-ecl
                    (#\e #\Escape)
                    (#\a (code-char 7))
                    (#\v (code-char 11))
                    (#\f (code-char 12))
                    (#\0 #\Null)
                    (t c))
                  c))) 
          ((eq c #\#)
            (get-char stream)
            `(quote ,(read-symbol stream)))
          ((member c +special-chars+)
            (cdr (assoc (get-char stream) +special-char-keywords+)))
          (t (read-symbol stream))))))

(defun get-token (stream)
  (if (> (fill-pointer (token-stream-token-buffer stream)) 0)
      (vector-pop (token-stream-token-buffer stream))
      (read-token stream)))

(defun unget-token (stream token)
  (vector-push-extend token (token-stream-token-buffer stream))
  token)

(defun peek-token (stream)
  (when (zerop (fill-pointer (token-stream-token-buffer stream)))
    (unget-token stream (get-token stream)))
  (aref (token-stream-token-buffer stream) 
    (1- (fill-pointer (token-stream-token-buffer stream)))))
      
(setf *block-nesting* 0)
(setf *variables* '())
(setf *methods* '())
(setf *arguments* '())

(defun parse-block (stream &optional selector arguments)
  (let ((variables '())
        (block-number *block-number*)
        (lambda-args '())
        (ignored-args '()))
    (setf *block-number* *line-number*)
    (when (eq (peek-token stream) :variables)
      (get-token stream)
      (loop for token = (get-token stream)
        until (eq token :variables)
          do
            (when (or (keywordp token)
                      (not (symbolp token)))
              (error "Bad variable declaration on line ~A: ~A" *line-number* token))
            (if (eq (char (symbol-name token) 0) #\:)
                (progn
                  (setf token
                    (intern (subseq (symbol-name token) 1)))
                  (setf arguments (nconc arguments (list token))))
                (setf variables (nconc variables (list token))))))
    (incf *block-nesting*)
    (push 
      (append variables arguments (first *variables*))
      *variables*)
    (when selector
      (push selector *methods*)
      (push arguments *arguments*))
    (setf lambda-args
      (loop for argument in arguments
        if (eq argument '_)
          collect
            (let ((lambda-arg (%gensym)))
              (push lambda-arg ignored-args)
              lambda-arg)
        else
          collect argument))
    (let ((code
            `(lambda (currentBlock ,@lambda-args) 
              (declare 
                (ignore 
                  ,@ignored-args
                  ,@(unless selector
                      '(currentBlock))))
              (block ,selector
                (let (,@(loop for variable in variables
                          collect `(,variable *primitive-nil*))
                      ,@(when selector
                          (list '(currentMethod currentBlock))))
                  (declare
                    (ignore
                      ,@(when selector
                          '(currentMethod))))
                  ,@(loop
                      when (eq (peek-token stream) :eof)
                        do (error "Block starting at ~A in ~A terminated by EOF" *block-number* *file-name*)
                      collect (parse-statement stream :end-method) into statements
                      if (eq (peek-token stream) :end-statement)
                        do (get-token stream)
                      else
                      if (eq (peek-token stream) :end-method)
                        do (get-token stream)
                           (return statements)))))))
      (when selector
        (pop *arguments*)
        (pop *methods*))
      (pop *variables*)
      (decf *block-nesting*)
      (prog1
        `(activate-method ,code ,*file-name* ,*block-number* ,selector ,arguments ,(pop-source stream))
        (setf *block-number* block-number)))))

(defun keyword-selector-p (token)
  (and (selector-p token)
       (let ((name (symbol-name token)))
         (eq (char name (1- (length name))) #\:))))

(defun binary-selector-p (token)
  (and (selector-p token)
       (not (eq token '_))
       (let ((name (symbol-name token)))
         (not (alpha-char-p (char name 0))))))

(defun unary-selector-p (token)
  (and (selector-p token)
       (not (keyword-selector-p token))
       (not (binary-selector-p token))))

(defun selector-p (token)
  (and (symbolp token) (not (keywordp token))))

(defun parse-statement (stream &optional delimiter)
  (let ((expression (parse-expression stream))
        (token (peek-token stream)))
    (cond
      ((null expression)
        (unless (and (eq token :eof)
                     (not (eq delimiter :eof)))
          '*primitive-nil*))
      ((or (eq token delimiter)
           (eq token :end-statement) 
           (eq token :eof))
        expression)
      (t
        (error "Expected ~A from line ~A but found ~A at line ~A" delimiter *block-number* token *line-number*)))))

(defun parse-definition (stream)
  (let ((arguments '())
        (roles '())
        (selectors '()))
    (loop for argument = (get-token stream)
      until (eq argument :begin-method)
        do
          (unless (unary-selector-p argument)
            (error "Bad argument name in method definition on line ~A: ~A" *line-number* argument))
          (push argument arguments)
          (push
            (if (eq (peek-token stream) :at)
                (progn
                  (get-token stream)
                  (parse-atom stream))
                '*no-role*)
            roles)
          (let ((selector (get-token stream)))
            (when (eq selector :begin-method)
              (return))
            (unless (selector-p selector)
              (error "Bad selector name in method definition on line ~A: ~A" *line-number* selector))
            (push selector selectors)))
    (let ((selector (intern (apply #'concatenate 'string (mapcar #'symbol-name (nreverse selectors))))))
      `(add-roles
         ',selector
         ,(parse-block stream selector (nreverse arguments))
         ,@(nreverse roles)))))

(defun parse-atom (stream)
  (let ((token (peek-token stream)))
    (cond
      ((eq token :eof) nil)
      ((unary-selector-p token)
        (cond
           ((member token (first *variables*))
             (get-token stream))
           ((eq token '|True|)
             (get-token stream)
             '*primitive-true*)
           ((eq token '|False|)
             (get-token stream)
             '*primitive-false*)
           ((eq token '|Nil|)
             (get-token stream)
             '*primitive-nil*)
           ((eq token '|resend|)
             (get-token stream)
             `(invoke-method ',(first *methods*) currentMethod ,@(first *arguments*)))
           (t
             `(mic-invoke-unary-method ',(get-token stream) *lobby*))))
      ((eq token :begin-parenthesis)
        (get-token stream)
        `(progn
          ,@(loop until (eq (peek-token stream) :eof)
              collect (parse-statement stream :end-parenthesis) into statements
              if (eq (peek-token stream) :end-statement)
                do (get-token stream)
              else
              if (eq (peek-token stream) :end-parenthesis)
                do (get-token stream)
                   (return statements))))
      ((eq token :begin-array)
        (get-token stream)
        `(vector
          ,@(loop until (eq (peek-token stream) :eof)
              if (eq (peek-token stream) :end-array)
                do (get-token stream)
                   (return statements)
              collect (parse-statement stream :end-array) into statements
              if (eq (peek-token stream) :end-statement)
                do (get-token stream))))
      ((eq token :begin-method)
        (get-token stream)
        (push-source stream "[" t)
        (parse-block stream))
      ((selector-p token)
        '*lobby*)
      ((keywordp token)
        nil)
      (t
        (get-token stream)))))
        
(defun parse-unary-invocation (stream &optional code)
  (let ((code (or code (parse-atom stream))))
    (loop for token = (peek-token stream)
      while (unary-selector-p token)
        do
          (get-token stream)
          (setf code
            `(pic-invoke-unary-method ',token ,code)))
    code))

(defun parse-binary-invocation (stream &optional code)
  (let ((code (parse-unary-invocation stream code)))
    (loop for token = (peek-token stream)
      while (binary-selector-p token)
        do
          (get-token stream)
          (setf code
            (cond
              ((and (eq token '^)
                    (eq code '*lobby*))
                `(return-from ,(first *methods*) ,(parse-unary-invocation stream)))
              ((member token '(+ - * ==))
                `(let ((x ,code)
                       (y ,(parse-unary-invocation stream)))
                   (if (and (numberp x) (numberp y))
                       (,(if (eq token '==) 'eq token) x y)
                       (invoke-method ',token nil x y))))
              (t
                `(pic-invoke-binary-method ',token ,code ,(parse-unary-invocation stream))))))
    code))
    
(defun parse-keyword-invocation (stream &optional code)
  (let ((arguments (list (parse-binary-invocation stream code)))
        (selectors '())
        (selector nil))
    (loop for selector = (peek-token stream)
      until (member selector '(:end-array :end-parenthesis :end-method :end-statement :eof))
        do
          (get-token stream)
          (unless (keyword-selector-p selector)
            (error "Bad selector name in keyword method invocation on line ~A: ~A" *line-number* selector))
          (push selector selectors)
          (push (parse-binary-invocation stream code) arguments))
    (setf selectors (nreverse selectors))
    (setf arguments (nreverse arguments))
    (when selectors
      (setf selector (intern (apply #'concatenate 'string (mapcar #'symbol-name selectors)))))
    (cond
      ((null selectors)
        (first arguments))
      ((and (eq (first arguments) '*lobby*)
            (= (length selectors) 1))
        (let* ((name (symbol-name (first selectors)))
               (variable (intern (subseq name 0 (1- (length name))))))
          (if (member variable (first *variables*))
              `(setf ,variable ,(second arguments))
              `(invoke-method ',(first selectors) nil *lobby* ,(second arguments)))))
      ((member selector '(|whileTrue:| |whileFalse:|))
        `(loop ,(if (eq selector '|whileTrue:|) 'while 'until) 
           (eq ,(if (and (consp (first arguments))
                         (eq (first (first arguments)) 'activate-method))
                    `(progn ,@(cdddr (second (first arguments))))
                    `(invoke-method '|value| nil ,(first arguments)))
               *primitive-true*)
           do
             ,@(loop for argument in (rest arguments)
                 if (and (consp argument) 
                         (eq (first argument) 'activate-method))
                   collect `(progn ,@(cdddr (second argument)))
                 else
                   collect `(invoke-method '|value| nil ,argument))))
      ((member selector '(|ifTrue:| |ifFalse:| |ifTrue:ifFalse:| |ifNil:| |ifNotNil:| |ifNil:ifNotNil:|))
        (let ((condition 
                (if (member selector '(|ifTrue:| |ifFalse:| |ifTrue:ifFalse:|)) 
                    '*primitive-true*
                    '*primitive-nil*))
              (negated
                (member selector '(|ifFalse:| |ifNotNil:|))))
          `(,(if negated 'unless 'if)
               (eq ,(first arguments) ,condition)
               ,@(loop for argument in (rest arguments)
                   if (and (consp argument)
                           (eq (first argument) 'activate-method))
                     collect `(progn ,@(cdddr (second argument)))
                   else
                     collect `(invoke-method '|value| nil ,argument)))))
      ((= (length arguments) 2)
        `(pic-invoke-binary-method ',selector ,@arguments))
      ((= (length arguments) 3)
        `(pic-invoke-trinary-method ',selector ,@arguments))
      (t
        `(invoke-method ',selector nil ,@arguments)))))

(defun parse-expression (stream)
  (let ((tokens '()))
    (push-source stream "")
    (loop for token = (get-token stream)
      if (eq token :eof)
        do
          (pop-source stream)
          (when (and (null tokens) (eq (token-stream-stream stream) *standard-input*))
            (invoke-method '|quit| nil *lobby*))
          (dolist (token tokens)
            (unget-token stream token))
          (return (parse-keyword-invocation stream))
      else
      if (or (eq token :at)
             (and tokens
                  (unary-selector-p (first tokens))
                  (eq token :begin-method)))
        do
          (unget-token stream token)
          (dolist (token tokens)
            (unget-token stream token))
          (return (parse-keyword-invocation stream (parse-definition stream)))
      else
      if (or (keywordp token)
             (not (selector-p token)))
             ;(and (or (keyword-selector-p token)
             ;         (binary-selector-p token))
             ;     (null tokens))
             ;(and (or (keyword-selector-p (first tokens))
             ;         (binary-selector-p (first tokens)))
             ;     (not (unary-selector-p token)))
             ;(and (and tokens (unary-selector-p (first tokens)))
             ;     (or (and (rest tokens) (unary-selector-p (second tokens)))
             ;         (not (selector-p token)))))
        do
          (pop-source stream)
          (unget-token stream token)
          (dolist (token tokens)
            (unget-token stream token))
          (return (parse-keyword-invocation stream))
      else
        do (push token tokens))))