;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*-
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:

;;;; Contains: Various regression tests for ECL

(in-package :cl-test)

(suite 'mixed)


;;; (EXT:PACKAGE-LOCK) returned the wrong value.
;;; Fixed in 77a267c7e42860affac8eddfcddb8e81fccd44e5

(test mix.0001.package-lock
  ;; Don't know the first state
  (ext:package-lock "CL-USER" nil)
  (is-false (ext:package-lock "CL-USER" t))
  (is-true  (ext:package-lock "CL-USER" nil))
  (is-false (ext:package-lock "CL-USER" nil)))


;; Bugs from sourceforge

(test mix.0002.mvb-not-evaled
  (is (eq :ok (block nil
                (tagbody
                   (return (multiple-value-bind ()
                               (go :fail) :bad))
                 :fail
                   (return :ok))))))



(ext:with-clean-symbols (foo)
  (declaim (ftype (function (cons) t)   foo)
           (ftype (function (t cons) t) (setf foo)))

  (defun foo (cons)
    (first cons))

  (defun (setf foo) (value cons)
    (setf (first cons) value))

  (test mix.0003.declaim-type
    (let ((*bar* (cons 'x 'y)))
      (is (eq (foo *bar*) 'x))
      (is (eq (setf (foo *bar*) 'z) 'z) "signals on error:
;; Z is not of type CONS.
;;   [Condition of type TYPE-ERROR]"))))



(test mix.0004.style-warning-argument-order
  (let ((warning nil))
    (is (eq :ok
            (handler-bind
                ((style-warning
                  (lambda (c)
                    (format t "got style-warning: ~s~%" c)
                    (setf warning c))))
              (block nil
                (tagbody
                   (return (multiple-value-bind () (go :fail) :bad))
                 :fail
                   (return :ok))))))
    (is-false warning)))

(test mix.0005.write-hash-readable
  (is (= (hash-table-count
          (read-from-string
           (write-to-string (make-hash-table)
                            :readably t))))))

(test mix.0006.find-package
  (is
   (let ((string ":cl-user"))
     (find-package
      (let ((*package* (find-package :cl)))
        (read-from-string string)))))
  (is
   (let ((string ":cl-user"))
     (let ((*package* (find-package :cl)))
       (find-package
        (read-from-string string))))))



;;; Date: 2016-05-21 (Masataro Asai)
;;; Description:
;;;
;;;     RESTART-CASE investigates the body in an incorrect manner,
;;;     then remove the arguments to SIGNAL, which cause the slots of
;;;     the conditions to be not set properly.
;;;
;;; Bug: https://gitlab.com/embeddable-common-lisp/ecl/issues/247
;;;
(ext:with-clean-symbols (x)
  (define-condition x () ((y :initarg :y)))
  (test mix.0007.restart-case-body
    (is-false (handler-bind ((x (lambda (c) (slot-value c 'y))))
                (restart-case
                    (signal 'x :y 1))))))


;;; Date: 2016-04-21 (Juraj)
;;; Fixed: 2016-06-21 (Daniel Kochmański)
;;; Description:
;;;
;;; Trace did not respect *TRACE-OUTPUT*.
;;;
;;; Bug: https://gitlab.com/embeddable-common-lisp/ecl/issues/236
;;;
(ext:with-clean-symbols (fact)
  (defun fact (n) (if (zerop n) :boom (fact (1- n))))
  (test mix.0008.trace-output
    (is
     (not (zerop
           (length
            (with-output-to-string (*trace-output*)
              (trace fact)
              (fact 3)
              (untrace fact)
              *trace-output*)))))))


;;;; Author:   Daniel Kochmański
;;;; Created:  2015-09-21
;;;; Contains: Random state tests
(test mix.0009.random-states
  (is (numberp (random 18)) "Can't generate trivial random number")
  (is (numberp (random 18 #$1))
      "Can't generate a number from read (#$1) random state")
  (is (numberp (random 18 (make-random-state)))
      "Can't generate a number from a new random state")
  (is (numberp (random 18 (make-random-state #$1)))
      "Can't generate a number from a new random state from reader")
  (is (= (random 18 #$1)
         (random 18 #$1)
         (random 18 #$1))
      "The same seed produces different results")
  (is (let ((*print-readably* t)
            (rs (make-random-state #$1)))
        (equalp
         (prin1-to-string #$1)
         (prin1-to-string rs)))
      "The same seed gives different random states")
  (is (let* ((*print-readably* t)
             (rs (make-random-state #$1))
             (rs-read (read-from-string
                       (prin1-to-string rs))))
        (equalp
         (prin1-to-string rs-read)
         (prin1-to-string rs)))
      "Can't read back a random state"))


;;; Date: 2016-08-04 (jd)
;;; Fixed: 2016-08-04 (jd)
;;; Description:
;;;
;;; file-stream-fd caused internal error if fed with non-file ANSI
;;; stream
;;;
;;; Bug: https://gitlab.com/embeddable-common-lisp/ecl/issues/271
;;;
(test mix.0010.file-stream-fd
  ;; We check the second one only if first test passes. Second test
  ;; caused internal error of ECL and crashed the process preventing
  ;; further tests, so we perform it only on versions after the fix.
  (if (signals simple-type-error (ext:file-stream-fd ""))
      (signals simple-type-error (ext:file-stream-fd
                                  (make-string-output-stream)))
      (fail (ext:file-stream-fd (make-string-output-stream))
            "Not-file stream would cause internal error on this ECL (skipped)")))


;;; Date: 2016-12-20
;;; Reported by: Kris Katterjohn
;;; Fixed: Daniel Kochmański
;;; Description:
;;;
;;;   atan signalled `division-by-zero' exception when the second
;;;   argument was signed zero. Also inconsistent behavior on invalid
;;;   operation (atan 0.0 0.0).
;;;
;;; Bug: https://gitlab.com/embeddable-common-lisp/ecl/issues/329
(test mix.0012.atan-signed-zero
  (finishes (atan 1.0 -0.0)))


;;; Date: 2016-12-21
;;; Description:
;;;
;;;   `sleep' sues `ECL_WITHOUT_FPE_BEGIN' which didn't restore fpe
;;;   correctly.
;;;
;;; Bug: https://gitlab.com/embeddable-common-lisp/ecl/issues/317
(test mix.0013.sleep-without-fpe
  (sleep 0.1)
  (let ((a 1.0)
        (b 0.0))
    ;; nb: normally operation signals `division-by-zero', but OSX
    ;; signals `floating-point-overflow'. It's OK I suppose.
    (signals arithmetic-error (/ a b))))


;;; Date: 2017-01-20
;;; Description:
;;;
;;;   `dolist' macroexpansion yields result which doesn't have a
;;;   correct scope.
;;;
;;; Bug: https://gitlab.com/embeddable-common-lisp/ecl/issues/348
(test mix.0014.dolist
  (is-false
   (nth-value 1
     (compile nil
              (lambda ()
                (dolist (s '("foo" "bar" "baz") s)
                  (declare (type string s))
                  (check-type s string)
                  (format nil "~s" s))))))
  (finishes (eval '(dolist (e '(1 2 3 4) e)
                    (print e)
                    (go :next)
                    (print 'skip)
                    :next))))


;;; Date: 2017-07-02
;;; Description:
;;;
;;;   Function `ecl_new_binding_index' called `si_set_finalizer',
;;;   which resetted `env->nvalues' leading to invalid binding in mvb
;;;   during the first function run.
;;;
;;; Bug: https://gitlab.com/embeddable-common-lisp/ecl/issues/233
(test mix.0015.mvb
  (with-compiler ("aux-cl-0003.lsp" :load t)
    `(progn
       (defvar mix.0015.v1 'booya)
       (defun mix.0015.fun ()
         (let ((share_t))
           (multiple-value-bind (mix.0015.v1 woops)
               (case share_t
                 ((nil)
                  (values 1 2)))
             woops)))))
  (ignore-errors
    (delete-file "aux-cl-0003.lsp")
    (delete-file "aux-cl-0003.fas")
    (delete-file "aux-cl-0003.fasc"))
  (is-eql 2 (mix.0015.fun)))

;;; Date: 2018-05-08
;;; Description:
;;;
;;;   Better handling of fifos. This test will most likely fail on Windows (this
;;;   is not confirmed yet) because it does not support non-blocking
;;;   operations.
;;;
;;;   When we figure out what would be correct semantics for Windows this test
;;;   should be disabled for that platform and a separate test case ought to be
;;;   created. It is possible that it won't fail (because cygwin will handle it
;;;   gracefully and/or WinAPI does not support file-pipes).
;;;
;;; Bug: https://gitlab.com/embeddable-common-lisp/ecl/issues/242
(test mix.0016.fifo-tests
  (ext:run-program "mkfifo" '("my-fifo") :output t)
  ;; 1) reader (first) and writer (inside)
  (with-open-file (stream "my-fifo")
    (is (null (file-length stream)))
    (is (null (listen stream)))
    (is (eql :foo (read-line stream nil :foo)))
    (is (eql :fifo (ext:file-kind stream nil)))
    (with-open-file (stream2 "my-fifo" :direction :output)
      ;; Even for output it should not block on Linux.
      (finishes (write-line "foobar" stream2)))
    (is (equal "foobar" (read-line stream nil :foo))))
  ;; 2) writer (first) and reader (second)
  (with-open-file (stream "my-fifo" :direction :output)
    (finishes (write-line "foobar" stream)))
  (with-open-file (stream "my-fifo" :direction :input)
    ;; there is nobody on the other side, data is lost
    (is (eql :foo (read-line stream nil :foo))))
  ;; 3) writer (first) and reader (inside)
  (with-open-file (stream "my-fifo" :direction :output)
    (finishes (write-line "foobar" stream))
    (with-open-file (stream2 "my-fifo" :direction :input)
      ;; Even for output it should not block on Linux.
      (is (equal "foobar" (read-line stream2 nil :foo)))))
  ;; clean up
  (ext:run-program "rm" '("-rf" "my-fifo") :output t))


;;; Date: 2018-12-02
;;; Description:
;;;
;;;   Serialization/Deserialization tests
#+externalizable
(test mix.0017.serialization
  (let* ((vector (make-array 4 :element-type 'ext:byte16 :initial-contents #(1 2 3 4)))
         (to-be-serialized
          (vector nil  ; 1: empty list
                  '(1 2)  ; 2: non-empty list
                  #\q  ; 3: character
                  42  ; 4: fixnum
                  (+ 10 most-positive-fixnum)  ; 5: bignum
                  2/3  ; 6: ratio
                  12.3f4  ; 7-9: floats
                  13.2d4
                  #+long-float 14.2l3
                  #C(4 7)  ; 10: complex
                  #.(find-package "COMMON-LISP-USER")  ; 11: package
                  'q  ; 12: symbol
                  ;; 13: hash-table
                  (let ((ht (make-hash-table)))
                    (setf (gethash :foo ht) :abc)
                    (setf (gethash :bar ht) :def)
                    ht)
                  ;; 14: array
                  (let ((a (make-array '(2 2) :initial-element 0)))
                    (setf (aref a 0 0) 'q)
                    (setf (aref a 0 1) 1/5)
                    a)
                  vector  ; 15: non-displaced vector
                  ;; 16: displaced vector
                  (make-array 3 :element-type 'ext:byte16
                              :displaced-to vector
                              :displaced-index-offset 1)
                  "a∩b∈c"  ; 17: string
                  (make-string 3 :initial-element #\q :element-type 'base-char)  ; 18: base-string
                  (make-array 6 :element-type 'bit :initial-contents #(0 1 0 1 1 0))  ; 19: bit-vector
                  ;; stream: not externalizable?
                  ;; 20: random-state
                  (let ((r (make-random-state)))
                    (random 10 r)
                    r)
                  ;; readtable: not externalizable
                  #P"/foo/bar/whatever.gif"  ; 21: pathname
                  ;; TODO: other objects
                  ))
         (deserialized (si::deserialize (si::serialize to-be-serialized))))
    (is-true (equalp (subseq to-be-serialized 0 12)
                     (subseq deserialized 0 12)))
    (is-true (loop for key being the hash-keys of (elt to-be-serialized 12)
                if (not (eq (gethash key (elt to-be-serialized 12))
                            (gethash key (elt deserialized 12))))
                return nil
                finally (return t)))
    (is-true (equalp (subseq to-be-serialized 13 16)
                     (subseq deserialized 13 16)))
    (is-true (and (equalp (multiple-value-list (array-displacement (elt to-be-serialized 15)))
                          (multiple-value-list (array-displacement (elt to-be-serialized 15))))))
    (is-true (equal (elt to-be-serialized 16) (elt deserialized 16)))
    (is-true (equal (elt to-be-serialized 17) (elt deserialized 17)))
    (is-true (equal (elt to-be-serialized 18) (elt deserialized 18)))
    (is-true (equalp (elt to-be-serialized 19) (elt deserialized 19)))
    (is-true (equal (elt to-be-serialized 20) (elt deserialized 20)))
    ))
