(declaim (optimize (speed 3) (safety 1)))

(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+
  '((#\( . :begin-parenthesis)
    (#\) . :end-parenthesis)
    (#\[ . :begin-method)
    (#\] . :end-method)
    (#\{ . :begin-array)
    (#\} . :end-array)
    (#\@ . :at)
    (#\. . :end-statement)
    (#\| . :variables)
    (:eof . :eof)))

(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 make-big-int (value)
  (let ((negative (< value 0)))
    (setf value (abs value))
    (loop with new-value = 0
          for shift from 0 by 16
          until (zerop value)
      do (setf new-value (%slate (|+| (|bitShift:| '(logand value #xFFFF) 'shift) 'new-value)))
         (setf value (ash value -16))
      finally
        (when negative
          (setf new-value (%slate (|negated| 'new-value))))
        (return new-value))))

(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))))
      (when negative
        (setf value (- value)))
      (unless (<= (- (ash 1 30)) value (1- (ash 1 30)))
        (setf value (make-big-int value)))
      (return-from read-number value))
    (when (eq (spy-char stream) #\.)
      (get-char stream)
      (unless (digit-char-p (spy-char stream))
        (unget-char #\. stream)
        (when negative
          (setf value (- value)))
        (unless (<= (- (ash 1 30)) value (1- (ash 1 30)))
          (setf value (make-big-int value)))
        (return-from read-number value))
      (loop for size = 1 then (* size 10)
        while (digit-char-p (spy-char stream))
          do (setf value (+ (* value 10) (digit-char-p (get-char stream))))
        finally
          (setf value (/ (coerce value 'float) (coerce size 'float)))))
    (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))))))
    (when negative 
      (setf value (- value)))
    (cond 
      ((floatp value)
        (%float value))
      ((not (<= (- (ash 1 30)) value (1- (ash 1 30))))
        (make-big-int value))
      (t         
        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)
                (#\e #\^[)
                (#\a (code-char 7))
                (#\v (code-char 11))
                (#\f (code-char 12))
                    (#\x
                      (code-char
                        (parse-integer (coerce (list (get-char stream) (get-char stream)) 'string)
                          :radix 16)))
                (#\0 #+cormanlisp #\Nul #-cormanlisp #\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)
    (cond
      ((or initial-contents (not (eql (spy-char stream) #\')))
        (setf 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+)
                    (assoc c +special-chars+))
            do
              (vector-push-extend (get-char stream) buffer)))
      (t
        (setf buffer (read-string stream))))
    (%intern (coerce buffer 'string))))

(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)
                    (#\e #\^[)
                    (#\a (code-char 7))
                    (#\v (code-char 11))
                    (#\f (code-char 12))
                    (#\x
                      (code-char 
                        (parse-integer (coerce (list (get-char stream) (get-char stream)) 'string)
                          :radix 16)))
		    (#\0 #+cormanlisp #\Nul #-cormanlisp #\Null)
                    (t c))
                  c))) 
          ((eq c #\#)
            (get-char stream)
            `(quote ,(read-symbol stream)))
          ((assoc c +special-chars+)
            (cdr (assoc (get-char stream) +special-chars+)))
          (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* '())
(setf *optionals* '())

(defun %symbol-name (sym)
  (multiple-value-bind (obj exists) (gethash sym *literal-objects*)
    (if exists
        (get-slot obj '|name|)
        (symbol-name sym))))

(defun parse-block (stream &optional selector arguments opts)
  (let ((variables '())
        (block-number *block-number*)
        (lambda-args '())
        (ignored-args '())
        (rest-args nil)
        opts-sym)
    (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 rest-args token))
              ((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) #\&)
                (let ((var (get-token stream)))
                  (unless (symbolp var)
                    (error "Bad keyword argument declaration on line ~A: ~A" *line-number* var))
                  (setf opts (nconc opts (list (list token var))))))
              (t
                (setf variables (nconc variables (list token)))))))
    (when opts
      (setf opts-sym (%gensym)))
    (incf *block-nesting*)
    (push 
      (append variables (mapcar #'second opts) arguments (when rest-args (list rest-args)) (first *variables*))
      *variables*)
    (setf lambda-args
      (loop for argument in arguments
            and index from 0
        if (eq argument '_)
          collect
            (let ((lambda-arg (%gensym)))
              (push lambda-arg ignored-args)
              lambda-arg)
        else
          collect argument))
    (when rest-args
      (setf arguments (append arguments (list rest-args)))
      (setf rest-args
            (if (eq rest-args '_)
                (let ((lambda-arg (%gensym)))
                  (push lambda-arg ignored-args)
                  lambda-arg)
                rest-args)))
    (when selector
      (push selector *methods*)
      (push (append lambda-args (when rest-args (list rest-args))) *arguments*)
      (push opts-sym *optionals*))
    (let ((code
           `(lambda (currentBlock ,@lambda-args ,@(when opts `(&optional ,opts-sym)) ,@(when rest-args `(&rest ,rest-args))) 
              (declare 
                (ignore 
                  ,@ignored-args
                  ,@(unless selector
                      '(currentBlock))))
              ,@(unless (or (not rest-args) (member rest-args ignored-args))
                  `((setf ,rest-args (coerce ,rest-args 'simple-vector))))
              (block ,selector
                (let (,@(loop for variable in (append (mapcar #'second opts) variables)
                          collect `(,variable *primitive-nil*))
                      ,@(when selector
                          (list '(currentMethod currentBlock))))
                  (declare
                    (ignore
                      ,@(when selector
                          '(currentMethod))))
                  ,@(when opts
                      (let ((opt-sym (%gensym))
                            (val-sym (%gensym)))
                        `((loop for (,opt-sym ,val-sym) on ,opts-sym by #'cddr
                            do (case ,opt-sym
                                ,@(loop for (selector arg) in opts
                                    collect `(,selector (setf ,arg ,val-sym))))))))
                  ,@(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
        `(#-jit activate-method
          #+jit ,(if (zerop *block-nesting*)
                     'jit-activate-method
                     '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)))
         (and (not (eq (char name 0) #\&))
              (eq (char name (1- (length name))) #\:)))))

(defun optional-selector-p (token)
  (and (selector-p token)
       (eq (char (%symbol-name token) 0) #\&)))

(defun binary-selector-p (token)
  (and (selector-p token)
       (not (eq token '_))
       (let* ((name (%symbol-name token))
              (first (char name 0)))
         (not (or (alpha-char-p first)
                  (eq first #\&))))))

(defun unary-selector-p (token)
  (and (selector-p token)
       (not (optional-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 t))
        (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 '())
        (opts '()))
    (loop for argument = (get-token stream)
      until (or (eq argument :begin-method)
                (optional-selector-p argument))
        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 (peek-token stream)))
            (when (not (or (eq selector :begin-method)
                           (optional-selector-p selector)))
              (get-token stream)
              (unless (selector-p selector)
                (error "Bad selector name in method definition on line ~A: ~A" *line-number* selector))
              (push selector selectors)))
      finally
        (when (optional-selector-p argument)
          (unget-token stream argument)
          (loop for selector = (get-token stream)
            until (eq selector :begin-method)
              do 
                (unless (optional-selector-p selector)
                  (error "Bad selector name in optional keyword parameter on line ~A: ~A" *line-number* selector))
                (let ((argument (get-token stream)))
                  (unless (unary-selector-p argument)
                    (error "Bad argument name in optional keyword parameter on line ~A: ~A" *line-number* argument))
                  (push (list selector argument) opts)))))
    (let ((selector (%intern
                      (apply #'concatenate 'string 
                        (mapcar (lambda (sym) 
                                  (%symbol-name sym))
                         (nreverse selectors))))))
      `(add-roles
         ',selector
         ,(parse-block stream selector (nreverse arguments) (nreverse opts))
         ,@(nreverse roles)))))

(defun parse-optionals (stream)
  (let ((opts '()))
    (loop for selector = (peek-token stream)
      until (member selector '(:end-array :end-parenthesis :end-method :end-statement :eof))
        do
          (get-token stream)
          (unless (optional-selector-p selector)
            (error "Bad selector name in optional keyword argument on line ~A: ~A" *line-number* selector))
          (push (list selector (%gensym) (parse-binary-invocation stream)) opts))
    `((let (,@(loop for (selector sym val) in (nreverse opts)
                collect `(,sym ,val)))
        (list ,@(loop for (selector sym val) in (sort opts #'string-lessp :key #'(lambda (opt) (%symbol-name (first opt))))
                  collect `(quote ,selector)
                  collect sym))))))
 
(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*))
             (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)
             (if (first *optionals*)
                 `(invoke-method-with-optionals ',(first *methods*) currentMethod ,(first *optionals*) ,@(first *arguments*))
                 `(invoke-method ',(first *methods*) currentMethod ,@(first *arguments*))))
           ((member token *slots*)
             (get-token stream)
             `(sic-get-slot ',token *lobby* (x (sc-invoke-method ',token x))))
           (t
             (get-token stream)
             (if (and top-level (optional-selector-p (peek-token stream)))
                 `(invoke-method ',token nil *lobby* (parse-optionals stream))
                 `(sc-invoke-method ',token *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 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
            (cond
              ((eq token '|not|)
                `(let ((x ,code))
                   (cond
                     ((eq x *primitive-true*) 
                       *primitive-false*)
                     ((eq x *primitive-false*)
                       *primitive-true*)
                     (t
                       (invoke-method ',token nil x)))))
              ((eq token '|size|)
                `(let ((x ,code))
                   (typecase x
                     (vector
                       (length x))
                     (t
                       (sc-invoke-method ',token x)))))
              ((member token '(|isEmpty| |do|))
                `(sc-invoke-method ',token ,code))
              ((member token *slots*)
                `(sic-get-slot ',token ,code (x (sc-invoke-method ',token x))))
              (t
                (if (and top-level (optional-selector-p (peek-token stream)))
                    `(invoke-method-with-optionals ',selector nil
                       ,@(parse-optionals stream)
                       ,code) 
                    `(sc-invoke-method ',token ,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
              ((and (eq token '^)
                    (eq code '*lobby*))
	       (if *methods*
		   `(return-from ,(first *methods*) ,(parse-unary-invocation stream))
		 `(return ,(parse-unary-invocation stream))))
              ((member token '(+ - *))
                `(let ((x ,code)
                       (y ,(parse-unary-invocation stream)))
                   (if (and (numberp x) (numberp y))
                       (integer-op (invoke-method ',token nil x y) (,token x y))
                       (invoke-method ',token nil x y))))
              ((eq token '=)
                `(let ((x ,code)
                       (y ,(parse-unary-invocation stream)))
                   (cond
                     ((or (and (characterp x) (characterp y))
                          (and (symbolp x) (symbolp y)))
                       (if (eq x y) *primitive-true* *primitive-false*))
                     ((and (numberp x) (numberp y))
                       (if (= x y) *primitive-true* *primitive-false*))
                     (t
                       (sc-invoke-method ',token x y)))))
              ((member token '(<= < > >= ~=))
                `(let ((x ,code)
                       (y ,(parse-unary-invocation stream)))
                   (if (and (numberp x) (numberp y))
                       (if (,(if (eq token '~=) '/= token) x y) *primitive-true* *primitive-false*)
                       (sc-invoke-method ',token x y))))
              ((eq token '==)
                `(if (eq ,code ,(parse-unary-invocation stream))
                     *primitive-true* *primitive-false*))
              (t
                (if (and top-level (optional-selector-p (peek-token stream)))
                    `(invoke-method-with-optionals ',selector nil
                       ,@(parse-optionals stream)
                       ,code
                       ,(parse-unary-invocation stream))
                    `(sc-invoke-method ',token ,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) '*lobby*)
            (= (length selectors) 1))
        (let* ((name (%symbol-name (first selectors)))
               (variable (%intern (subseq name 0 (1- (length name))))))
          (cond
            ((member variable (first *variables*))
              `(setf ,variable ,(second arguments)))
            ((and top-level (optional-selector-p (peek-token stream)))
              `(invoke-method-with-optionals `,(first selectors) nil ,@(parse-optionals stream) *lobby*))
            (t
              `(sc-invoke-method ',(first selectors) *lobby* ,(second arguments))))))
      ((eq selector '|at:|)
        `(let ((x ,(first arguments))
               (y ,(second arguments)))
           (typecase x
             (simple-vector
               (svref x y))
             (string
               (char x y))
             (t
               (sc-invoke-method ',selector x y)))))
      ((eq selector '|at:put:|)
        `(let ((x ,(first arguments))
               (y ,(second arguments))
               (z ,(third arguments)))
           (typecase x
             (simple-vector
               (setf (svref x y) z) )
             (string
               (setf (char x y) z))
             (t
               (sc-invoke-method ',selector x y z)))))
      ((eq selector '|atSlotNamed:|)
        (let ((sel-sym (gensym))
              (obj-sym (gensym)))
          `(let ((,sel-sym ,(second arguments)))
             (sic-get-slot ,sel-sym ,(first arguments) (,obj-sym (sc-invoke-method ',selector ,obj-sym ,sel-sym))))))
      ((eq selector '|atSlotNamed:put:|)
        (let ((sel-sym (gensym))
              (obj-sym (gensym))
              (val-sym (gensym)))
          `(let ((,sel-sym ,(second arguments))
                 (,val-sym ,(third arguments)))
             (sic-set-slot ,sel-sym ,(first arguments) ,val-sym (,obj-sym (sc-invoke-method ',selector ,obj-sym ,sel-sym ,val-sym))))))
      ((and (member selector '(|caseOf:| |caseOf:otherwise:|))
            (consp (second arguments))
            (eq (first (second arguments)) 'vector)
            (not (consp (third (second (second arguments)))))
            (not (symbolp (third (second (second arguments))))))
        `(case ,(first arguments)
           ,@(loop for (invoke assoc key value) in (rest (second arguments))
               collect `(,key ,@(cdddr (second value))))
           ,@(when (third arguments)
               `((t ,@(cdddr (second (third arguments))))))))
      ((and (member selector '(|upTo:do:| |downTo:do:| |below:do:| |above:do:|))
            (consp (third arguments))
            (eq (first (third arguments)) 'activate-method))
        `(loop for ,(second (second (second (third arguments))))
               from ,(first arguments)
               ,(case selector
                  (|upTo:do:| 'to)
                  (|downTo:do:| 'downto)
                  (|below:do:| 'below)
                  (|above:do:| 'above)) ,(second arguments)
           do (progn ,@(cdddr (second (third 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))))
                    `(sc-invoke-method '|do| ,(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 `(sc-invoke-method '|do| ,argument))
           finally
             (return *primitive-nil*)))
      ((member selector '(|or:| |and:| |ifTrue:| |ifFalse:| |ifTrue:ifFalse:| |ifNil:| |ifNotNil:| |ifNil:ifNotNil:|))
        (let ((test-sym (%gensym))
              (condition 
                (if (member selector '(|or:| |and:| |ifTrue:| |ifFalse:| |ifTrue:ifFalse:|)) 
                    '*primitive-true*
                    '*primitive-nil*))
              (negated
                (member selector '(|or:| |ifFalse:| |ifNotNil:|))))
          `(let ((,test-sym ,(first arguments)))
             (if
                 ,(if negated
                      `(not (eq ,test-sym ,condition))
                      `(eq ,test-sym ,condition))
                 ,@(loop for argument in (rest arguments)
                     if (and (consp argument)
                             (eq (first argument) 'activate-method))
                       collect `(progn ,@(cdddr (second argument)))
                     else
                       collect `(sc-invoke-method '|do| ,argument))
                 ,@(case selector
                     (|and:| `(*primitive-false*))
                     (|or:| `(*primitive-true*)))
                 ,@(when (member selector '(|ifNil:| |ifNotNil:|))
                     `(,test-sym))
                 ,@(when (member selector '(|ifTrue:| |ifFalse:|))
                     `(*primitive-nil*))))))
      (t
        (if (and top-level (optional-selector-p (peek-token stream)))
            `(invoke-method-with-optionals ',selector nil
               ,@(parse-optionals stream)
               ,@arguments)
            `(sc-invoke-method ',selector ,@arguments))))))

(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)
          (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 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)))
             ;(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 nil top-level))
      else
        do (push token tokens))))