(proclaim '(optimize (debug 3)))

(in-package :hu.caleb)

;; Custom lambda implementation logic. Contains functions for which we have our own implementation,
;; but arnesi parses them as application-form.

(defvar *custom-function-hash* (make-hash-table :test 'eq))

(defmacro def-custom-function (symbol form-state)
  `(setf (gethash ',symbol *custom-function-hash*) ',form-state))

;; LET

(defclass let-form-state (form-state)
  ((current-variable :initform 0)
   (new-bindings :initform nil)))

(set-copy-function let-form-state new-bindings #'copy-list)

(defmethod initial-form-state-for-form ((form arnesi:let-form))
  (make-instance 'let-form-state :form form))

(defmethod init-form-state ((fs let-form-state) (es eval-state))
  (push-lexical-env es))

(defmethod step-form-state ((fs let-form-state) (es eval-state))
  (let* ((let-form (slot-value fs 'current-form))
	 (ivar (slot-value fs 'current-variable))
	 (binds (slot-value let-form 'arnesi:binds)))

    (when (> ivar 0)
      (push (current-state-input es) (slot-value fs 'new-bindings)))
    
    (cond
      ((eq ivar (length binds))
       (assert (eq (length (slot-value fs 'new-bindings)) (length binds)))

       (let ((special-names (special-variable-names let-form))
             (dynamic-env-created nil))
         
         (loop for (name . form) in binds 
               for value in (reverse (slot-value fs 'new-bindings))
               do (if (or (member name special-names) (globally-special-p name))
                    (progn
                      (add-special-variable (eval-state-lexical-env es) name)
                      (unless dynamic-env-created
                        (push-dynamic-env es)
                        (setq dynamic-env-created t))
                      (bind-variable (eval-state-dynamic-env es) name value))
                    
                    (bind-variable (eval-state-lexical-env es) name value))))
       
       (push-form-state es (make-instance 'statement-list-state
                                          :form let-form
                                          :body  (slot-value let-form 'arnesi:body)))
       (setf (slot-value fs 'current-variable) -1))
      
      ((eq ivar -1)
       (remove-form-state es))

      (t
       (incf (slot-value fs 'current-variable))
       (push-form-state es (initial-form-state-for-form (cdr (nth ivar binds))))))
    ))




;; LET*

(defclass let*-form-state (form-state)
  ((current-variable :initform 0)
   (dynamic-env-created :initform nil)
   (special-variables :initform nil)))

(defmethod initial-form-state-for-form ((form arnesi:let*-form))
  (make-instance 'let*-form-state :form form))

(defmethod init-form-state ((fs let*-form-state) (es eval-state))
  (push-lexical-env es))

(defmethod step-form-state ((fs let*-form-state) (es eval-state))
  (with-slots (current-form current-variable special-variables dynamic-env-created) fs
    (let ((binds (slot-value current-form 'arnesi:binds)))
      (when (> current-variable 0)
        (let ((name (car (nth (1- current-variable) binds)))
              (value (current-state-input es)))
          (if (or (member name special-variables) (globally-special-p name))
            (progn
              (add-special-variable (eval-state-lexical-env es) name)
              (unless dynamic-env-created
                (push-dynamic-env es)
                (setf dynamic-env-created t))
              (bind-variable (eval-state-dynamic-env es) name value))
            (bind-variable (eval-state-lexical-env es)
                           name
                           value))))

      (when (eq current-variable 0)
        (setf special-variables (special-variable-names current-form)))

      (cond
       ((eq current-variable (length binds))
        (push-form-state es (make-instance 'statement-list-state
                                           :form current-form
                                           :body (slot-value current-form 'arnesi:body)))
        (setf current-variable -1))
       ((eq current-variable -1)
        (remove-form-state es))

       (t
        (push-form-state es (initial-form-state-for-form (cdr (nth current-variable binds))))
        (incf current-variable)))
      )))

;; FLET
; Theoretically need not be broken into parts, but it is easy to interpret this way

(defclass flet-and-labels-form-state (form-state)
  ((current-function :initform 0)
   (current-symbol :initform nil)
   (type :initarg :type)
   (functions-to-bind :initform nil)))

(defmethod initial-form-state-for-form ((form arnesi:flet-form))
  (make-instance 'flet-and-labels-form-state :form form :type 'flet))

(defmethod initial-form-state-for-form ((form arnesi:labels-form))
  (make-instance 'flet-and-labels-form-state :form form :type 'labels))

(defmethod init-form-state ((fs flet-and-labels-form-state) (es eval-state))
  (with-slots (type) fs
    (if (eq type 'labels)
      (push-lexical-env es))))

(defmethod step-form-state ((fs flet-and-labels-form-state) (es eval-state))
  (with-slots (current-form current-function functions-to-bind current-symbol type) fs
    (with-slots (arnesi:binds arnesi:body) current-form
      (when (> current-function 0)
        (push (cons current-symbol (current-state-input es)) functions-to-bind))
      
      (cond
       ((eql current-function (length arnesi:binds))
        (if (eq type 'flet)
          (push-lexical-env es))
        (loop for (var . def) in functions-to-bind
              do (bind-function (eval-state-lexical-env es) var def))
        (push-form-state es (make-instance 'statement-list-state
                                           :form current-form
                                           :body arnesi:body))
        (setf current-function -1))
       
       ((eql current-function -1)
        (remove-form-state es))
       
       ((< current-function (length arnesi:binds))
        (destructuring-bind (var . def) (nth current-function arnesi:binds)
          (setf current-symbol var)
          (push-form-state es (initial-form-state-for-form def)))
        (incf current-function))
        
       (t
        (assert nil))))))
        
    


;; Constant forms

(defclass constant-form-state (form-state) ())

(defmethod initial-form-state-for-form ((form arnesi:constant-form))
  (make-instance 'constant-form-state :form form))

(defmethod step-form-state ((fs constant-form-state) (es eval-state))
  (set-form-state-input es (slot-value (slot-value fs 'current-form) 'arnesi:value))
  (remove-form-state es))


;; CALL/CC

(intern "CALL/CC")

(defclass continuation ()
  ((eval-state :initarg :eval-state :accessor continuation-eval-state))
  (:metaclass clos:funcallable-standard-class))

(defmethod initialize-instance :after ((cont continuation) &key)
  (clos:set-funcallable-instance-function cont
                                          (lambda (&optional rv)
                                            (run-continuation cont rv))))

(defun run-continuation (cont rv)
  ; Create an intepreter state and make it tick until it feels like stopping
  (let ((es (copy-instance (continuation-eval-state cont))))
    (set-form-state-input es rv)
    (run-eval-state es)))
  
(defclass call/cc-form-state (form-state)
  ((state :initform :eval-arg)))

(defmethod step-form-state ((fs call/cc-form-state) (es eval-state))
  (with-slots (state current-form) fs
    (let ((arg (nth 0 (slot-value current-form 'arnesi:arguments))))
      (ecase state
        (:eval-arg
         (setf state :return)
         (push-form-state es (initial-form-state-for-form arg)))
        
        (:return       
         (setf state :continue)
         (let ((cont (make-instance 'continuation :eval-state (copy-instance es)))
               (fn (current-state-input es)))
           
           (call-function-in-caleb es current-form fn (list cont))
           ))
        
        (:continue
         (remove-form-state es))))))

(def-custom-function call/cc call/cc-form-state)
          
;; LAMBDA

(defclass lambda-expression ()
  ((arglist :initarg :arglist)
   (form :initarg :form)
   (body :initarg :body)
   (lexenv :initarg :lexenv))
  (:metaclass clos:funcallable-standard-class))

(defun evaluate-lambda-application (lexpr arglist)
  (locally
    (declare (special *saved-dynamic-state*))
    (let* ((es (make-instance 'eval-state))
           (old-saved-state *saved-dynamic-state*)
           (*saved-dynamic-state* (cons es *saved-dynamic-state*)))

      (push-form-state es (make-instance 'lambda-call-form-state
                                         :lambda-expression lexpr
                                         :args arglist
                                         :form (slot-value lexpr 'form)))
                                       
      (loop while (not (eq (slot-value es 'form-state-stack) nil))
            do (step-eval-state es))
      (current-state-input es))))

(defmethod initialize-instance :after ((lexpr lambda-expression) &key)
  (clos:set-funcallable-instance-function lexpr
                                          (lambda (&rest args)
                                            (evaluate-lambda-application lexpr args))))

(defclass lambda-form-state (form-state) ())

(defmethod initial-form-state-for-form ((form arnesi:lambda-function-form))
  (make-instance 'lambda-form-state :form form))


(defmethod step-form-state ((fs lambda-form-state) (es eval-state))
  (with-slots (arnesi:source arnesi:body) (slot-value fs 'current-form)
    (let* ((lexpr (make-instance 'lambda-expression
                                 :arglist (nth 1 arnesi:source)
                                 :body arnesi:body
                                 :form (slot-value fs 'current-form)
                                 :lexenv (eval-state-lexical-env es))))      
      (set-form-state-input es lexpr)
      (remove-form-state es))))



(defgeneric initial-form-state-for-function-value (form))

; Symbols

(defclass symbol-function-form-state (form-state) ())

(defmethod initial-form-state-for-function-value ((form symbol))
  (make-instance 'symbol-function-form-state :form form))

(defmethod step-form-state ((fs symbol-function-form-state) (es eval-state))
  (let ((op (slot-value fs 'current-form)))
    (set-form-state-input es (find-symbol-function es op))
    (remove-form-state es)))
  

; Lambda forms

(defmethod initial-form-state-for-function-value ((form arnesi:lambda-function-form))
  (make-instance 'lambda-form-state :form form))


;; Function calls

(defclass lambda-call-form-state (form-state)
  ((current-state :initform :init)
   (eval-stack :initform nil)
   (current-arg-to-eval :initform nil)
   (parameters-to-bind :initform nil)
   (dynamic-env-created :initform nil)
   (lambda-expression :initarg :lambda-expression)
   (args :initarg :args)))

(set-copy-function lambda-call-form-state eval-stack #'copy-list)
(set-copy-function lambda-call-form-state parameters-to-bind #'copy-list)

(defmethod init-form-state ((fs lambda-call-form-state) (es eval-state))
  (with-slots (old-lexenv lambda-expression) fs
    (setf (eval-state-lexical-env es) (slot-value lambda-expression 'lexenv))
    (push-lexical-env es)))

(defmethod step-form-state ((fs lambda-call-form-state) (es eval-state))
  (with-slots (current-state eval-stack parameters-to-bind lambda-expression args current-arg-to-eval current-form dynamic-env-created) fs
    (let ((evaluator (lambda (var default-value) (push (cons var default-value) eval-stack)))
          (binder (lambda (var value) (push (cons var value) parameters-to-bind)))
          (lambda-list (slot-value lambda-expression 'arglist)))

      (case current-state
        (:init
         (destructure evaluator binder lambda-list args)
         (setf current-state :evaluate-loop))
        
        (:evaluate-loop
         (unless (eq current-arg-to-eval nil)
           (destructure evaluator binder
                        (car (slot-value fs 'current-arg-to-eval))
                        (current-state-input es)
                        :is-toplevel nil))
         
         (if (eq (slot-value fs 'eval-stack) nil)
           ; argument evaluation completed, we can finally call the lambda
           (progn
             (setf current-state :return)
             ; bind parameters to the new and shiny environment (maybe dynamic) we created for this application
             (let ((special-names (special-variable-names (slot-value lambda-expression 'form))))
               (loop for var in special-names
                     do (add-special-variable (eval-state-lexical-env es) var))
             
               (loop for (var . value) in parameters-to-bind
                     do (if (or (member var special-names) (globally-special-p var))
                          (progn
                            (unless dynamic-env-created
                              (push-dynamic-env es)
                              (setf dynamic-env-created t))
                            (add-special-variable (eval-state-lexical-env es) var)
                            (bind-variable (eval-state-dynamic-env es) var value))
                          (bind-variable (eval-state-lexical-env es) var value))))
             
             (push-form-state es (make-instance 'statement-list-state
                                                :form current-form
                                                :body (slot-value lambda-expression 'body)))
                                             
           ; there is something left in the eval stack, grab the first item and evaluate it
           (progn
             (setf current-arg-to-eval (pop eval-stack))
             (push-form-state es (initial-form-state-for-form (arnesi:walk-form (cdr current-arg-to-eval))))))))

        (:return
         (remove-form-state es))))))

         
  
(defclass application-form-state (form-state)
  ((current-arg :initform -1)
   (operator :initform nil)
   (evaluated-args :initform nil)))

(set-copy-function application-form-state evaluated-args #'copy-list)

(defmethod initial-form-state-for-form ((form arnesi:application-form))
  (multiple-value-bind (class-symbol found) (gethash (slot-value form 'arnesi:operator) *custom-function-hash*)
    (if found
      (make-instance class-symbol :form form)
      (make-instance 'application-form-state :form form))))

(defun find-continuation-for-exception (es ex)
  (destructuring-bind (type tag parameter value) ex
    (case type
      (:throw
       (list (find-catch-tag (eval-state-dynamic-env es) tag) parameter value))
      (:block
       (if (form-state-exists es tag)
         (list tag parameter value)
         (list nil nil nil)))
      (:go
       (if (form-state-exists es tag)
         (list tag parameter value)
         (list nil nil nil)))
      (otherwise
       (list nil nil nil)))))

(defun make-nested-catches (tag-list inner-form)
  (if (eq tag-list nil)
    (let ((sym (gensym)))
      `(list :return nil nil (multiple-value-list ,inner-form)))
    (let ((tag (car tag-list))
          (sym (gensym)))
      `(catch-and-handle (',tag (,sym) (list :throw ',tag nil ,sym))
                         ,(make-nested-catches (cdr tag-list) inner-form)))))

(defun make-special-bindings (bindings inner-form)
  (if (eq bindings nil)
    inner-form
    
    `(let ,(mapcar (lambda (binding) `( ,(car binding) ',(cdr binding))) bindings)
       (declare (special ,@(mapcar #'car bindings)))
       ,inner-form)))

;; Welcome to the DEFUN FROM HELL! Mwahahahaaa...!

(defun call-function-in-caleb (es form fn args)
  (cond
   ((eq (type-of fn) 'continuation)
    ; This is a continuation. Overwrite the current eval state with the one stored
    ; in the continuation.

    ; I am too lazy to find out the list of slots in an eval-state programmatically,
    ; so this has to be maintained manually
    (loop for slot in '(dynamic-env lexical-env form-state-stack exit-action)
          do (setf (slot-value es slot) (slot-value (continuation-eval-state fn) slot)))
    (set-form-state-input es (nth 0 args)))
   
   ((eq (type-of fn) 'lambda-expression)
    ; there is an interpreted version, interpret it 'by hand'.
    (progn
      (push-form-state es (make-instance 'lambda-call-form-state
                                         :lambda-expression fn
                                         :form form
                                         :args args))))

   (t
    ; no interpreted version, just apply the function and set input to
    ; its return value
    (let* ((was-nonlocal-exit t)
           (form-to-call (make-special-bindings (collect-variable-bindings (eval-state-dynamic-env es))
                                                (make-nested-catches (collect-catch-tags (eval-state-dynamic-env es))
                                                                     `(apply ,fn ',args))))
           non-unwind-result
           (result (unwind-protect
                       (setq non-unwind-result
                              (catch 'caleb-exception
                                (prog1
                                    (eval form-to-call)
                                  (setq was-nonlocal-exit nil))))
                     (when (eq non-unwind-result nil)
                       ; If there was a way to find out the type of exit that made this stack frame
                       ; unwind, result would simply be set to that, the nonlocal exit would be
                       ; discarded, and after unwinding, it would be reraised again.
                       ;
                       ; But I don't know if there is a way to do that, so now we will run inside
                       ; the stack unwinding and keep the precious native exit.
                       (setf (eval-state-exit-action es) '(:keep-native-exit))
                       (unwind-until-form nil nil es)
                       (run-eval-state es)
                       (unless (eq (first (eval-state-exit-action es)) :keep-native-exit)
                         (throw 'caleb-unwind-after-unwind-protect nil)))
                     non-unwind-result)))

      (unless was-nonlocal-exit
        (ecase (first result)
          (:return
           (setq result (nth 3 result)))
          (:throw
           (setq was-nonlocal-exit t))))

      (if was-nonlocal-exit
        (destructuring-bind (cont parameter value) (find-continuation-for-exception es result)
          (if (eq cont nil)
            ; Propagate exception, no interpreted handler exists
            ; Exceptions are propagated naturally, otherwise the thing is wrapped into caleb-exception
            (let (tag thrown-values)
              (if (eq (first result) :throw)
                (setq tag (nth 1 result) thrown-values (nth 3 result))
                (setq tag 'caleb-exception thrown-values (list result)))
              
              (throw tag thrown-values))
            (progn
              (setf (slot-value es 'form-state-input) value)
              (unwind-until-form cont parameter es))))
        (progn
          (setf (slot-value es 'form-state-input) result)
          (remove-form-state es))))
    )))

(defmethod step-form-state ((fs application-form-state) (es eval-state))
  (let* ((form (slot-value fs 'current-form))
         (args (slot-value form 'arnesi:arguments))
         (iarg (slot-value fs 'current-arg))
         (op (slot-value form 'arnesi:operator))
         (evaluator (lambda (var default-value) (push (cons var default-value) (slot-value fs 'temporary-eval-stack))))
         (binder (lambda (var value) (push (cons var value) (slot-value fs 'parameters-to-bind)))))

    (assert (<= iarg (length args)))
    
    (when (> iarg 0)
      (push (current-state-input es) (slot-value fs 'evaluated-args)))

    (when (= iarg 0)
      (setf (slot-value fs 'operator) (current-state-input es)))

    (cond
     ((eq iarg (length args))
      ; argument evaluation done, apply the function
      
      (assert (eq (length args) (length (slot-value fs 'evaluated-args))))

      (setf (slot-value fs 'current-arg) -2)
      (call-function-in-caleb es form (slot-value fs 'operator) (reverse (slot-value fs 'evaluated-args))))

     ((eq iarg -2)
      (remove-form-state es))
     ((eq iarg -1)
      (push-form-state es (initial-form-state-for-function-value op))
      (incf (slot-value fs 'current-arg)))
     
     (t
      (let ((current-arg (nth iarg args)))
        (push-form-state es (initial-form-state-for-form current-arg)))
      (incf (slot-value fs 'current-arg)))
     )))
     

;; PROGN

(defmethod initial-form-state-for-form ((form arnesi:progn-form))
  (make-instance 'statement-list-state
                 :form form
                 :body (slot-value form 'arnesi:body)))

;; IF
  
(defclass if-state (form-state)
  ((state :initform :init)))

(defmethod initial-form-state-for-form ((form arnesi:if-form))
  (make-instance 'if-state :form form))

; TODO: send in arnesi patch to export arnesi::else

(defmethod step-form-state ((fs if-state) (es eval-state))
  (with-slots (current-form state) fs
    (case state
      (:init
       (setf state :decided)
       (push-form-state es (initial-form-state-for-form (slot-value current-form 'arnesi:consequent))))
      (:decided
       (setf state :return)
       (push-form-state es (initial-form-state-for-form (if (current-state-input es)
                                                          (slot-value current-form 'arnesi:then)
                                                          ; BUG: arnesi does not export else
                                                          (slot-value current-form 'arnesi::else)))))
      (:return
       (remove-form-state es)))))

;; BLOCK

(defclass block-form-state (form-state)
  ((state :initform :init)))

(defmethod initial-form-state-for-form ((form arnesi:block-form))
  (make-instance 'block-form-state :form form))

(defmethod step-form-state ((fs block-form-state) (es eval-state))
  (with-slots (state current-form) fs
    (with-slots (lexical-env form-state-stack) es
      (case state
        (:init
         (bind-block-label lexical-env (slot-value current-form 'arnesi:name) (form-state-id fs))
         
         (push-form-state es (make-instance 'statement-list-state
                                            :form current-form
                                            :body (slot-value current-form 'arnesi:body)))
         (setf state :return))
        (:return
         (remove-form-state es))
        (t
         (assert nil))))))

;; RETURN-FROM

(defclass return-from-form-state (form-state)
  ((state :initform :init)))

(defmethod initial-form-state-for-form ((form arnesi:return-from-form))
  (make-instance 'return-from-form-state :form form))

(defmethod step-form-state ((fs return-from-form-state) (es eval-state))
  (with-slots (current-form state) fs
    (with-slots (lexical-env form-state-stack) es
      (case state
        (:init
         (push-form-state es (initial-form-state-for-form (slot-value current-form 'arnesi:result)))
         (setf state :return))
        
        (:return
         (let* ((block-name (nth 1 (slot-value current-form 'arnesi:source)))
                (cont (find-block-label lexical-env block-name)))

           (assert (not (eq cont nil)))

           ; test if the block found in the lexical env is not in the dynamic-env, i.e.
           ; (block obb (lambda () (return-form obb 42)))

           (if (not (form-state-exists es cont))
             ; block is not found, maybe there is some noninterpreted code in the way
             (throw 'caleb-exception (list :block cont nil (slot-value es 'form-state-input)))

             ; block is found, go on merrily
             (unwind-until-form cont nil es))
           ))))))

      
;; UNWIND-PROTECT
(defclass unwind-protect-form-state (form-state)
  ((state :initform :init)
   (target-form :initform nil)
   (returned-form-state :initform nil)
   (saved-exit-action :initform nil)
   (target-form-state-parameter :initform nil)))

(defmethod initial-form-state-for-form ((form arnesi:unwind-protect-form))
  (make-instance 'unwind-protect-form-state :form form))

(defmethod step-form-state ((fs unwind-protect-form-state) (es eval-state))
  (with-slots (current-form state target-form returned-form-state saved-exit-action) fs
    (case state
      (:init
       (setf state :cleanup)
       (push-form-state es (initial-form-state-for-form (slot-value current-form 'arnesi:protected-form))))
      (:cleanup
       (setf state :return)
       (setf returned-form-state (slot-value es 'form-state-input))
       (setf saved-exit-action (eval-state-exit-action es))
       (push-form-state es (make-instance 'statement-list-state
                                          :form current-form
                                          :body (slot-value current-form 'arnesi:cleanup-form))))
      (:return
       (remove-form-state es)
       (setf (slot-value es 'form-state-input) returned-form-state)
       (setf (eval-state-exit-action es) saved-exit-action)
       (unless (eq target-form nil)
         (unwind-until-form target-form nil es))))))


;; TAGBODY

(defclass tagbody-form-state (form-state)
  ((state :initform :init)))

(defmethod initial-form-state-for-form ((form arnesi:tagbody-form))
  (make-instance 'tagbody-form-state :form form))

(defmethod modify-form-state ((fs tagbody-form-state) parameter)
  (setf (slot-value fs 'state) parameter))

(defmethod step-form-state ((fs tagbody-form-state) (es eval-state))
  (with-slots (state current-form) fs
    (with-slots (arnesi:body) current-form
      (cond
       ((eq state :init)
        ; parse TAGBODY, add GO tags to lexical environment
        (dotimes (iform (length arnesi:body))
          (let ((child-form (nth iform arnesi:body)))
            (if (eq (type-of child-form) 'arnesi:go-tag-form)
              (bind-tagbody-tag (eval-state-lexical-env es) (slot-value child-form 'arnesi:name) (form-state-id fs) iform))))
        (setf state 0))
       ((eq state (length arnesi:body))
        (set-form-state-input es nil)
        (remove-form-state es))
       (t
        (push-form-state es (initial-form-state-for-form (nth state arnesi:body)))
        (incf state))))))

(defclass go-tag-form-state (form-state) ())

(defmethod initial-form-state-for-form ((form arnesi:go-tag-form))
  (make-instance 'go-tag-form-state :form form))

(defmethod step-form-state ((fs go-tag-form-state) (es eval-state))
  ; do nothing, GO tags should be ignored during execution
  (remove-form-state es))


;; GO

(defclass go-form-state (form-state) ())

(defmethod initial-form-state-for-form ((form arnesi:go-form))
  (make-instance 'go-form-state :form form))

(defmethod step-form-state ((fs go-form-state) (es eval-state))
  (with-slots (current-form) fs
    (let ((go-target (find-tagbody-tag (eval-state-lexical-env es) (slot-value current-form 'arnesi:name))))
      ; Can target label be found?

      (assert (not (eq go-target nil)))
      (destructuring-bind (form-state-id . go-tag) go-target
        (if (form-state-exists es form-state-id)
          ; target stack frame found
          (unwind-until-form form-state-id go-tag es)
          ; target stack frame not found, maybe noninterpreted code is in the way
          (throw 'caleb-exception (list :go form-state-id go-tag nil)) 
          )))))


  
;; SETQ

; TODO: send in arnesi patch to reverse order of SETQ assignments because it is just plain wrong

(defclass setq-state (form-state)
  ((current-var :initform 0)))

(defmethod initial-form-state-for-form ((form arnesi:setq-form))
  (make-instance 'setq-state :form form))

; arnesi converts multiple-variable SETQ forms into PROGN forms containing multiple SETQ's

(defmethod step-form-state ((fs setq-state) (es eval-state))
  (with-slots (current-var current-form) fs
    (cond
     ((eq current-var 0)
      (push-form-state es (initial-form-state-for-form (slot-value current-form 'arnesi:value)))
      (incf current-var))
     ((eq current-var 1)
      (let ((binding (find-variable es (slot-value current-form 'arnesi:var))))
        (if (eq binding nil)
          ; Variable not found, set a global variable
          ; TODO: check whether global special variables need special treatment
          (set (slot-value current-form 'arnesi:var) (current-state-input es))

          ; Variable found, replace its binding
          (rplacd binding (current-state-input es))))
      (remove-form-state es))
     ((eq current-var 2)
      (remove-form-state es))
     (t
      (assert nil)))))
  
;; variable reference

(defmethod initial-form-state-for-form ((form arnesi:variable-reference))
  (make-instance 'variable-reference-state
                 :form form))

(defclass variable-reference-state (form-state) ())

; TODO: send in arnesi patch to handle t correctly (not variable-reference, but constant-form)

(defmethod step-form-state ((fs variable-reference-state) (es eval-state))
  (let* ((form (slot-value fs 'current-form))
         (varname (slot-value form 'arnesi:name))
         (binding (find-variable es varname)))
    (remove-form-state es)

    (cond
     ((or (eq varname t) (eq varname nil))
      ; HACK: this is a fix for an arnesi bug, t and nil are considered a free-variable-reference there.
      ; TODO: although binding is resolved anyway...
      (set-form-state-input es varname))
     ((eq binding nil)
      ; No variable is found, check global variables
      (set-form-state-input es (eval varname)))
     (t
      (set-form-state-input es (cdr binding))))))


;; THE

(defclass the-form-state (form-state)
  ((state :initform :init)))

(defmethod initial-form-state-for-form ((form arnesi:the-form))
  (make-instance 'the-form-state :form form))

(defmethod step-form-state ((fs the-form-state) (es eval-state))
  (with-slots (current-form state) fs
    (case state
     (:init
      (push-form-state es (initial-form-state-for-form (slot-value current-form 'arnesi:value)))
      (setf state :return))
     (:return
      (set-form-state-input es (eval `(the ,(slot-value current-form 'arnesi:type-form) ,(current-state-input es))))
      (remove-form-state es)))))


;; LOCALLY

(defclass locally-form-state (form-state)
  ((state :initform :init)))

(defmethod initial-form-state-for-form ((form arnesi:locally-form))
  (make-instance 'locally-form-state :form form))

(defmethod step-form-state ((fs locally-form-state) (es eval-state))
  (with-slots (current-form state lexical-env-added) fs
    (case state
      (:init
       (let ((special-names (special-variable-names current-form)))
         (unless (eq special-names nil)
           (push-lexical-env es)
           (loop for name in special-names
                 do (add-special-variable (eval-state-lexical-env es) name))))
       (push-form-state es (make-instance 'statement-list-state
                                          :form current-form
                                          :body (slot-value current-form 'arnesi:body)))
       (setf state :return))
      
      (:return
       (remove-form-state es)))))

;; CATCH

(defclass catch-form-state (form-state)
  ((state :initform -1)
   (tag-added :initform nil)))

(defmethod modify-form-state ((fs catch-form-state) parameter)
  (assert (eq parameter nil))
  
  (with-slots (current-form state) fs
    (setf state (length (slot-value current-form 'arnesi:body)))))

(defmethod initial-form-state-for-form ((form arnesi:catch-form))
  (make-instance 'catch-form-state :form form))

(defmethod init-form-state ((fs catch-form-state) (es eval-state))
  (push-dynamic-env es))

(defmethod step-form-state ((fs catch-form-state) (es eval-state))
  (with-slots (current-form state tag-added) fs
    (with-slots (arnesi:tag arnesi:body) current-form

      (cond
       ((eq state -1)
        ; evaluate tag
        (setf state 0)
        (push-form-state es (initial-form-state-for-form arnesi:tag)))
       ((< state (length arnesi:body))
        (when (and (eq state 0) (not tag-added))
          (setf tag-added t)
          (bind-catch-tag (eval-state-dynamic-env es) (current-state-input es) (form-state-id fs)))

        (push-form-state es (initial-form-state-for-form (nth state arnesi:body)))
        (incf state))
       ((eq state (length arnesi:body))
        (when (eq (length arnesi:body) 0)
          (set-form-state-input es nil))
        (remove-form-state es))
       (t
        (assert nil))))))
      
;; THROW

(defclass throw-form-state (form-state)
  ((state :initform :tag)
   (tag :initform nil)))

(defmethod initial-form-state-for-form ((form arnesi:throw-form))
  (make-instance 'throw-form-state :form form))

(defmethod step-form-state ((fs throw-form-state) (es eval-state))
  (with-slots (state tag current-form) fs
    (with-slots (arnesi:tag arnesi:value) current-form
      (case state
        (:tag
         (setf state :result)
         (push-form-state es (initial-form-state-for-form arnesi:tag)))
        (:result
         (setf state :return)
         (setf tag (current-state-input es))
         (push-form-state es (initial-form-state-for-form arnesi:value)))
        (:return
         (let ((cont (find-catch-tag (eval-state-dynamic-env es) tag)))
           (if (eq cont nil)
             ; Propagate exception, no interpreted handler exists
             (throw tag (values-list (slot-value es 'form-state-input)))
             (unwind-until-form cont nil es))))))))


;; MULTIPLE-VALUE-CALL

(defclass multiple-value-call-state (form-state)
  ((state :initform -1)
   (operator :initform nil)
   (args :initform nil)))

(defmethod initial-form-state-for-form ((form arnesi:multiple-value-call-form))
  (make-instance 'multiple-value-call-state :form form))

(defmethod step-form-state ((fs multiple-value-call-state) (es eval-state))
  (with-slots (current-form state operator args) fs
    (with-slots (arnesi:func arnesi:arguments) current-form
      (when (eq state 0)
        (setf operator (current-state-input es)))

      (when (> state 0)
        (setq args (append args (slot-value es 'form-state-input))))
      
      (cond
       ((eq state -1)
        (push-form-state es (initial-form-state-for-form arnesi:func))
        (setq state 0))

       ((eq state -2)
        (remove-form-state es))
       
       ((< state (length arnesi:arguments))
        (push-form-state es (initial-form-state-for-form (nth state arnesi:arguments)))
        (incf state))

       ((eq state (length arnesi:arguments))
        (setf state -2)
        (call-function-in-caleb es current-form operator args))

       (t
        (assert nil))))))

;; FUNCTION (aka #')

(defclass function-form-state (form-state)
  ((state :initform :init)))

(defmethod initial-form-state-for-form ((form arnesi:free-function-object-form))
  (make-instance 'function-form-state :form form))

(defmethod step-form-state ((fs function-form-state) (es eval-state))
  (with-slots (current-form state) fs
    (with-slots (arnesi:name) current-form
      (case state
        (:init
         (push-form-state es (initial-form-state-for-function-value arnesi:name))
         (setf state :return))
        (:return
         (remove-form-state es)))
      )))

;; MULTIPLE-VALUE-PROG1

(defclass multiple-value-prog1-state (form-state)
  ((state :initform :init)
   (return-values :initform nil)))

(defmethod initial-form-state-for-form ((form arnesi:multiple-value-prog1-form))
  (make-instance 'multiple-value-prog1-state :form form))

(defmethod step-form-state ((fs multiple-value-prog1-state) (es eval-state))
  (with-slots (state return-values current-form) fs
    (with-slots (arnesi:first-form arnesi:other-forms) current-form
      (case state
        (:init
         (push-form-state es (initial-form-state-for-form arnesi:first-form))
         (setf state :list))

        (:list
         (push-form-state es (make-instance 'statement-list-state
                                            :body arnesi:other-forms
                                            :form current-form))
         (setf state :return)
         (setf return-values (slot-value es 'form-state-input)))

        (:return
         (setf (slot-value es 'form-state-input) return-values)
         (remove-form-state es))))))

;; LOAD-TIME-VALUE

; Always runs the form, since this is an interpreter
; TODO: export load-time-value-form from arnesi

(defclass load-time-value-form-state (form-state)
  ((state :initform :init)))

(defmethod initial-form-state-for-form ((form arnesi::load-time-value-form))
  (make-instance 'load-time-value-form-state :form form))

(defmethod step-form-state ((fs load-time-value-form-state) (es eval-state))
  (with-slots (state current-form) fs
    (with-slots (arnesi:value) current-form
      (case state
        (:init
         (push-form-state es (initial-form-state-for-form arnesi:value))
         (setf state :return))
        (:return
         (remove-form-state es))))))


;; PROGV

(defclass progv-form-state (form-state)
  ((state :initform :vars)
   (bound-symbols :initform nil)
   (bound-values :initform nil)))

(defmethod initial-form-state-for-form ((Form arnesi:progv-form))
  (make-instance 'progv-form-state :form form))

(defmethod init-form-state ((fs progv-form-state) (es eval-state))
  (push-lexical-env es))

(defmethod step-form-state ((fs progv-form-state) (es eval-state))
  (with-slots (state bound-symbols bound-values current-form) fs
      (with-slots (arnesi:vars-form arnesi:values-form arnesi:body) current-form
        (case state
          (:vars
           (push-form-state es (initial-form-state-for-form arnesi:vars-form))
           (setf state :values))

          (:values
           (setf bound-symbols (current-state-input es))
           ; where is 'for all elements of this sequence'?
           (assert (listp bound-symbols))
           (assert (eql (count-if-not #'symbolp bound-symbols) 0))
           (push-form-state es (initial-form-state-for-form arnesi:values-form))
           (setf state :body))

          (:body
           (setf bound-values (current-state-input es))
           (assert (listp bound-values))

           (loop for symbol in bound-symbols
                 for value in bound-values
                 do (bind-variable (eval-state-lexical-env es) symbol value))

           (push-form-state es (make-instance 'statement-list-state
                                              :form current-form
                                              :body arnesi:body))

           (setf state :return))

          (:return
           (remove-form-state es))))))

;; EVAL-WHEN

(defclass eval-when-form-state (form-state)
  ((state :initform :init)))

(defmethod initial-form-state-for-form ((form arnesi:eval-when-form))
  (make-instance 'eval-when-form-state :form form))

(defmethod step-form-state ((fs eval-when-form-state) (es eval-state))
  (with-slots (state current-form) fs
    (with-slots (arnesi:eval-when-times arnesi:body) current-form
      (case state
        (:init
         (let ((execute (eval `(eval-when ,arnesi:eval-when-times t))))
           (if execute
             (progn
               (push-form-state es (make-instance 'statement-list-state
                                                  :form current-form
                                                  :body arnesi:body))
               (setf state :return))
             (progn
               (set-form-state-input es nil)
               (remove-form-state es)))))
        (:return
         (remove-form-state es))))))
  
;; custom funcall

; Currently does not work because call/cc becomes a little more general with this
(def-custom-function funcall funcall-form-state)


(defclass funcall-form-state (form-state)
  ((state :initform 0)
   (evaluated-arguments :initform nil)))

(set-copy-function funcall-form-state evaluated-arguments #'copy-list)

(defmethod step-form-state ((fs funcall-form-state) (es eval-state))
  (with-slots (state evaluated-arguments current-form) fs
    (with-slots (arnesi:arguments) current-form
      (cond
       ((numberp state)
        (when (> state 0)
          (push (current-state-input es) evaluated-arguments))
        
        (if (eql (length arnesi:arguments) state)
          (progn
            (setf state :return)
            (let* ((correct-order-args (reverse evaluated-arguments))
                   (fn (car correct-order-args))
                   (args (cdr correct-order-args)))
              (when (symbolp fn)
                (setq fn (find-symbol-function es fn)))

              (call-function-in-caleb es current-form fn args)))
          (progn
            (push-form-state es (initial-form-state-for-form (nth state arnesi:arguments)))
            (incf state))))
       ((eq state :return)
        (remove-form-state es))))))