;; This code is a kluge intended only for bootstrapping.
;; It will be replaced by much nicer code fairly
;; soon. You probably shouldn't be looking at this unless 
;; you are morbidly curious. Avert your eyes! Run away!

(defstruct wm-slot
  (name nil :type symbol)
  (index -1 :type fixnum)
  (delegates nil :type boolean)
  (accessors nil :type boolean)
  (roles '() :type list))
    
(defstruct wm-map
  (slot-names '() :type list)
  (slots (make-hash-table) :type hash-table))

(defstruct (wm-object
             (:print-function
               (lambda (object stream level)
                 (format stream "<WM: ~A, ~A>" (wm-object-name object) (wm-map-slot-names (wm-object-map object))))))
  (name "" :type string)
  (map (make-wm-map) :type wm-map)
  (slots #() :type simple-vector))

(defstruct wm-role
  (positions 0 :type fixnum)
  (arguments 0 :type fixnum)
  (method nil :type wm-object))

(defun clone-map (map)
  (let ((new-map (make-wm-map)))
    (setf (wm-map-slot-names new-map)
      (copy-seq (wm-map-slot-names map)))
    (maphash 
      (lambda (slot-name slot)
        (setf (gethash slot-name (wm-map-slots new-map)) slot))
      (wm-map-slots map))
    new-map))

(defmacro with-object ((name &rest slots) &body body)
  `(let ((,name (make-wm-object))) 
     (prog ()
       (setf (wm-object-name ,name) ,(string name))
       ,@(loop for (slot-name slot-delegates slot-value slot-accessors) in slots
           collect 
             `(add-slot 
                ,name
                ',(if (stringp slot-name)
                      (intern slot-name)
                      (intern (string-downcase (string slot-name)))) 
                ,slot-delegates 
                ,slot-value
                ,slot-accessors)))
     ,@body))

(defmacro define-object (name &rest slots)
  ;(format t "DEFINING: ~A~%" name)
  `(defvar ,name
     (with-object (,name ,@slots)
       ,name)))

(defun clone-object (object)
  (make-wm-object 
    :name (wm-object-name object)
    :map (wm-object-map object)
    :slots (copy-seq (wm-object-slots object))))

(defun make-method (selector arguments variables code &optional accessor)
  (let ((method (clone-object *primitive-method*))
        (arguments (loop for argument in arguments
                     collect (if (eq argument '_) (gensym) argument))))
    (set-slot method '|selector| selector)
    (set-slot method '|accessor| accessor)
    (set-slot method '|arguments| arguments)
    (set-slot method '|code| code)
    (set-slot method '|activation|
      (let ((activation (clone-object *primitive-activation*)))
        (dolist (argument arguments)
          (add-slot activation argument nil *primitive-nil* (not (null (symbol-package argument)))))
        (dolist (variable variables)
          (add-slot activation variable nil *primitive-nil* t))
        activation))
    method))

;(trace make-method)

(defun add-accessors (object name)
  (let ((object-symbol (gensym))
        (value-symbol (gensym))
        (mutator (intern (concatenate 'string (string name) ":"))))
    (add-roles
      name
      (make-method name (list object-symbol) '()
        (list
          (list
            (lambda ()
              (get-slot (get-slot (first *activation-stack*) object-symbol) name))
            0 t))
        t)
      object)
    (add-roles
      mutator
      (make-method mutator
        (list object-symbol value-symbol) '()
        (list
          (list
            (lambda ()
              (set-slot (get-slot (first *activation-stack*) object-symbol) name
                (get-slot (first *activation-stack*) value-symbol)))
            0 t))
        t)
      object)
   object))


(defun add-slot (object name delegates value &optional accessors)
  (unless (wm-object-p object)
    (setf object
      (or (gethash object *literal-objects*)
          (let ((representation (make-wm-object)))
            (add-slot representation '|traits| t 
              (typecase object
                (integer *traits-integer*)
                (float *traits-float*)
                (character *traits-character*)
                (symbol *traits-symbol*)
                (string *traits-string*)
                (array *traits-array*)
                (t (error "Unhandled object type: ~A" argument)))
              t)
            (setf (gethash object *literal-objects*) representation)))))
  (let* ((map (clone-map (wm-object-map object)))
         (slot (or (gethash name (wm-map-slots map))
                   (progn
                     (setf (wm-map-slot-names map) 
                       (nconc (wm-map-slot-names map)
                         (list name)))
                     (setf (gethash name (wm-map-slots map))
                       (make-wm-slot :name name))))))
    (setf (wm-object-map object) map)
    (setf (wm-slot-delegates slot) 
          (or (wm-slot-delegates slot)
              delegates))
    (unless (or (wm-slot-accessors slot)
                (not accessors))
      (add-accessors object name))
    (setf (wm-slot-accessors slot) 
          (or (wm-slot-accessors slot)
              accessors))
    (if (= (wm-slot-index slot) -1)
        (let ((index 0))
          (maphash
            (lambda (slot-name slot)
              (setf index (max index (1+ (wm-slot-index slot)))))
            (wm-map-slots map))
          (setf (wm-slot-index slot) index)
          (setf (wm-object-slots object)
            (concatenate 'simple-vector
              (wm-object-slots object)
              (list value))))
        (set-slot object name value))
    object))

;(trace add-slot)

(defun add-role (object name position arguments method)
  (unless (wm-object-p object)
    (setf object
      (or (gethash object *literal-objects*)
          (let ((representation (make-wm-object)))
            (add-slot representation '|traits| t 
              (typecase object
                (integer *traits-integer*)
                (float *traits-float*)
                (character *traits-character*)
                (symbol *traits-symbol*)
                (string *traits-string*)
                (array *traits-array*)
                (t (error "Unhandled object type: ~A" argument)))
              t)
            (setf (gethash object *literal-objects*) representation)))))
  (let* ((map (clone-map (wm-object-map object)))
         (slot (or (gethash name (wm-map-slots map))
                   (setf (gethash name (wm-map-slots map))
                     (make-wm-slot :name name)))))
    (setf (wm-object-map object) map)
    (dolist (role (wm-slot-roles slot))
      (when (eq (wm-role-method role) method)
        (setf (wm-role-positions role)
          (logior (wm-role-positions role) position))
        (return-from add-role object)))
    (push
      (make-wm-role :positions position :arguments arguments :method method)
      (wm-slot-roles slot))
    object))
      
(defun get-slot (object slot-name)
  (multiple-value-bind
    (slot exists)
    (gethash slot-name (wm-map-slots (wm-object-map object)))
    (when exists
      (setf exists (>= (wm-slot-index slot) 0)))
    (values
      (when exists
        (svref (wm-object-slots object) (wm-slot-index slot)))
      exists)))

(defun set-slot (object slot-name slot-value)
  ;(format t "(set-slot ~A ~A ~A)~%" object slot-name slot-value)
  (setf (svref (wm-object-slots object)
          (wm-slot-index (gethash slot-name (wm-map-slots (wm-object-map object)))))
    slot-value))

(defsetf get-slot set-slot)

(defun dispatch-method (name ignore ignore-count arguments)
  ;(format t "DISPATCHING: ~A~%" name)
  (let ((methods (make-hash-table))
        (visited (make-hash-table))
        (objects (copy-seq arguments))
        (delegations (make-array (length arguments) :initial-element '()))) 
    (do ()
        ((null (find-if (lambda (object) (not (null object))) objects)))
      (loop for object in objects
            and position on objects
        when object
          do
            (unless (wm-object-p object)
              (setf (first position)
                (or (gethash object *literal-objects*)
                    (typecase object
                      (integer *traits-integer*)
                      (float *traits-float*)
                      (character *traits-character*)
                      (symbol *traits-symbol*)
                      (string *traits-string*)
                      (array *traits-array*)
                      (t (error "Unhandled object type: ~A" argument)))))))
      (loop for object in objects
           and index from 0 
        when object
          do
            ;(format t "DISPATCH: ~A @ ~A~%" object index)
            (multiple-value-bind 
              (slot exists)
              (gethash name (wm-map-slots (wm-object-map object)))
              (when exists
         ;       (format t "ROLES: ~A~%" (wm-slot-roles slot))
                (dolist (role (wm-slot-roles slot))
          ;        (format t "ROLE: ~A/~A/~A~%" (wm-role-positions role) (wm-role-arguments role) ignore)
                  (when (logbitp index (wm-role-positions role))
                    (multiple-value-bind
                      (positions exists)
                      (gethash (wm-role-method role) methods)
                      (when (= (setf (gethash (wm-role-method role) methods)
                                 (logior (or positions 0) (ash 1 index)))
                               (wm-role-arguments role))
                        (if ignore
                            (when (eq ignore (wm-role-method role))
                              (decf ignore-count)
                              (when (zerop ignore-count)
                                (setf ignore nil)))
                            (progn
                              (when (get-slot (wm-role-method role) '|accessor|)
                                (setf (first arguments) (first objects)))
                              (return-from dispatch-method (wm-role-method role)))))))))))
      (loop for object in objects
            and position on objects
            and index from 0
            and delegates = nil
        when object
          do
          ;  (format t "DELEGATING...: ~A~%" object)
            (loop for slot-name in (reverse (wm-map-slot-names (wm-object-map object)))
                  for slot = (gethash slot-name (wm-map-slots (wm-object-map object)))
                  for contents = (svref (wm-object-slots object) (wm-slot-index slot))
              when (and (wm-slot-delegates slot)
                        (not (eq contents *primitive-nil*))
                        (not (logbitp index (or (gethash contents visited) 0))))
                do
                  ;(format t "DELEGATE: ~A@~A -> ~A~%" slot-name index (svref (wm-object-slots object) (wm-slot-index slot)))
                  (setf (gethash contents visited) 
                        (logior (or (gethash contents visited) 0)
                                (ash 1 index)))
                  (if delegates
                      (push contents (svref delegations index))
                      (setf delegates contents)))
            (unless delegates
              (setf delegates (pop (svref delegations index))))
            (setf (first position) delegates)))
    (if ignore
        *primitive-nil*
        (error "Failed to dispatch method ~A" name))))

(defvar *activation-stack* '())

(defun current-activation ()
  (first *activation-stack*))

(defun pop-stack (object))

(defun link-method (method)
  (if *activation-stack*
      (let ((closure (clone-object method)))
        (set-slot closure '|lexicalParent| (first *activation-stack*))
        closure)
      method))

(defun push-array (&rest objects)
  (make-array (length objects) :initial-contents objects))

(defun invoke-method (selector ignore ignore-count &rest objects)
  (tagbody tail-call
    (let* ((continuation *activation-stack*)
           (method (if (selector-p selector)
                       (dispatch-method selector ignore ignore-count objects)
                       selector))
           (activation 
             (clone-object (get-slot method '|activation|)))
           (stack '()))
      (loop for argument in (get-slot method '|arguments|)
            and object in objects
        do
          (set-slot activation argument object))
      (set-slot activation '|currentMethod| method)
      (set-slot activation '|resendDepth| ignore-count)
      (set-slot activation '|lexicalParent|
        (or (get-slot method '|lexicalParent|) *lobby*))
      (set-slot activation '|continuation|
        (lambda (result)
          (setf *activation-stack* continuation)
          (return-from invoke-method result)))
      (push activation *activation-stack*)
      (loop for code in (get-slot method '|code|)
            and position on (get-slot method '|code|)
        do
          (cond
            ((atom code) 
              (push code stack))
            ((and (eq (first code) #'invoke-method)
                  (null (rest position)))
              (pop *activation-stack*)
              (setf selector (fourth code))
              (setf ignore (fifth code))
              (setf ignore-count (sixth code))
              (setf objects (nreverse stack))
              (go tail-call))
            (t
              (let ((result 
                     (apply (first code)
                       (append
                         (cdddr code)
                         (when (and stack
                                    (> (second code) 0))
                           (nreverse
                             (shiftf stack
                               (rest (nthcdr (1- (second code)) stack))
                               '())))))))
                (when (third code)
                  (push (or result *primitive-nil*) stack))))))
      (pop *activation-stack*)
      (return-from invoke-method (if stack (first stack) *primitive-nil*)))))

(defun interpret (code)
  (let ((method (make-method (gensym) '() '() code)))
    (or (invoke-method method nil 0) *primitive-nil*)))

(defun add-roles (name method &rest objects)
  (let ((arguments
         (loop for object in objects
               and index from 0
           when object
             sum (ash 1 index))))
    (loop for object in objects
          and index from 0
      when object
        do
          (add-role object name (ash 1 index) arguments method))
    method))

;(trace add-roles)

(defmacro define-method (name arguments &body body)
  (let ((selector
         (if (stringp name)
             (intern name)
             (intern (string-downcase (string name))))))
    `(add-roles ',selector
       (make-method ',selector
         ',(loop for argument in arguments
             if (consp argument)
               collect (first argument)
             else
               collect argument)
         '()
         (list
           (list
             (lambda ()
               (let ,(loop for argument in arguments
                       collect
                         (if (consp argument)
                             `(,(first argument) 
                                (get-slot (first *activation-stack*) ',(first argument)))
                             `(,argument
                                (get-slot (first *activation-stack*) ',argument))))
                    (block ,(when (symbolp name) name) ,@body)))
             0 t)))
         ,@(loop for argument in arguments
             collect (when (consp argument) (second argument))))))

(defvar *line-number* 1)
(defvar *block-number* 0)

(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))))

(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 get-char (stream)
  (let ((c
         (if (> (fill-pointer (token-stream-char-buffer stream)) 0)
             (vector-pop (token-stream-char-buffer stream))
             (read-char (token-stream-stream stream)))))
    (when (eq c #\Newline)
      (incf *line-number*))
    c))

(defun unget-char (c stream)
  (when (eq c #\Newline)
    (decf *line-number*))
  (vector-push 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)
                (t c))))
          (vector-push 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 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 c buffer))
    (loop for c = (spy-char stream)
      until (or (member c +space-chars+)
                (member c +special-chars+))
        do
          (vector-push (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)
                    (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))))))

(defvar *literal-objects* (make-hash-table))

(define-object *primitive-nil*
  (traits t nil))
(define-object *traits-method*
  (name nil "Method")
  (traits t nil)
  (cloneable t *primitive-nil*))
(define-object *primitive-method*
  (traits t *traits-method*)
  (selector nil nil)
  (accessor nil nil)
  (arguments nil '())
  ("lexicalParent" nil nil)
  (code nil '())
  (activation nil nil))
(define-object *traits-activation*
  (name nil "Activation")
  (traits t nil)
  (cloneable t *primitive-nil*))
(define-object *primitive-activation*
  (traits t *traits-activation*)
  ("currentMethod" nil nil)
  ("resendDepth" nil 0)
  ("lexicalParent" t nil)
  (continuation nil nil))
(add-accessors *traits-method* '|cloneable|)
(add-accessors *traits-method* '|traits|)
(add-accessors *traits-method* '|name|)
(add-accessors *traits-activation* '|cloneable|)
(add-accessors *traits-activation* '|traits|)
(add-accessors *traits-activation* '|name|)
(add-accessors *primitive-method* '|traits|)
(add-accessors *primitive-activation* '|traits|)
(add-accessors *primitive-nil* '|traits|)

(define-object *traits-root*
  (name nil "Root" t)
  (traits t nil t))
(define-object *primitive-root*
  (traits t *traits-root* t))

(define-object *traits-oddball*
  (name nil "Oddball" t)
  (traits t nil t)
  (root t *traits-root* t))
(define-object *primitive-oddball*
  (traits t *traits-oddball* t))
(set-slot *primitive-nil* '|traits| *traits-oddball*)

(define-object *traits-derivable*
  (name nil "Derivable" t)
  (traits t nil t)
  (root t *traits-root* t))
(define-object *primitive-derivable*
  (traits t *traits-derivable* t))

(define-object *traits-cloneable*
  (name nil "Cloneable" t)
  (traits t nil t)
  (derivable t *traits-derivable* t))
(define-object *primitive-cloneable*
  (traits t *traits-cloneable* t))
(set-slot *traits-method* '|cloneable| *traits-cloneable*)
(set-slot *traits-activation* '|cloneable| *traits-cloneable*)

(define-object *traits-traits*
  (name nil "Traits" t))
(define-object *primitive-traits*
  (name nil "_" t)
  (traits t *traits-traits* t))
(set-slot *traits-method* '|traits| *traits-traits*)
(set-slot *traits-activation* '|traits| *traits-traits*)
(set-slot *traits-root* '|traits| *traits-traits*)
(set-slot *traits-oddball* '|traits| *traits-traits*)
(set-slot *traits-derivable* '|traits| *traits-traits*)
(set-slot *traits-cloneable* '|traits| *traits-traits*)

(define-object *traits-boolean*
  (name nil "Boolean" t)
  (traits t *traits-traits* t)
  (oddball t *traits-oddball* t))
(define-object *primitive-true*
  (traits t *traits-boolean* t))
(define-object *primitive-false*
  (traits t *traits-boolean* t))

(define-object *traits-number*
  (name nil "Number" t)
  (traits t *traits-traits* t)
  (derivable t *traits-derivable* t))
(define-object *primitive-number*
  (traits t *traits-number* t))

(define-object *traits-integer*
  (name nil "Integer" t)
  (traits t *traits-traits* t)
  (number t *traits-number* t))
(define-method traits ((integer *traits-integer*))
  *traits-integer*)

(define-object *traits-float*
  (name nil "Float" t)
  (traits t *traits-traits* t)
  (number t *traits-number* t))
(define-method traits ((float *traits-float*))
  *traits-float*)

(define-object *traits-character*
  (name nil "Character" t)
  (traits t *traits-traits* t)
  (oddball t *traits-oddball* t))
(define-method traits ((character *traits-character*))
  *traits-character*)

(define-object *traits-symbol*
  (name nil "Symbol" t)
  (traits t *traits-traits* t)
  (oddball t *traits-oddball* t))
(define-method traits ((symbol *traits-symbol*))
  *traits-symbol*)

(define-object *traits-collection*
  (name nil "Collection" t)
  (traits t *traits-traits* t)
  (cloneable t *traits-cloneable* t))
(define-object *primitive-collection*
  (traits t *traits-collection* t))

(define-object *traits-array*
  (name nil "Array" t)
  (traits t *traits-traits* t)
  (collection t *traits-collection* t))
(define-method traits ((array *traits-array*))
  *traits-array*)
 
(define-object *traits-string*
  (name nil "String" t)
  (traits t *traits-traits* t)
  (collection t *traits-collection*))
(define-method traits ((string *traits-string*))
  *traits-string*)

(define-object *traits-namespace*
  (name nil "Namespace" t)
  (traits t *traits-traits* t)
  (oddball t *traits-oddball*))
(define-object *primitive-namespace*
  (traits t *traits-namespace* t))

(define-object *prototypes*
  (traits t *traits-namespace* t)
  ("Traits" nil *primitive-traits* t)
  ("Root" nil *primitive-root* t)
  ("Cloneable" nil *primitive-cloneable* t)
  ("Oddball" nil *primitive-oddball* t)
  ("Derivable" nil *primitive-derivable* t)
  ("Namespace" nil *primitive-namespace* t)
  ("Nil" nil *primitive-nil* t)
  ("Boolean" nil *primitive-true* t)
  ("True" nil *primitive-true* t)
  ("False" nil *primitive-false* t)
  ("Number" nil *primitive-number* t)
  ("Integer" nil 0 t)
  ("Float" nil 0.0 t)
  ("Character" nil #\Space t)
  ("Symbol" nil '|symbol| t)
  ("Collection" nil *primitive-collection* t)
  ("Array" nil #() t)
  ("String" nil "" t)
  ("Activation" nil *primitive-activation* t)
  ("Method" nil *primitive-method* t))

(define-object *lobby*
  (traits t *traits-namespace* t)
  (prototypes t *prototypes* t))

(define-method clone ((oddball *primitive-oddball*))
  (with-object (new-oddball (traits t *traits-oddball* t))
    new-oddball))

(define-method derive ((derivable *traits-derivable*))
  (let ((object (clone-object derivable))
        (traits (clone-object *primitive-traits*)))
    (add-slot traits '|parent| t (get-slot object '|traits|) t)
    (set-slot object '|traits| traits)
    object))

(define-method "deriveFrom:" ((derivable *traits-derivable*) (array *traits-array*))
  (let ((object (clone-object derivable))
        (traits (clone-object *primitive-traits*)))
    (add-slot traits '|parent1| t (get-slot object '|traits|) t)
    (set-slot object '|traits| traits)
    (loop for parent in (coerce array 'list)
          and index from 2
      do
        (add-slot traits (intern (format nil "parent~A" index)) t parent t)) 
    object))
    
(define-method "==" ((x *traits-root*) (y *traits-root*))
  (if (eq x y) *primitive-true* *primitive-false*))

(define-method "asMethod:on:" ((method *traits-method*) (selector *traits-symbol*) (array *traits-array*))
  (let ((method (clone-object method)))
    (set-slot method '|selector| selector)
    (apply #'add-roles selector method (coerce array 'list))))

(define-method "addSlotsFrom:" ((x *traits-root*) (y *traits-root*))
  (loop for slot-name in (wm-map-slot-names (wm-object-map y))
        for slot = (gethash slot-name (wm-map-slots (wm-object-map y)))
        for contents = (svref (wm-object-slots y) (wm-slot-index slot))
    do
      (add-slot x slot-name
        (wm-slot-delegates slot)
        contents
        (wm-slot-accessors slot)))
  x) 

(define-method "addSlot:" ((object *traits-root*) (name *traits-symbol*))
  (add-slot object name nil *primitive-nil* t)
  object)

(define-method "addDelegate:" ((object *traits-root*) (name *traits-symbol*))
  (add-slot object name t *primitive-nil* t)
  object)

(define-method clone ((object *traits-cloneable*))
  (clone-object object))

(define-method clone ((array *traits-array*))
  (copy-seq array))

(define-method clone ((string *traits-string*))
  (copy-seq string))

(define-method "newSize:" ((array *traits-array*) (size *traits-integer*))
  (make-array size :initial-element *primitive-nil*))

(define-method "newSize:" ((string *traits-string*) (size *traits-integer*))
  (make-array size :element-type 'character :initial-element #\Space))

(define-method "at:" ((array *traits-array*) (index *traits-integer*))
  (aref array index))
 
(define-method "at:put:" ((array *traits-array*) (index *traits-integer*) value)
  (setf (aref array index) value))

(define-method size ((array *traits-array*))
  (length array))
 
(define-method "at:" ((string *traits-string*) (index *traits-integer*))
  (char string index))

(define-method "at:put:" ((string *traits-string*) (index *traits-integer*) value)
  (setf (char string index) value))

(define-method size ((string *traits-string*))
  (length string))

(define-method "," ((x *traits-array*) (y *traits-array*))
  (concatenate 'array x y))
  
(define-method "," ((x *traits-string*) (y *traits-string*))
  (concatenate 'string x y))

(define-method print ((object *traits-traits*))
  (unless (and (wm-object-p object)
               (or (eq object *traits-traits*)
                   (eq (get-slot object '|traits|) *traits-traits*)))
    (return-from print (invoke-method '|print| 
                         (get-slot (first *activation-stack*) '|currentMethod|) 
                         (1+ (get-slot (first *activation-stack*) '|resendDepth|))
                         object)))
  (format t "@~A" (or (get-slot object '|name|) "_"))
  object)

(define-method print ((object *traits-symbol*))
  (when (wm-object-p object)
    (return-from print
      (invoke-method '|print| 
        (get-slot (first *activation-stack*) '|currentMethod|) 
        (1+ (get-slot (first *activation-stack*) '|resendDepth|)) 
        object)))
  (format t "#~A" object)
  object)

(define-method print ((object *traits-character*))
  (when (wm-object-p object)
    (return-from print
      (invoke-method '|print| 
        (get-slot (first *activation-stack*) '|currentMethod|)
        (1+ (get-slot (first *activation-stack*) '|resendDepth|))                       
        object)))
  (format t "$~A" 
    (case object
      (#\Newline "\\n")
      (#\Tab "\\t")
      (#\Return "\\r")
      (#\Backspace "\\b")
      (t object)))
  object)

(define-method print ((object *traits-root*))
  (format t "<")
  (when (get-slot object '|traits|)
    (format t "@~A:" (or (get-slot (get-slot object '|traits|) '|name|) "_")))
  (dolist (slot-name (wm-map-slot-names (wm-object-map object)))
    (format t " ~A" slot-name))
  (format t ">")
  object)
    
(define-method print ((object *primitive-nil*))
  (format t "Nil")
  object)

(define-method print ((object *primitive-true*))
  (format t "True")
  object)
 
(define-method print ((object *primitive-false*))
  (format t "False")
  object)

(define-method print ((object *traits-number*))
  (when (wm-object-p object)
    (return-from print
      (invoke-method '|print| 
        (get-slot (first *activation-stack*) '|currentMethod|)
        (1+ (get-slot (first *activation-stack*) '|resendDepth|))                       
        object)))
  (if (wm-object-p object)
      (format t "<@Number>")
      (format t "~A" object))
  object)

(define-method print ((array *traits-array*))
  (when (wm-object-p array)
    (return-from print
      (invoke-method '|print| 
        (get-slot (first *activation-stack*) '|currentMethod|)
        (1+ (get-slot (first *activation-stack*) '|resendDepth|))                       
        array)))
  (format t "{")
  (dotimes (index (1- (length array)))
    (invoke-method '|print| nil 0 (aref array index))
    (format t ". "))
  (when (> (length array) 0)
    (invoke-method '|print| nil 0 (aref array (1- (length array)))))
  (format t "}")
  array)

(define-method print ((string *traits-string*))
  (when (wm-object-p string)
    (return-from print
      (invoke-method '|print| 
        (get-slot (first *activation-stack*) '|currentMethod|)
        (1+ (get-slot (first *activation-stack*) '|resendDepth|))                       
        string)))
  (format t "'~A'" string)
  string)

(define-method print ((method *traits-method*))
  (when (eq method *traits-method*)
    (return-from print
      (invoke-method '|print| 
        (get-slot (first *activation-stack*) '|currentMethod|)
        (1+ (get-slot (first *activation-stack*) '|resendDepth|))                       
        method)))
  (format t "[~A]" (or (get-slot method '|selector|) ""))
  method)

(define-method "^" ((activation *traits-activation*) value)
  (loop for parent = (get-slot activation '|lexicalParent|)
    until (or (get-slot (get-slot activation '|currentMethod|) '|selector|)
              (eq parent *lobby*))
      do
        (setf activation parent))
  (funcall (get-slot activation '|continuation|) value))

(define-method "currentMethod" ((activation *traits-activation*))
  (get-slot (second *activation-stack*) '|currentMethod|))

(define-method value ((method *traits-method*))
  (invoke-method method nil 0))
  
(define-method "value:" ((method *traits-method*) x)
  (invoke-method method nil 0 x))

(define-method "value:value:" ((method *traits-method*) x y)
  (invoke-method method nil 0 x y))

(define-method "value:value:value:" ((method *traits-method*) x y z)
  (invoke-method method nil 0 x y z))

(define-method "values:" ((method *traits-method*) arguments)
  (apply #'invoke-method method nil 0 (coerce arguments 'list)))

(define-method "fileIn" ((string *traits-string*))
  (with-open-file (file string)
    (with-line-number (line-number 0)
      (let ((token-stream (make-token-stream :stream file))
            (result *primitive-nil*))
        (loop for code = (parse-statement token-stream :eof) 
          while code
            do
              (setf result (interpret code)))
        result))))

(define-method "apply:" ((selector *traits-symbol*) (arguments *traits-array*))
  (apply #'invoke-method selector nil 0 (coerce arguments 'list)))
 
(define-method "applyWith:" ((selector *traits-symbol*) x)
  (invoke-method selector nil 0 x))

(define-method "applyWith:with:" ((selector *traits-symbol*) x y)
  (invoke-method selector nil 0 x y))

(define-method "applyWith:with:with:" ((selector *traits-symbol*) x y z)
  (invoke-method selector nil 0 x y z))

(define-method "identityHash" ((object *traits-root*))
  (sxhash object))

(define-method resend ((activation *traits-activation*))
  (loop
    until (or (get-slot (get-slot activation '|currentMethod|) '|selector|)
              (eq activation *lobby*))
      do
        (setf activation (get-slot activation '|lexicalParent|)))
  ;(format t "SUPER: ~A~%" activation)
  (unless (eq activation *lobby*)
    (let ((ignore (get-slot activation '|currentMethod|)))
      (apply #'invoke-method 
        (get-slot ignore '|selector|) 
        ignore 
        (1+ (get-slot activation '|resendDepth|))
          (loop for argument in (get-slot ignore '|arguments|)
   ;          do (format t "ARGUMENT: ~A -> ~A~%" argument (get-slot activation argument))
             collect (get-slot activation argument))))))

(define-method "as:" ((i *traits-integer*) (f *traits-float*))
  (coerce i 'float))

(define-method "as:" ((f *traits-float*) (i *traits-integer*))
  (values (floor f)))

(define-method "+" ((x *traits-integer*) (y *traits-integer*))
  (+ x y))

(define-method "-" ((x *traits-integer*) (y *traits-integer*))
  (- x y))

(define-method "quo:" ((x *traits-integer*) (y *traits-integer*))
  (values (floor x y)))

(define-method "*" ((x *traits-integer*) (y *traits-integer*))
  (* x y))

(define-method "+" ((x *traits-float*) (y *traits-float*))
  (+ x y))

(define-method "-" ((x *traits-float*) (y *traits-float*))
  (- x y))

(define-method "/" ((x *traits-float*) (y *traits-float*))
  (/ x y))

(define-method "*" ((x *traits-float*) (y *traits-float*))
  (* x y))

(define-method "=" ((x *traits-integer*) (y *traits-integer*))
  (if (= x y) *primitive-true* *primitive-false*))

(define-method ">" ((x *traits-integer*) (y *traits-integer*))
  (if (> x y) *primitive-true* *primitive-false*))

(define-method "<" ((x *traits-integer*) (y *traits-integer*))
  (if (< x y) *primitive-true* *primitive-false*))

(define-method ">=" ((x *traits-integer*) (y *traits-integer*))
  (if (>= x y) *primitive-true* *primitive-false*))

(define-method "<=" ((x *traits-integer*) (y *traits-integer*))
  (if (<= x y) *primitive-true* *primitive-false*))

(define-method "=" ((x *traits-float*) (y *traits-float*))
  (if (= x y) *primitive-true* *primitive-false*))

(define-method ">" ((x *traits-float*) (y *traits-float*))
  (if (> x y) *primitive-true* *primitive-false*))

(define-method "<" ((x *traits-float*) (y *traits-float*))
  (if (< x y) *primitive-true* *primitive-false*))

(define-method ">=" ((x *traits-float*) (y *traits-float*))
  (if (>= x y) *primitive-true* *primitive-false*))

(define-method "<=" ((x *traits-float*) (y *traits-float*))
  (if (<= x y) *primitive-true* *primitive-false*))
 
(defstruct token-stream
  (stream *standard-input* :type stream)
  (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))

(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 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)))))
      
(defvar *block-nesting* 0)

(defun parse-block (stream &optional selector arguments)
  (let ((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))
            (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))))))
    (make-method selector arguments variables
      (prog2
        (incf *block-nesting*)
        (loop for token = (get-token stream)
          until (eq token :end-method) 
          when (eq token :eof)
            do (error "Block starting at ~A terminated by EOF" *block-number*)
          do (unget-token stream token)
          nconc (parse-statement stream :end-method))
        (setf *block-number* block-number)
        (decf *block-nesting*)))))

(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 accumulate)
  (let ((expression (parse-expression stream))
        (token (peek-token stream)))
    (cond
      ((null expression) nil)
      ((eq token delimiter)
        expression)
      ((eq token :end-statement)
        (get-token stream)
        (if accumulate
            expression
            (nconc expression (list (list #'pop-stack 1 nil)))))
      (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 '())
        (code '())
        (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))
          (setf arguments (nconc arguments (list argument)))
          (setf code
            (nconc
              code
              (if (eq (peek-token stream) :at)
                  (progn 
                    (get-token stream)
                    (parse-atom stream))
                  (list nil))))
          (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))
            (setf selectors (nconc selectors (list selector)))))
    (if (zerop *block-nesting*)
        (nconc code
          (list 
            (list #'add-roles (length arguments) t
              (intern 
                (apply #'concatenate 'string
                  (mapcar #'symbol-name selectors)))
              (parse-block stream (intern (apply #'concatenate 'string (mapcar #'symbol-name selectors))) arguments))))
        (nconc 
          (list 
            (list #'link-method 0 t (parse-block stream arguments)))
          code
          (list
            (list #'add-roles (1+ (length arguments)) t
              (intern
                (apply #'concatenate 'string
                  (mapcar #'symbol-name selectors)))))))))

(defun parse-atom (stream &optional)
  (let ((token (peek-token stream)))
    (cond
      ((eq token :eof) nil)
      ((unary-selector-p token)
        (list 
          (list #'current-activation 0 t)
          (list #'invoke-method 1 t (get-token stream) nil 0)))
      ((eq token :begin-parenthesis)
        (get-token stream)
        (loop for token = (get-token stream)
          until (or (eq token :end-parenthesis) (eq token :eof))
            do (unget-token stream token)
            nconc (parse-statement stream :end-parenthesis)))
      ((eq token :begin-array)
        (get-token stream)
        (let ((size 0))
          (nconc
            (loop for token = (get-token stream)
              until (eq token :end-array)
                do (unget-token stream token)
                   (incf size)
                nconc (parse-statement stream :end-array t))
            (list (list #'push-array size t)))))
      ((eq token :begin-method)
        (get-token stream)
        (list (list #'link-method 0 t (parse-block stream))))
      ((selector-p token)
        (list (list #'current-activation 0 t)))
      ((and (consp token)
            (eq (first token) 'quote))
        (list (second (get-token stream))))
      (t
        (list (get-token stream))))))
        
(defun parse-unary-invocation (stream)
  (let ((code (parse-atom stream)))
    (loop for token = (peek-token stream)
      while (unary-selector-p token)
        do
          (setf code
            (nconc code
              (list 
                (list #'invoke-method 1 t (get-token stream) nil 0)))))
    code))

(defun parse-binary-invocation (stream)
  (let ((code (parse-unary-invocation stream)))
    (loop for token = (peek-token stream)
      while (binary-selector-p token)
        do
          (get-token stream)
          (setf code
            (nconc code
              (parse-unary-invocation stream)
              (list
                (list #'invoke-method 2 t token nil 0)))))
    code))
     
(defun parse-keyword-invocation (stream &optional code)
  (let ((code (or code (parse-binary-invocation stream)))
        (selectors '()))
    (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))
          (setf selectors (nconc selectors (list selector)))
          (setf code (nconc code (parse-binary-invocation stream))))
    (if (null selectors)
        code
        (nconc code
          (list
            (list #'invoke-method (1+ (length selectors)) t
              (intern 
                (apply #'concatenate 'string
                  (mapcar #'symbol-name selectors)))
              nil 0))))))
          
(defun parse-expression (stream)
  (let ((tokens '()))
    (loop for token = (get-token stream)
      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
          (unget-token stream token)
          (dolist (token tokens)
            (unget-token stream token))
          (return (parse-keyword-invocation stream))
      do (push token tokens))))
    
(defun repl ()
  (let ((counter 0)
        (token-stream (make-token-stream)))
    (loop for result = (prog2 (format t "~&Who, me? ~A> " (incf counter))
                              (interpret (parse-statement token-stream :end-statement t))
                              (get-token token-stream))
      do
        (invoke-method '|print| nil 0 result)
        (format t "~%"))))

;(trace parse-atom)
;(trace parse-statement)
;(trace parse-expression)
;(trace parse-definition)
;(trace parse-block)
;(trace parse-binary-invocation)
;(trace parse-keyword-invocation)
;(trace parse-unary-invocation)
;(trace invoke-method)
;(trace dispatch-method)