(defvar *slate-debug* t
  "Defines whether errors should involve the interpreter or use Slate-level `handlers'.")

(defvar *slate-compile* nil
  "Defines whether fileIn invokes the compiler or the interpreter on the contents.")

(defvar *gensym-counter* 0)

(defun %gensym ()
  (intern (format nil "~~~A" (incf *gensym-counter*))))

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

(defmacro traits-for-prim (object)
  (let ((sym (%gensym)))
    `(let ((,sym ,object))
       (typecase ,sym
     (integer *traits-integer*)
     (float *traits-float*)
     (character *traits-character*)
     (symbol *traits-symbol*)
     (string *traits-string*)
     ((array (unsigned-byte 8)) *traits-byte-array*)
     (array *traits-array*)
     (stream *traits-filestream*)
     (function *traits-lisp*)
     #+clisp (socket::socket-stream *traits-socket*)
     #+clx
     ,@((xlib:display *traits-display*)
	(xlib:screen *traits-screen*)
	(xlib:drawable *traits-drawable*)
	(xlib:window *traits-window*)
	(xlib:pixmap *traits-pixmap*)
	(xlib:cursor *traits-cursor*)
	(xlib:color *traits-color*))
     (t (error "Unhandled object type: ~A" ,sym))))))

(defstruct wm-slot
  (name nil :type symbol)
  (index -1 :type fixnum)
  (delegates nil :type boolean)
  (accessors nil :type (or boolean (eql :immutable)))
  (roles '() :type list))

(defstruct wm-map
  (slot-names '() :type list)
  (slots (make-hash-table) :type hash-table))

(defstruct (wm-object
#-ecl
             (:print-function
               (lambda (object stream level)
                 (format stream "~&<@~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))

#-ecl
(defmethod make-load-form ((s wm-object) &optional env)
  (unless (eq (get-slot s '|traits|) *traits-method*)
    (error "make-load-form only supports Method objects."))
  `(make-slate-method
     ,(get-slot s '|fileName|)
     ,(get-slot s '|lineNumber|)
     ,(if (eq (get-slot s '|selector|) *primitive-nil*) '*primitive-nil* `(quote ,(get-slot s '|selector|)))
     ',(get-slot s '|arguments|)
     ,(get-slot s '|sourceCode|)
     *primitive-nil*))

(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)
  `(progn
    ;(format t "DEFINING: ~A~%" name)
    (defvar ,name)
    (setf ,name
     (with-object (,name ,@slots)
       ,name))))

(defmacro clone-object (object)
  (let ((object-symbol (%gensym)))
    `(let ((,object-symbol ,object))
       (make-wm-object
         :name (wm-object-name ,object-symbol)
         :map (wm-object-map ,object-symbol)
         :slots (copy-seq (wm-object-slots ,object-symbol))))))

(defmacro activate-method (code file line selector arguments source)
  (let* ((act-symbol (%gensym))

#-ecl
         (method (make-slate-method file line (or selector *primitive-nil*) arguments source *primitive-nil*))
#+ecl
         (method `(%load-form ,(%gensym) (make-slate-method ,file ,line ,(if selector `(quote ,selector) '*primitive-nil*) ',arguments ,source *primitive-nil*)))
         (index (wm-slot-index (gethash '|code| (wm-map-slots (wm-object-map *primitive-method*))))))
    `(let ((,act-symbol (clone-object ,method)))
       (setf (svref (wm-object-slots ,act-symbol) ,index) ,code)
       ,act-symbol)))

(defun make-slate-method (file line selector arguments source code &optional accessor)
  (let ((method (clone-object *primitive-method*)))
    (set-slot method '|fileName| file)
    (set-slot method '|lineNumber| line)
    (set-slot method '|selector| (or selector *primitive-nil*))
    (set-slot method '|accessor| accessor)
    (set-slot method '|arguments| arguments)
    (set-slot method '|sourceCode| source)
    (set-slot method '|code| code)
    method))

(defun add-accessors (object name &optional immutable)
  (let ((mutator (intern (concatenate 'string (string name) ":"))))
    (add-roles
      name
      (make-slate-method "" 0 name '(object) *primitive-nil*
       (lambda (currentBlock object)
         (declare (ignore currentBlock))
         (get-slot object name))
        t)
      object)
    (unless immutable
      (add-roles
        mutator
        (make-slate-method "" 0 mutator
          '(object value)
          *primitive-nil*
          (lambda (currentBlock object value)
            (declare (ignore currentBlock))
            (set-slot object name value))
          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 
              (traits-for-prim object) 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)
                (eq (wm-slot-accessors slot) accessors))
      (add-accessors object name (eq accessors :immutable)))
    (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))

(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 
              (traits-for-prim object) 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)
  (unless (wm-object-p object)
    (setf object (gethash object *literal-objects*))
    (unless object (return-from get-slot (values nil nil))))
  (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)
  (unless (wm-object-p object)
    (setf object (gethash object *literal-objects*)))
  (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)

(define-condition method-not-found ()
  ((method-name :initarg :method-name :initform "" :reader method-name)
   (args :initarg :args :initform '() :reader method-args))
  (:report (lambda (condition stream)
	     (format stream "Error: A method named '~A' was not found for the arguments: ~A" (method-name condition) (method-args condition))))
  #-ecl
  (:documentation "Notify the user that a method wasn't found, and report the method name and arguments, then resume the REPL."))

(defun dispatch-method (name ignore error arguments)
  ;(format t "DISPATCHING: ~A~%" name)
  (loop for argument in arguments
        and index from 0
        and delegations = '()
        with methods = (make-hash-table)
        and visited = (make-hash-table)
        and order = (make-hash-table)
        and dispatch = nil
        and accessor = nil
    do
      ;(format t "ARGUMENT: ~A @ ~A~%" argument index)
      (loop for depth from 0
            while argument
        do
          (unless (wm-object-p argument)
            (setf argument
              (or (gethash argument *literal-objects*)
                  (traits-for-prim argument))))
          (multiple-value-bind (slot exists) (gethash name (wm-map-slots (wm-object-map argument)))
            (when exists
              (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))
                  (let ((method (wm-role-method role)))
                    (setf (gethash method order)
                          (logior (logandc2 (or (gethash method order) #xFFFFFFFF) (ash #xF (* 4 (- 7 index))))
                                  (ash depth (* 4 (- 7 index)))))
                    (multiple-value-bind (positions exists) (gethash method methods)
                      (when (= (setf (gethash method methods)
                                     (logior (or positions 0) (ash 1 index)))
                               (wm-role-arguments role))
                        ;(format t "ORDER: ~A~%" (gethash method order))
                        (when (and (or (null ignore)
                                       (> (gethash method order) (or (gethash ignore order) -1)))
                                   (or (null dispatch)
                                       (< (gethash method order) (gethash dispatch order))))
                          (if (get-slot method '|accessor|)
                              (when (zerop index) (setf accessor argument))
                              (setf accessor nil))
                          (setf dispatch method)))))))))
          (loop for slot-name in (reverse (wm-map-slot-names (wm-object-map argument)))
                for slot = (gethash slot-name (wm-map-slots (wm-object-map argument)))
                for contents = (svref (wm-object-slots argument) (wm-slot-index slot))
                with delegates = nil
            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 argument) (wm-slot-index slot)))
                (setf (gethash contents visited) 
                      (logior (or (gethash contents visited) 0)
                              (ash 1 index)))
                (if delegates
                    (push contents delegations)
                    (setf delegates contents))
              finally
                (unless delegates 
                  (setf delegates (pop delegations)))
                (setf argument delegates)))
    finally
      (when dispatch
        (when accessor 
          (setf (first arguments) accessor))
        ;(format t "FIN: ~A~%" (gethash dispatch order))
        (return-from dispatch-method dispatch)))
  (if error
      (if *slate-debug*
	  (handler-bind ((method-not-found
                    	#'(lambda (c)
	                        (when (y-or-n-p "~&~A~&Return to the Slate top level? " c)
	                          (throw 'top-level nil)))))
	    (signal 'method-not-found
		    :method-name name
		    :args (loop for argument in arguments
			    collect (invoke-method
				     '|printOn:| nil
				     argument *standard-output*))))
	(eval `(invoke-method '|messageNotUnderstood| nil ,@arguments)))
    *primitive-nil*))

(defmacro apply-method (method &rest arguments)
  (let ((meth-sym (%gensym)))
    `(let ((,meth-sym ,method))
       (funcall (the function (get-slot ,meth-sym '|code|)) ,meth-sym ,@arguments))))

(defun invoke-method (selector ignore &rest arguments)
  (let ((method (dispatch-method selector ignore t arguments)))
    (apply (the function (get-slot method '|code|)) method arguments)))

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

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

(defmacro define-method (name arguments &body body)
  (let ((argument-names
          (loop for argument in arguments
            if (consp argument)
              collect (first argument)
            else
              collect argument))
        (selector
          (if (stringp name)
              (intern name)
              (intern (string-downcase (string name))))))
    `(%add-roles ',selector
       (make-slate-method "" 0 ',selector
         ',argument-names
         *primitive-nil*
         (lambda (currentBlock ,@argument-names) 
           (block ,(when (symbolp name) name)
             (let ((currentMethod currentBlock))
               (declare (ignore currentMethod))
               ,@body))))
       ,@(loop for argument in arguments
           collect (when (consp argument) (second argument))))))