mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-23 13:01:42 -08:00
360 lines
12 KiB
Common Lisp
360 lines
12 KiB
Common Lisp
;;;; -*- 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)))
|
||
))
|