(in-package :hu.caleb.test)
            
(def-suite :hu.caleb.evaluator :in :hu.caleb)
(in-suite :hu.caleb.evaluator)

(defmacro evaluator-test ((name &key (test 'equal)) form expected-result)
  `(test ,name
     (is (,test (hu.caleb:caleb ',form)
                ',expected-result))))

(evaluator-test (can-eval-constant-form-1)
                3
                3)

(evaluator-test (can-eval-constant-form-2)
                'alma
                alma)

(evaluator-test (can-eval-constant-form-3)
                '(complex (form (because . i) am sneaky) 42)
                (complex (form (because . i) am sneaky) 42))

(evaluator-test (can-eval-simple-progn)
                (progn 1 2)
                2)

(evaluator-test (can-eval-simple-let)
                (let ((a 2)) a)
                2)

(evaluator-test (can-eval-simple-application)
                (+ 3 4)
                7)

(evaluator-test (can-eval-lambda-form-application)
                ((lambda (a b) (+ a b)) 3 4)
                7)

(test lambda-form-callable-outside
  (let ((l (hu.caleb:caleb '(lambda (a b) (+ a b)))))
    (is (= (funcall l 3 4)))))

(evaluator-test (let-shadows)
                (let ((a 2))
                  (let ((a 4))
                    a))
                4)

(evaluator-test (let-is-parallel)
                (let ((a 2) (b 3))
                  (let ((a b) (b a))
                    (cons a b)))
                (3 . 2))

(evaluator-test (let-binds-special-variables)
                (flet ((return-a ()
                         (locally
                           (declare (special a))
                           a)))
                  (let ((a 'good))
                    (declare (special a))
                    (return-a)))
                good)
                      
(evaluator-test (can-eval-simple-let*)
                (let* ((a 2)) a)
                2)

(evaluator-test (simple-let*-sequential)
                (let* ((a 2) (b a)) b)
                2)

(evaluator-test (let*-binds-special-variables)
                (flet ((return-a ()
                         (locally
                           (declare (special a))
                           a)))
                  (let* ((a 'good))
                    (declare (special a))
                    (return-a)))
                good)

(evaluator-test (simple-if-1)
                (if t 2 3)
                2)

(evaluator-test (simple-if-2)
                 (if nil 2 3)
                 3)

(evaluator-test (simple-setq-1)
                (let ((a 2))
                  (setq a 3)
                  a)
                3)

(evaluator-test (simple-setq-2)
                (let ((a 2) (b 4))
                  (setq a 'cica b 'kutya)
                  (cons a b))
                (cica . kutya))

(evaluator-test (setq-is-sequential)
                (let ((a 2) (b 1))
                  (setq a b b a)
                  (cons a b))
                (1 . 1))

(evaluator-test (setq-sets-special-variable)
                (flet ((return-a ()
                         (locally
                           (declare (special a))
                           a)))
                  (let* ((a 'bad))
                    (declare (special a))
                    (setq a 'good)
                    (return-a)))
                good)
                         
(evaluator-test (simple-flet-1)
                (flet ((add1 (a) (+ a 1)))
                  (add1 3))
                4)

(evaluator-test (simple-labels-1)
                (labels ((is-even (n)
                           (if (eql n 0)
                             t
                             (is-odd (- n 1))))
                         (is-odd (n)
                           (if (eql n 0)
                             nil
                             (is-even (- n 1)))))
                  (list (is-even 4) (is-odd 4) (is-even 3)))
                (t nil nil))

(evaluator-test (flet-labels-difference-1)
                (flet ((bad (_) 'bad))
                  (flet ((bad (n)
                           (if (eql n 0)
                             1
                             (bad (- n 1)))))
                    (bad 2)))
                bad)

(evaluator-test (flet-labels-difference-2)
                (flet ((bad (_) 'bad))
                  (labels ((bad (n)
                           (if (eql n 0)
                             1
                             (bad (- n 1)))))
                    (bad 2)))
                1)

(evaluator-test (simple-block-1)
                (block obb
                  (return-from obb 'good)
                  'bad)
                good)

(evaluator-test (simple-block-2)
                (block obb
                  'one
                  'two)
                two)
                     
(evaluator-test (block-chooses-innermost)
                (block obb
                  (block obb
                    (return-from obb 'bad))
                  'good)
                good)

(evaluator-test (block-returns-over-not-interpreted-code)
                (block obb
                  (let ((fn (lambda () (return-from obb 'good))))
                    (funcall fn)
                    'bad))
                good)

; TODO: test what happens when lexenv containing block label is closed over but
; block is not in the dynamic env

; TODO: block-contained-by-lexenv, when a return-from is called from outside the pertaining
; block because it is contained in a lambda and returned

(evaluator-test (simple-unwind-protect-1)
                (let (rv)
                  (block obb
                    (unwind-protect
                        (progn
                          (push 'first rv)
                          (return-from obb)
                          (push 'second rv))
                      (push 'third rv)))
                  rv)
                (third first))

(evaluator-test (simple-unwind-protect-2)
                (let (rv)
                  (unwind-protect
                      (progn
                        (push 'first rv)
                        (push 'second rv))
                    (push 'third rv))
                  rv)
                (third second first))
                  
(evaluator-test (unwind-protect-cleanup-not-protected)
                 (let (rv)
                   (block obb
                     (unwind-protect
                         (progn
                           (push 'body rv)
                           (return-from obb)
                           (push 'cannot-happen rv))
                       
                       (push 'cleanup rv)
                       (return-from obb)))
                   rv)
                 (cleanup body))

(evaluator-test (unwind-protect-exception-discarded-on-nonlocal-exit)
                (catch 'tag
                  (block cica
                    (unwind-protect
                        (throw 'tag 'bad)
                      (return-from cica 'good))))
                good)

(evaluator-test (unwind-protect-result-discarded)
                (catch 'tag
                  (block cica
                    (unwind-protect
                        (throw 'tag 'good)
                      'bad)))
                good)

(evaluator-test (simple-tagbody-1)
                (let (rv)
                  (tagbody
                   (go a)
                   (push 'bad rv)
                   a
                   )
                  rv)
                nil)
                 
(evaluator-test (tagbody-nested-resolution-1)
                (let (rv)
                  (tagbody
                   a (tagbody
                    (go b)
                    (push 'cica rv)
                    b (push 'kutya rv))
                   b (push 'obb rv) go end
                   end)
                  rv)
                (obb kutya))


(evaluator-test (tagbody-nested-resolution-2)
                (let (rv)
                  (tagbody
                   a (tagbody
                    (go b)
                    (push 'cica rv)
                    c (push 'kutya rv))
                   b (push 'obb rv) go end
                   end)
                  rv)
                (obb))

(evaluator-test (tagbody-returns-over-non-interpreted-code)
                (let ((rv 'original))
                  (tagbody
                   a (funcall (lambda () (go b)))
                     (setq rv 'bad)
                     (go c)
                   b (setq rv 'good)
                   c)
                  rv)
                good)
                     
                 
(evaluator-test (simple-the-1)
                (the fixnum 3)
                3)

(evaluator-test (application-without-args)
                (flet ((f () 42))
                  (f))
                42)

(evaluator-test (special-variable-declaration-1)
                (flet ((return-a ()
                         (locally (declare (special a))
                           a)))
                  (let ((a 4))
                    (declare (special a))
                    (return-a)))
                4)

(evaluator-test (special-variable-declaration-2)
                (let ((a 'outer))
                  (declare (special a))
                  (flet ((return-a-returner ()
                           (let ((a 'inner))
                             (declare (special a))
                             (lambda () a))))
                    (let ((a-returner (return-a-returner)))
                      (funcall a-returner))))
                outer)

(evaluator-test (special-variable-declaration-3)
                (let ((a 'outer))
                  (flet ((return-a-returner ()
                           (let ((a 'inner))
                             (lambda () a))))
                    (let ((a-returner (return-a-returner)))
                      (funcall a-returner))))
                inner)

(evaluator-test (special-variable-declaration-4)
                (let ((a 'outer))
                  (declare (special a))
                  (flet ((return-a-returner ()
                           (let ((a 'inner))
                             (declare (special a))
                             (lambda ()
                               (let ((a 'lambda))
                                 (declare (special a))
                                 a)
                               ))))
                    (let ((a-returner (return-a-returner)))
                      (funcall a-returner))))
                lambda)

(evaluator-test (special-variable-declaration-5)
                (let ((a 'outer))
                  (declare (special a))
                  (funcall (lambda ()
                             a)))
                outer)

(evaluator-test (special-variable-declaration-6)
                (let* ((a 'outer))
                  (declare (special a))
                  (funcall (lambda ()
                             a)))
                outer)

(evaluator-test (special-variable-declaration-7)
                (let ((a 'good))
                  (declare (special a))
                  a)
                good)

(evaluator-test (lambda-binds-special-variables)
                (flet ((return-a ()
                         (declare (special a))
                         a))
                  (let ((a 'good))
                    (declare (special a))
                    (return-a)))
                good)

(test throw-throws-native-exception-1
  (catch 'tag
    (is (eq (hu.caleb:caleb '(progn
                                (throw 'tag 'good)
                                'bad))
            'good))))

(evaluator-test (simple-catch-1)
                (catch 'obb
                  (throw 'obb 'good)
                  'bad)
                good)

(evaluator-test (catch-right-catch-is-chosen)
                (catch 'outer
                  (catch 'middle
                    (catch 'inner
                      (throw 'middle 'bad-outer)
                      'bad-inner))
                  'good)
                good)

(evaluator-test (catch-throw-from-unwind-protect-overrides)
                (catch 'tag
                  (unwind-protect
                      (progn
                        (throw 'tag 'bad-not-overridden)
                        'bad-not-thrown)
                    (throw 'tag 'good)))
                good)

(evaluator-test (catch-can-be-thrown-through-noninterpreted-code)
                (let ((thrower (lambda () (throw 'obb 'good))))
                  (catch 'obb
                    (funcall thrower)
                    'bad))
                good)

(evaluator-test (catch-multiple-values-can-be-thrown-through-noninterpreted-code)
                (multiple-value-list (let ((thrower (lambda () (throw 'obb (values 1 2 3)))))
                                       (catch 'obb
                                         (funcall thrower)
                                         'bad)))
                (1 2 3))

(evaluator-test (catch-returns-nil-without-code)
                (catch 'alma)
                nil)

(evaluator-test (catch-multiple-values-can-be-thrown)
                (multiple-value-list (catch 'alma (throw 'alma (values 1 2 3))))
                (1 2 3))

(defun thrower ()
  (throw 'tag 'frog))

(evaluator-test (catch-catches-native-throw-1)
                (catch 'tag
                  (thrower)
                  'stork)
                frog)

(evaluator-test (complex-dotimes)
                (let (rv)
                  (dotimes (i 5)
                    (push i rv))
                  rv)
                (4 3 2 1 0))
                  
(evaluator-test (complex-loop-sum)
                (loop for i in '(1 2 3 4 5 6)
                      when (evenp i)
                      sum i)
                12)

(evaluator-test (complex-loop-premature-return)
                (let (rv)
                  (loop for i in '(1 2 3 4 5 6)
                        when (evenp i)
                        do (push i rv)
                        when (eql i 5)
                        return nil)
                  rv)
                (4 2))

(evaluator-test (complex-prog1-returns-one-value)
                (multiple-value-list (prog1
                                         (values 'good 'more 'even-more)
                                       'bad))
                (good))
(evaluator-test (free-function-can-be-called)
                (funcall #'list 1 2 3)
                (1 2 3))

(evaluator-test (multiple-value-call-simple-1)
                (length (multiple-value-call (lambda (&rest a) a) (values 1 2 3)))
                3)

(evaluator-test (multiple-value-prog1-1)
                (multiple-value-list (multiple-value-prog1 (values 1 2 3) 'bad))
                (1 2 3))

(evaluator-test (load-time-value-1)
                (load-time-value (+ 1 2))
                3)

(evaluator-test (progv-simple-1)
               (progv '(a b) '(1 2)
                 (list a b))
               (1 2))

(evaluator-test (progv-simple-2)
                (progv (append '(a) '(b)) (cons 3 (cons 4 nil))
                  (list a b))
                (3 4))

(evaluator-test (eval-when-executing)
                (let (rv)
                  (push (eval-when (:execute)
                          (push 'first rv)
                          'second)
                        rv)
                  rv)
                (second first))

(evaluator-test (eval-when-not-executing)
                (eval-when (:compile-toplevel)
                  'bad)
                nil)

(defvar *scrap-variable*)

(test can-set-global-variables
  (setq *scrap-variable* 'bad)
  (hu.caleb:caleb '(setq *scrap-variable* 'good))
  (is (eq *scrap-variable* 'good)))

(test unwind-protect-works-with-native-exceptions
  (setq *scrap-variable* 'bad)
  
  (catch 'tag
    (hu.caleb:caleb '(unwind-protect
                          (thrower)
                        (setq *scrap-variable* 'good))))
  (is (eq *scrap-variable* 'good)))

(test unwind-protect-with-throw-overrides-native-exception
  (setq *scrap-variable* 'bad-original)
  (setq *scrap-variable*
        (catch 'tag
          (catch 'good-tag
            (hu.caleb:caleb '(unwind-protect
                                  (thrower)
                                (throw 'good-tag 'good))))))
  (is (eq *scrap-variable* 'good)))

(evaluator-test (can-read-global-variables)
                (progn
                  (setq *scrap-variable* 'outer)
                  (let ((rv nil))
                    (flet ((foo () (push *scrap-variable* rv)))
                      (let ((*scrap-variable* 'inner))
                        (foo))
                      (foo))
                    rv))
                (outer inner))

(evaluator-test (lambda-list-can-bind-dynamically)
                 (let ((rv nil))
                   (setq *scrap-variable* 'original)
                   (labels
                       ((foo () (push *scrap-variable* rv))
                        (bar (*scrap-variable*) (push *scrap-variable* rv) (foo)))
                     (bar 'good))
                   rv)
                 (good good))

(defun return-special-a-b ()
  (declare (special a b))
  (list a b))

(evaluator-test (special-variables-passed-to-native)
                (let ((a 'good-1) (b 'good-2))
                  (declare (special a b))
                  (return-special-a-b))
                (good-1 good-2))

(defun call-lambda (l) (funcall l))

(evaluator-test (lexical-variables-bound-through-native-code)
                (let ((a 'bad))
                  (call-lambda (lambda () (setq a 'good)))
                  a)
                good)

(evaluator-test (return-form-works-through-native-code)
                (block main
                  (let ((returner (lambda () (return-from main 'good))))
                    (call-lambda returner)
                    'bad)
                  'bad)
                good)

(define-condition test-condition () ((value :initarg :value :accessor test-condition-value)))
(defun signaler () (signal (make-instance 'test-condition :value 'good)))
(defun return-good () (invoke-restart 'return-good))

(evaluator-test (simple-signals-1)
                (let ((rv 'bad))
                  (handler-case
                      (signaler)
                    (test-condition () (setq rv 'good)))
                  rv)
                good)

(evaluator-test (simple-signals-2)
                (handler-bind
                    ((test-condition (lambda (c) (invoke-restart 'return-good))))
                  (restart-case
                      (progn (signaler))
                    (return-good () 'good)))
                good)

(evaluator-test (simple-signals-3)
                (handler-bind
                    ((test-condition (lambda (c) (return-good))))
                  (restart-case
                      (progn (signaler))
                    (return-good () 'good)))
                good)

(evaluator-test (simple-signals-4)
                (handler-bind
                    ((test-condition (lambda (c) (use-value (test-condition-value c)))))
                  (restart-case
                      (progn (signaler))
                    (use-value (v) v)))
                good)

(evaluator-test (simple-signals-5)
                (handler-bind
                    ((test-condition (lambda (c) (use-value (test-condition-value c)))))
                  (restart-case
                      (progn (call-lambda (lambda () (signaler))))
                    (use-value (v) v)))
                good)