(in-package :serapeum.tests)

(def-suite static-let :in serapeum)
(in-suite static-let)

;;; We need to use EVAL* in order to make these tests pass when run consecutively
;;; because of the underlying LOAD-TIME-VALUE inside STATIC-LET.
(defmacro static-let-test (name &body body)
  `(test ,name
     (let ((serapeum/static-let::*flushable-bindings* (make-hash-table)))
       (eval* '(progn ,@body)))))

(static-let-test static-let
  (let ((x 0))
    (flet ((foo ()
             (static-let ((y (progn (incf x) 42)))
               y)))
      (is (= 0 x))
      (is (= 42 (foo)))
      (is (= 1 x))
      (is (= 42 (foo)))
      (is (= 1 x))
      (is (= 1 (handler-bind ((error #'continue))
                 (flush-all-static-binding-groups))))
      (is (= 1 x))
      (is (= 0 (handler-bind ((error #'continue))
                 (flush-all-static-binding-groups))))
      (is (= 42 (foo)))
      (is (= 2 x)))))

(static-let-test static-let-non-flushablep
  (let ((x 0))
    (flet ((foo ()
             (static-let ((y (progn (incf x) 42)
                             :flush nil))
               y)))
      (is (= 0 x))
      (is (= 42 (foo)))
      (is (= 1 x))
      (is (= 42 (foo)))
      (is (= 1 x))
      (is (= 0 (handler-bind ((error #'continue))
                 (flush-all-static-binding-groups))))
      (is (= 1 x))
      (is (= 42 (foo)))
      (is (= 1 x)))))

(static-let-test static-let-group
  (let ((x 0))
    (flet ((foo ()
             (static-let ((y (progn (incf x) 42) :in 'foo)
                          (q 42 :in 'bar))
               (declare (type integer q))
               (is (= 42 q))
               y)))
      (is (= 0 x))
      (is (= 42 (foo)))
      (is (= 1 x))
      (is (= 42 (foo)))
      (is (= 1 x))
      (is (= 1 (flush-static-binding-group 'foo :are-you-sure-p t)))
      (is (= 1 x))
      (is (= 42 (foo)))
      (is (= 2 x))
      (is (= 2 (handler-bind ((error #'continue))
                 (flush-all-static-binding-groups))))
      (is (= 0 (handler-bind ((error #'continue))
                 (flush-all-static-binding-groups))))
      (is (= 2 x))
      (is (= 42 (foo)))
      (is (= 3 x)))))

(static-let-test static-let-default-group
  (flet ((aux ()
           (static-let ((x (make-array 10 :initial-element 1)))
             (map-into x #'1+ x)
             (aref x 0))))
    (is (eql 2 (aux)))
    (is (eql 3 (aux)))
    (handler-bind ((error #'continue))
      (flush-static-binding-group (find-package :cl-user)))
    (is (eql 4 (aux)))
    (handler-bind ((error #'continue))
      (flush-static-binding-group (find-package :serapeum.tests)))
    (is (eql 2 (aux)))))

(static-let-test static-let-error
  (signals error
    (eval* `(static-let ((x 10)
                         (y x))
              (+ y x))))
  (signals static-binding-active-error
    (eval* `(static-let ((x 10 :in 'foo))
              (flush-static-binding-group 'foo :are-you-sure-p t)
              x)))
  (signals static-binding-active-error
    (eval* `(flet ((foo () (flush-static-binding-group 'foo :are-you-sure-p t)))
              (static-let ((x 10 :in 'foo))
                (foo)
                x)))))

(static-let-test static-let*
  (let ((x 0))
    (flet ((foo ()
             (static-let* ((y (progn (incf x) 21))
                           (z (progn (setf x (* 10 x)) y)))
               (+ y z))))
      (is (= 0 x))
      (is (= 42 (foo)))
      (is (= 10 x))
      (is (= 42 (foo)))
      (is (= 10 x))
      (is (= 2 (handler-bind ((error #'continue))
                 (flush-all-static-binding-groups))))
      (is (= 0 (handler-bind ((error #'continue))
                 (flush-all-static-binding-groups))))
      (is (= 10 x))
      (is (= 42 (foo)))
      (is (= 110 x)))))

(static-let-test static-let*-shadowing
  (static-let ((x 42))
    (static-let ((x x))
      (is (= 42 x)))))

(static-let-test static-let*-non-flushablep
  (let ((x 0))
    (flet ((foo ()
             (static-let* ((y (progn (incf x) 21))
                           (z (progn (setf x (* 10 x)) y)
                              :flush nil))
               (+ y z))))
      (is (= 0 x))
      (is (= 42 (foo)))
      (is (= 10 x))
      (is (= 42 (foo)))
      (is (= 10 x))
      (is (= 1 (handler-bind ((error #'continue))
                 (flush-all-static-binding-groups))))
      (is (= 0 (handler-bind ((error #'continue))
                 (flush-all-static-binding-groups))))
      (is (= 10 x))
      (is (= 42 (foo)))
      (is (= 11 x)))))

(static-let-test static-let*-group
  (let ((x 0))
    (flet ((foo ()
             (static-let* ((y (progn (incf x) 21) :in 'foo)
                           (z (progn (setf x (* 10 x)) y) :in 'foo)
                           (q 42 :in 'bar))
               (declare (type integer q))
               (is (= 42 q))
               (+ y z))))
      (is (= 0 x))
      (is (= 42 (foo)))
      (is (= 10 x))
      (is (= 42 (foo)))
      (is (= 10 x))
      (is (= 2 (flush-static-binding-group 'foo :are-you-sure-p t)))
      (is (= 10 x))
      (is (= 42 (foo)))
      (is (= 110 x))
      (is (= 3 (handler-bind ((error #'continue))
                 (flush-all-static-binding-groups))))
      (is (= 0 (handler-bind ((error #'continue))
                 (flush-all-static-binding-groups))))
      (is (= 110 x))
      (is (= 42 (foo)))
      (is (= 1110 x)))))

(static-let-test static-let-not-dynamic
  (signals error
    (eval* `(static-let ((x 1))
              (declare (dynamic-extent x))
              (1+ x))))
  (signals error
    (eval* `(static-let* ((x 1)
                          (y 2))
              (declare (dynamic-extent y))
              (1+ x)))))

(static-let-test static-let-setf
  (finishes
    (eval* `(static-let ((x 1))
              (setf x 2))))
  (signals error
    (eval* `(static-let ((x 1 :read-only t))
              (setf x 2)))))
