;; TODO:
;; - implement block/return-from/unwind-protect/catch/tagbody with continuations once continuations work :)
;;
;; - special case for funcall: if the callee is an intepreted lambda or continuation, do not venture
;;   to native code
;;
;; - let/cc (just a simple macro)
;;
;; - maybe with-call/cc a'la arnesi
;;
;; - test all native/interpreted combinations of handler/restart/signal
;;
;; - write a couple of test cases for the correct functioning of interpreted unwind-protect and various
;;   nonlocal exits (return-from and go)
;;
;; - (?) make lexical variable references work (i.e. (let ((a nil)) (caleb '(setq a 3))) )

(proclaim '(optimize (debug 3)))

(in-package :hu.caleb)

(defclass bindings-container ()
  ((function-bindings :initform nil)
   (variable-bindings :initform nil)
   (parent-container :initform nil :initarg :parent :accessor bindings-container-parent)))

(defclass dynamic-environment (bindings-container)
  ((catch-tags :initform nil)))

(defclass lexical-environment (bindings-container)
  ((block-eval-state-map :initform nil)
   (go-tag-eval-state-map :initform nil)
   (special-variables :initform nil)))

(defvar *saved-dynamic-state* nil)

(defmethod find-variable ((env (eql nil)) name)
  nil)

(defmethod find-variable ((env bindings-container) name)
  (let ((found (assoc name (slot-value env 'variable-bindings))))
    (if (eq found nil)
      (find-variable (slot-value env 'parent-container) name)
      found)))

; Please do not set variables to caleb::variable-is-special!

(defmethod find-variable ((env lexical-environment) name)
  (if (member name (slot-value env 'special-variables))
    'variable-is-special
    (call-next-method)))

(defmethod find-function ((env (eql nil)) name)
  nil)

(defmethod find-function ((env bindings-container) name)
  (let ((found (assoc name (slot-value env 'function-bindings))))
    (if (eq found nil)
      (find-function (slot-value env 'parent-container) name)
      found)))

(defmethod bind-variable ((env bindings-container) name value)
  (assert (symbolp name))
  (push (cons name value) (slot-value env 'variable-bindings)))

(defmethod bind-function ((env bindings-container) name value)
  (push (cons name value) (slot-value env 'function-bindings)))
  
(defmethod set-variable ((env bindings-container) name value)
  (if (eq (find-variable env name) nil)
      (bind-variable env name value)
      (rplacd (find-variable env name) value))
  nil)

(defmethod bind-catch-tag ((env dynamic-environment) tag id)
  (push (cons tag id)
        (slot-value env 'catch-tags)))

(defmethod find-catch-tag ((env dynamic-environment) tag)
  (let ((found (assoc tag (slot-value env 'catch-tags))))
    (if (eq found nil)
      (find-catch-tag (slot-value env 'parent-container) tag)
      (cdr found))))

(defmethod find-catch-tag ((env (eql nil)) tag)
  nil)

(defmethod collect-catch-tags ((env dynamic-environment))
  (with-slots (catch-tags parent-container) env
    (append (mapcar #'car catch-tags) (collect-catch-tags parent-container))))

(defmethod collect-catch-tags ((env (eql nil)))
  nil)

(defmethod collect-variable-bindings ((env bindings-container))
  (with-slots (variable-bindings parent-container) env
    (append variable-bindings (collect-variable-bindings parent-container))))

(defmethod collect-variable-bindings ((env (eql nil)))
  nil)
      
(defmethod bind-block-label ((env lexical-environment) label id)
  (push (cons label id)
        (slot-value env 'block-eval-state-map)))

(defmethod find-block-label ((env lexical-environment) name)
  (let ((found (assoc name (slot-value env 'block-eval-state-map))))
    (if (eq found nil)
      (find-block-label (slot-value env 'parent-container) name)
      (cdr found))))

(defmethod find-block-label ((env (eql nil)) name)
  nil)

(defmethod bind-tagbody-tag ((env lexical-environment) tag id iform)
  (push (cons tag
              (cons id iform))
        (slot-value env 'go-tag-eval-state-map)))

(defmethod find-tagbody-tag ((env lexical-environment) name)
  (let ((found (assoc name (slot-value env 'go-tag-eval-state-map))))
    (if (eq found nil)
      (find-tagbody-tag (slot-value env 'parent-container) name)
      (cdr found))))

(defmethod find-tagbody-tag ((env (eql nil)) name)
  nil)

(defun find-symbol-function (es symbol)
  (let ((cell (find-function (slot-value es 'lexical-env) symbol)))
      (if (eq cell nil)
        (symbol-function symbol)
        (cdr cell))))  
                                
(defmethod add-special-variable ((env lexical-environment) name)
  (push name (slot-value env 'special-variables)))

(defclass eval-state ()
  ; If you add a slot here, modify call-function-in-caleb, too!
   ((dynamic-env :initform nil :accessor eval-state-dynamic-env)
    (lexical-env :initform  nil :accessor eval-state-lexical-env)
    (form-state-stack :initform nil)
    (form-state-input :initform nil)
    (exit-action :initform '(:return) :accessor eval-state-exit-action)))

(defclass form-state ()
  ((current-form :initarg :form)
   (lexenv-before :initform nil)
   (dynenv-before :initform nil)
   (id :initform (gensym) :accessor form-state-id)))

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

(defmethod push-form-state ((es eval-state) (fs form-state))
  (with-slots (lexenv-before dynenv-before) fs
    (setf lexenv-before (eval-state-lexical-env es))
    (setf dynenv-before (eval-state-dynamic-env es)))
  
  (init-form-state fs es)
  (push fs (slot-value es 'form-state-stack)))

(defun remove-form-state (es)
  (with-slots (form-state-stack form-state-input) es
    (assert (not (eq form-state-stack nil)))
    (let ((fs-removed (pop form-state-stack)))
      (unwind-form-state fs-removed es)
      (with-slots (lexenv-before dynenv-before) fs-removed
        (setf (eval-state-lexical-env es) lexenv-before)
        (setf (eval-state-dynamic-env es) dynenv-before)))
    ))

(defun form-state-exists (es id)
  (loop for candidate in (slot-value es 'form-state-stack)
        do (when (eq (form-state-id candidate) id) (return-from form-state-exists t)))
  nil)
                          

(defmethod current-form-state ((es eval-state))
  (with-slots (form-state-stack) es
    (if (eq form-state-stack nil)
      nil
      (car form-state-stack))))

(defmethod set-form-state-input ((es eval-state) input)
  (setf (slot-value es 'form-state-input) (list input)))

(defmethod current-state-input ((es eval-state))
  (nth 0 (slot-value es 'form-state-input)))

(defmethod push-lexical-env ((es eval-state))
  (with-slots (lexical-env) es
    (setf lexical-env (make-instance 'lexical-environment :parent lexical-env))))

(defmethod pop-lexical-env ((es eval-state))
  (with-slots (lexical-env) es
    (setf lexical-env (bindings-container-parent lexical-env))))

(defmethod push-dynamic-env ((es eval-state))
  (with-slots (dynamic-env) es
    (setf dynamic-env (make-instance 'dynamic-environment :parent dynamic-env))))

(defmethod pop-dynamic-env ((es eval-state))
  (with-slots (dynamic-env) es
    (setf dynamic-env (bindings-container-parent dynamic-env))))


(defgeneric step-form-state (form-state eval-state))

(defgeneric unwind-form-state (form-state eval-state))

(defgeneric init-form-state (form-state eval-state))

(defgeneric modify-form-state (form-state parameter))

(defmethod modify-form-state ((fs form-state) parameter))

(defmethod unwind-form-state ((fs form-state) eval-state))

(defmethod init-form-state ((fs form-state) eval-state))

(defun unwind-until-form (form parameter es)
  (loop named unroll
        until (eq (current-form-state es) nil)
        do (progn
             (cond
              ((and (eq (type-of (current-form-state es)) 'unwind-protect-form-state)
                    (not (eq (slot-value (current-form-state es) 'state) :return)))
               (setf (slot-value (current-form-state es) 'target-form) form)
               (setf (slot-value (current-form-state es) 'target-form-state-parameter) parameter)
               (return-from unroll))
              ((eq (form-state-id (current-form-state es)) form)
               (modify-form-state (current-form-state es) parameter)
               (return-from unroll))
              (t
               (remove-form-state es))))))

(defun find-dynamic-variable (name)
  (locally
    (declare (special *saved-dynamic-state*))

    (loop for es in *saved-dynamic-state*
          do (progn
               (let ((binding (find-variable (eval-state-dynamic-env es) name)))

                 (unless (eq binding nil)
                   (return-from find-dynamic-variable binding)))))
    nil))
  
(defmethod find-variable ((es eval-state) name)
  (with-slots (lexical-env dynamic-env) es
    (let ((from-lexenv (find-variable lexical-env name)))
      (cond
       ((eq from-lexenv 'variable-is-special)
        (find-dynamic-variable name))
       ((and (eq from-lexenv nil) (globally-special-p name))
        ; when the variable is globally special (defvar'd), it should not
        ; be bound in the lexical environment. Globaly-special-p can be
        ; slow, so the first part of the and is used as an optimization
        (find-dynamic-variable name))
       (t
        from-lexenv)))))


;; Statement lists (e.g. the body of a progn)

(defclass statement-list-state (form-state)
  ((current-stmt :initform 0)
   (body :initarg :body)))

(defmethod step-form-state ((fs statement-list-state) (es eval-state))
  (let ((body (slot-value fs 'body))
        (istmt (slot-value fs 'current-stmt)))
    (cond
     ((eq istmt (length body))
      (when (eq (length body) 0)
        (set-form-state-input es nil))
      (remove-form-state es))
     (t
      (push-form-state es (initial-form-state-for-form (nth istmt body)))
      (incf (slot-value fs 'current-stmt)))
     )))
        
         
        



(defun step-eval-state (es)
  (with-slots (form-state-stack form-state-input) es
    (assert (not (eq form-state-stack nil)))
    (rplaca form-state-stack (copy-instance (car form-state-stack)))
    (step-form-state (car form-state-stack) es)))

(defun run-eval-state (es)
  (catch 'caleb-unwind-after-unwind-protect
    (loop while (not (eq (slot-value es 'form-state-stack) nil))
          do (step-eval-state es)))
  
  (ecase (first (eval-state-exit-action es))
    (:keep-native-exit
     ; This return value will not be used since the caller will do a non-local exit
     nil)
    (:return
     (values-list (slot-value es 'form-state-input)))
    (:throw
     (throw (nth 1 (eval-state-exit-action es)) (nth 2 (eval-state-exit-action es))))
    ))

(defun evaluate-arnesi-form (form)
  (locally
    (declare (special *saved-dynamic-state*))
    (let* ((es (make-instance 'eval-state))
           (*saved-dynamic-state* (cons es *saved-dynamic-state*)))
      (declare (special *saved-dynamic-state*))
      (push-lexical-env es)
      (push-form-state es (initial-form-state-for-form form))
      (run-eval-state es))))

(defun caleb (form)
  (evaluate-arnesi-form (arnesi:walk-form (arnesi::macroexpand-all form))))

; Meg ennyi roham:
; - call/cc
; - dynamic-wind
; es hasznalhato lesz!

; MACROLET                    not needed
; SYMBOL-MACROLET             not needed
; QUOTE                       not needed
; DECLARE                     not needed, only special declarations matter

; LAMBDA                      done
; IF                          done
; PROGN                       done

; LET                         done
; LET*                        done

; FLET                        done
; LABELS                      done

; SETQ                        done

; RETURN-FROM                 done
; BLOCK                       done

; UNWIND-PROTECT              done

; TAGBODY                     done
; GO                          done

; THE                         done

; LOCALLY                     done

; CATCH                       done
; THROW                       done

; MULTIPLE-VALUE-CALL         done
; MULTIPLE-VALUE-PROG1        done

; EVAL-WHEN                   done
; LOAD-TIME-VALUE             done

; PROGV                       done