(defvar *syntax*)
(defvar *current-scope*)

(defun %parse-block (stream &optional selector arguments roles opt-vars)
  (let (block rest-var
        (variables '())
        (block-number *block-number*))
    (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))
            (cond
              ((eq (char (%symbol-name token) 0) #\:)
                (setf token
                  (%intern (subseq (%symbol-name token) 1)))
                (setf arguments (nconc arguments (list token))))
              ((eq (char (%symbol-name token) 0) #\*)
                (setf token
                  (%intern (subseq (%symbol-name token) 1)))
                (setf rest-var token)
                (setf variables (nconc variables (list token))))
              (t
                (setf variables (nconc variables (list token)))))))
    (incf *block-nesting*)
    (push 
      (append variables arguments (mapcar #'second opt-vars) (first *variables*))
      *variables*)
    (cond 
      (selector
        (push selector *methods*)
        (setf block (%slate (|newEmpty| (|MethodDefinition| '*syntax*))))
        (set-slot block '|selector| selector)
        (set-slot block '|roles| (coerce roles 'simple-vector)))
      (t
        (setf block (%slate (|newEmpty| (|Block| '*syntax*))))))
    (set-slot block '|parentScope| *current-scope*)
    (setf *current-scope* block)
    (dolist (arg arguments)
      (%slate (|addInputVariableNamed:| 'block 'arg)))
    (loop for (opt-key opt-var) in opt-vars
      do (%slate (|addOptionalKeyword:named:| 'block 'opt-key 'opt-var)))
    (dolist (var variables)
      (if (eq var rest-var)
          (%slate (|restVariable:| 'block (|addVariableNamed:| 'block 'var))) 
          (%slate (|addVariableNamed:| 'block 'var))))
    (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)
           (set-slot block '|statements| (coerce statements 'simple-vector))
           (return))
    (when selector
      (pop *methods*))
    (pop *variables*)
    (setf *current-scope* (get-slot block '|parentScope|))
    (decf *block-nesting*)
    (pop-source stream)
    (setf *block-number* block-number)
    block))

(defun %parse-statement (stream &optional delimiter)
  (let ((expression (%parse-optionals stream (%parse-expression stream t)))
        (token (peek-token stream)))
    (cond
      ((null expression)
        (unless (and (eq token :eof)
                     (not (eq delimiter :eof)))
          (%slate (|for:| (|Literal| '*syntax*) '*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 '())
        (opt-vars '())
        (roles '())
        (selectors '()))
    (loop for argument = (get-token stream)
      until (eq argument :begin-method)
        do
          (cond
            ((eq (char (%symbol-name argument) 0) #\&)
               (unget-token stream argument))
          (t
          (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))
                (%slate (|for:| (|Literal| '*syntax*) '*no-role*)))
            roles)))
          (let ((selector (peek-token stream)))
            (when (not (eq selector :begin-method))
              (get-token stream)
              (unless (selector-p selector)
                (error "Bad selector name in method definition on line ~A: ~A" *line-number* selector))
              (if (eq (char (%symbol-name selector) 0) #\&)
                  (loop until (eq selector :begin-method)
                    do (push (list selector (get-token stream)) opt-vars)
                       (setf selector (get-token stream))
                    finally
                      (unget-token stream selector)) 
                  (push selector selectors)))))
    (let ((selector (%intern
                      (apply #'concatenate 'string 
                        (mapcar (lambda (sym) 
                                  (%symbol-name sym))
                         (nreverse selectors))))))
      (%parse-block stream selector (nreverse arguments) (nreverse roles) (nreverse opt-vars)))))

(defun %parse-optionals (stream expr)
  (let ((token (peek-token stream))
        (opts '())
        (args '())
        opt)
    (loop while (optional-selector-p token)
      do (push (get-token stream) opts)
         (push (%parse-binary-invocation stream) args)
         (setf token (peek-token stream)))
    (cond
      (opts
        (setf opt (%slate (|for:| (|OptionalKeywords| '*syntax*) 'expr)))
        (set-slot opt '|keywords| (coerce (nreverse opts) 'simple-vector))
        (set-slot opt '|arguments| (coerce (nreverse args) 'simple-vector))
        opt)
      (t
        expr))))
  
(defun %parse-atom (stream &optional top-level)
  (let ((token (peek-token stream)))
    (cond
      ((eq token :eof) nil)
      ((unary-selector-p token)
        (cond
           ((member token (first *variables*))
             (%slate (|from:| (|LoadVariable| '*syntax*) (|findVariable:| '*current-scope* '(get-token stream)))))
           ((eq token '|resend|)
             (get-token stream)
             (%slate (|Resend| '*syntax*)))
           (t
             (get-token stream)
             (%slate (|sending:to:| (|UnaryMessage| '*syntax*) 'token '(vector (%slate (|ImplicitArgument| '*syntax*))))))))
      ((eq token :begin-parenthesis)
        (get-token stream)
        (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 (%slate (|as:| '(coerce statements 'simple-vector) (|Parenthesis| '*syntax*))))))
      ((eq token :begin-array)
        (get-token stream)
        (loop until (eq (peek-token stream) :eof)
          if (eq (peek-token stream) :end-array)
            do (get-token stream)
               (return (%slate (|as:| '(coerce statements 'simple-vector) (|Array| '*syntax*))))
          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)
        (%slate (|ImplicitArgument| '*syntax*)))
      ((keywordp token)
        nil)
      (t
        (get-token stream)
        (when (and (consp token) (eq (first token) 'quote))
          (setf token (second token)))
        (%slate (|for:| (|Literal| '*syntax*) 'token))))))
        
(defun %parse-unary-invocation (stream &optional code top-level)
  (let ((code (or code (%parse-atom stream top-level))))
    (loop for token = (peek-token stream)
      while (unary-selector-p token)
        do
          (get-token stream)
          (setf code
            (%slate (|sending:to:| (|UnaryMessage| '*syntax*) 'token '(vector code)))))  
    code))

(defun %parse-binary-invocation (stream &optional code top-level)
  (let ((code (%parse-unary-invocation stream code top-level)))
    (loop for token = (peek-token stream)
      while (binary-selector-p token)
        do
          (get-token stream)
          (setf code
            (cond
              ((eq token '^)
                (%slate (|of:| (|ReturnClose| '*syntax*) '(%parse-unary-invocation stream)))) 
              (t
                (%slate (|sending:to:| (|BinaryMessage| '*syntax*) 'token
                          '(vector code
                                   (%parse-unary-invocation stream))))))))
    code))
    
(defun %parse-keyword-invocation (stream &optional code top-level)
  (let ((arguments (list (%parse-binary-invocation stream code top-level)))
        (selectors '())
        (selector nil))
    (loop for selector = (peek-token stream)
      until (or (member selector '(:end-array :end-parenthesis :end-method :end-statement :eof))
                (optional-selector-p selector))
        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 
                         (lambda (sym)
                           (%symbol-name sym))
                           selectors)))))
    (cond
      ((null selectors)
        (first arguments))
      ((and (eq (first arguments) (%slate (|ImplicitArgument| '*syntax*)))
            (= (length selectors) 1)) 
        (let* ((name (%symbol-name (first selectors)))
               (variable (%intern (subseq name 0 (1- (length name))))))
          (cond
            ((member variable (first *variables*))
              (%slate (|of:into:| (|StoreVariable| '*syntax*) '(second arguments) (|findVariable:| '*current-scope* 'variable))))
            (t
              (%slate (|sending:to:| (|KeywordMessage| '*syntax*) 'selector
                  '(coerce arguments 'simple-vector)))))))
      (t
        (%slate (|sending:to:| (|KeywordMessage| '*syntax*) 'selector
                  '(coerce arguments 'simple-vector)))))))

(defun %parse-expression (stream &optional top-level)
  (let ((tokens '()))
    (push-source stream "")
    (loop for token = (get-token stream)
      if (eq token :eof)
        do
          (pop-source stream)
          (dolist (token tokens)
            (unget-token stream token))
          (return (%parse-keyword-invocation stream nil top-level))
      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) top-level))
      else
      if (or (keywordp token)
             (not (selector-p token)))
        do
          (pop-source stream)
          (unget-token stream token)
          (dolist (token tokens)
            (unget-token stream token))
          (return (%parse-keyword-invocation stream nil top-level))
      else
        do (push token tokens))))