mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-04-27 03:40:31 -07:00
Code Issues Projects Releases Packages Wiki Activity

Merge branch 'improve-testing' into develop

Browse source
This commit is contained in:
Daniel Kochmański 2016-08-10 13:50:52 +02:00
commit c196d0f0e7
71 changed files with 3313 additions and 3949 deletions
Download patch file Download diff file Expand all files Collapse all files

12
CHANGELOG
View file

@ -23,7 +23,7 @@
have a C compiler accessible to ECL, you may use
(ext:install-c-compiler) to switch back to the Lisp-to-C compiler.
- Before issuing make check on the package package developer has to
- Before issuing =make check= on the package package developer has to
install ECL on the preferred destination (specified with "--prefix"
parameter given to configure script).
@ -38,15 +38,19 @@ Initializing a random state with an appropriate array (element type and
arity) is now possible only with the #$ reader macro.
** Enhancements
- Refactored ECL internal tests framework
Tests in =src/tests= are now asdf-loadable (with =load-source-op=) and
divided into test suites. =make check= target runs all regression and
feature tests which aren't supposed to fail.
- Removed 15000 lines of obsolete code
Files not included in the buildsystem but lingering in the codebase or
options failing to build. All info is added in the new documentation in the
section "Removed interfaces".
- Improved man page and help output.
Man page now contains up-to-date list of flags, as well
as explanation of flag's behavior.
Man page now contains up-to-date list of flags, as well as explanation of
flag's behavior.
- Indented C/C++ code to follow emacs's gnu C style
This is a first step towards coding standards in the

2
src/clos/print.lsp
View file

@ -150,7 +150,7 @@ printer and we should rather use MAKE-LOAD-FORM."
(defun no-make-load-form (object)
(declare (si::c-local))
(error "No adequate specialization of MAKE-LOAD-FORM for an object of type"
(error "No adequate specialization of MAKE-LOAD-FORM for an object type ~A"
(type-of object)))
(defmethod make-load-form ((class class) &optional environment)

105
src/tests/1am.lisp Normal file
View file

@ -0,0 +1,105 @@
;;; Copyright (c) 2014 James M. Lawrence
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(defpackage #:1am-ecl
(:use #:cl)
(:export #:test #:is #:signals #:run #:*tests*))
(in-package #:1am-ecl)
(defvar *tests* nil "A list of tests; the default argument to `run'.")
(defvar *pass-count* nil)
(defvar *running* nil)
(defvar *failed-random-state* nil)
(defun %shuffle (vector)
(loop for i downfrom (- (length vector) 1) to 1
do (rotatef (aref vector i) (aref vector (random (1+ i)))))
vector)
(defun shuffle (sequence)
(%shuffle (map 'vector #'identity sequence)))
(defun call-with-random-state (fn)
(let ((*random-state* (or *failed-random-state*
(load-time-value (make-random-state t)))))
(setf *failed-random-state* (make-random-state nil))
(multiple-value-prog1 (funcall fn)
(setf *failed-random-state* nil))))
(defun report (test-count pass-count)
(format t "~&Success: ~s test~:p, ~s check~:p.~%" test-count pass-count))
(defun %run (fn test-count)
(let ((*pass-count* 0))
(multiple-value-prog1 (call-with-random-state fn)
(report test-count *pass-count*))))
(defun run (&optional (tests *tests*))
"Run each test in the sequence `tests'. Default is `*tests*'."
(let ((*running* t))
(%run (lambda () (map nil #'funcall (shuffle tests)))
(length tests)))
(values))
(defun call-test (name fn)
(format t "~&~s" name)
(finish-output)
(if *running*
(funcall fn)
(%run fn 1)))
(defmacro test (name &body body)
"Define a test function and add it to `*tests*'."
`(progn
(defun ,name ()
(call-test ',name (lambda () ,@body)))
(pushnew ',name *tests*)
',name))
(defun passed ()
(write-char #\.)
;; Checks done outside a test run are not tallied.
(when *pass-count*
(incf *pass-count*))
(values))
(defmacro is (form)
"Assert that `form' evaluates to non-nil."
`(progn
(assert ,form)
(passed)))
(defun %signals (expected fn)
(flet ((handler (condition)
(cond ((typep condition expected)
(passed)
(return-from %signals (values)))
(t (error "Expected to signal ~s, but got ~s:~%~a"
expected (type-of condition) condition)))))
(handler-bind ((condition #'handler))
(funcall fn)))
(error "Expected to signal ~s, but got nothing." expected))
(defmacro signals (condition &body body)
"Assert that `body' signals a condition of type `condition'."
`(%signals ',condition (lambda () ,@body)))

211
src/tests/2am.lisp Normal file
View file

@ -0,0 +1,211 @@
;;; Copyright (c) 2014 James M. Lawrence
;;; Copyright (c) 2016 Daniel Kochmański
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
#| to avoid conflict with the library name package 2am-ecl |#
(defpackage #:2am-ecl
(:use #:cl)
(:export #:test #:is #:signals #:finishes #:run #:suite))
(in-package #:2am-ecl)
(defvar *tests* nil "A name of the default tests suite.")
(defvar *suites* (make-hash-table) "A collection of test suites.")
(defvar *hierarchy* (make-hash-table) "A hierarchy of test suites.")
(defvar *failures* nil)
(defvar *crashes* nil)
(defvar *test-name* nil)
(defvar *test-count* nil)
(defvar *pass-count* nil)
(defvar *fail-count* nil)
(defvar *running* nil)
(define-condition test-failure (simple-condition)
((test-name :initarg :name
:accessor test-name)))
(defun suite (&optional (name *tests* name-p) (sub nil sub-p))
"Sets the current suite to the `name'."
(assert (symbolp name))
(assert (typep sub 'sequence))
(when name-p
(setf *tests* name))
(when sub-p
(setf (gethash *tests* *hierarchy*) sub))
*tests*)
(defsetf suite (name) (tests suites)
"Resets the suite to contain the provided tests and suites"
`(progn
(assert (typep ,tests 'sequence))
(assert (typep ,suites 'sequence))
(setf (gethash ,name *suites*) ,tests
(gethash ,name *hierarchy*) ,suites)
tests))
(defun %shuffle (vector)
(loop for i downfrom (- (length vector) 1) to 1
do (rotatef (aref vector i) (aref vector (random (1+ i)))))
vector)
(defun shuffle (sequence)
(%shuffle (map 'vector #'identity sequence)))
(defun report (test-count pass-count fail-count crashes)
(let ((num-check (+ pass-count fail-count)))
(if *running*
(format t "~&Did ~s test~:p (~s crashed), ~s check~:p.~%" test-count crashes num-check)
(format t "~&Test ~s: ~s check~:p.~%" *test-name* num-check))
(unless (zerop num-check)
(let ((passed% (round (* 100 (/ pass-count num-check))))
(failed% (round (* 100 (/ fail-count num-check)))))
(format t " Pass: ~s (~2D%)~%" pass-count passed%)
(format t " Fail: ~s (~2D%)~%" fail-count failed%))))
(unless (= fail-count crashes 0)
(format t "~%Failure details:~%")
(format t "--------------------------------~%")
(maphash (lambda (test fails)
(format t " ~A:~%" test)
(dolist (fail (reverse fails))
(if (typep fail 'test-failure)
(format t " FAIL: ")
(format t " CRASH [~A]: " (type-of fail)))
(format t "~A~%" fail))
(format t "~&--------------------------------~%"))
*failures*)))
(defun %run (fn)
(let ((*test-count* 0)
(*pass-count* 0)
(*fail-count* 0)
(*failures* (make-hash-table))
(*crashes* 0))
(multiple-value-prog1 (funcall fn)
(report *test-count* *pass-count* *fail-count* *crashes*))))
(defun %run-suite (name)
(let ((visited nil)
(functions nil))
(labels ((traverse (name)
(unless (member name visited)
(push name visited)
(push (lambda ()
(format t "~&--- Running test suite ~s~%" name)
(map nil #'funcall (shuffle
(gethash name *suites*))))
functions)
(map nil #'traverse (shuffle
(gethash name *hierarchy*))))))
(traverse name))
(nreverse functions)))
(defun run (&optional (tests (gethash nil *suites*)))
"Run each test in the sequence `tests'. Default is `*tests*'."
(let ((*running* t))
(etypecase tests
(symbol
(%run (lambda ()
(map nil #'funcall (%run-suite tests)))))
(list
(%run (lambda ()
(map nil #'funcall (shuffle tests)))))))
(values))
(defun call-test (fn)
(format t "~&Running test ~s " *test-name*)
(finish-output)
(if *running*
(handler-case
(progn (incf *test-count*)
(funcall fn))
(serious-condition (c)
(write-char #\X)
(incf *crashes*)
(push c (gethash *test-name* *failures*))))
(%run fn))
(values))
(defmacro test (name &body body)
"Define a test function and add it to `*tests*'."
`(progn
(defun ,name ()
(let ((*test-name* ',name))
(call-test (lambda () ,@body))))
(pushnew ',name (gethash *tests* *suites*))
',name))
(defun passed ()
(write-char #\.)
(when *pass-count*
(incf *pass-count*))
T)
(defun failed (c)
(write-char #\f)
(when *fail-count*
(incf *fail-count*))
(when *failures*
(push c (gethash *test-name* *failures*)))
NIL)
(defmacro is (form &rest args
&aux
(fmt-ctrl (format nil "~s~@[~%~A~]" form (car args)))
(fmt-args (cdr args)))
"Assert that `form' evaluates to non-nil."
`(if ,form
(passed)
(failed (make-condition 'test-failure
:name *test-name*
:format-control ,fmt-ctrl
:format-arguments (list ,@fmt-args)))))
(defun %signals (expected fn)
(flet ((handler (condition)
(cond ((typep condition expected)
(return-from %signals (passed)))
(t
(return-from %signals
(failed (make-condition 'test-failure
:name *test-name*
:format-control "Expected to signal ~s, but got ~s:~%~a"
:format-arguments (list expected (type-of condition) condition))))))))
(handler-bind ((condition #'handler))
(funcall fn)))
(failed (make-condition 'test-failure
:name *test-name*
:format-control "Expected to signal ~s, but got nothing"
:format-arguments `(,expected))))
(defmacro signals (condition &body body)
"Assert that `body' signals a condition of type `condition'."
`(%signals ',condition (lambda () ,@body)))
(defmacro finishes (form)
`(handler-case (progn
,form
(passed))
(serious-condition (c)
(failed (make-condition 'test-failure
:name *test-name*
:format-control "Expected to finish, but got ~s"
:format-arguments (list (type-of c)))))))

41
src/tests/Makefile.in
View file

@ -3,40 +3,15 @@
ECL=@prefix@/@bindir@/ecl@EXEEXT@
all: show-fails
.PHONY: all
.PHONY: do-regressions cleanup clean-sources update
all: check
BUGS_FILES := $(shell find ../../src/tests/regressions/ -type f)
check: config.lsp
$(ECL) -norc -load config.lsp \
-eval '(ecl-tests::run-tests)' \
-eval '(ext:quit)' \
2>&1 | tee check.log
regressions.log: config.lsp
$(MAKE) do-regressions
do-regressions: regressions config.lsp
$(ECL) -norc -load config.lsp -eval '(ecl-tests::run-regressions-tests)' -eval '(ext:quit)' 2>&1 | tee regressions.log
show-fails: regressions.log
tail -n 16 regressions.log
#
# Create directories
#
regressions: config.lsp $(BUGS_FILES)
$(ECL) -norc -load config.lsp -eval '(ecl-tests::ensure-regressions)' -eval '(ext:quit)' < /dev/null
#
# Cleanup
#
clean:
rm -rf regressions.log
clean-sources:
test -f config.lsp.in || rm -rf bugs
rm -rf regressions
distclean: clean-sources clean
rm -rf cache
update: clean-sources
$(MAKE) regressions
rm -rf regressions.log cache

0
src/tests/regressions/eformat-tests/hebrew_latin8_cr.txt → src/tests/auxiliary/eformat-tests/hebrew_latin8_cr.txt
View file

0
src/tests/regressions/eformat-tests/hebrew_latin8_crlf.txt → src/tests/auxiliary/eformat-tests/hebrew_latin8_crlf.txt
View file

0
src/tests/regressions/eformat-tests/hebrew_latin8_lf.txt → src/tests/auxiliary/eformat-tests/hebrew_latin8_lf.txt
View file

0
src/tests/regressions/eformat-tests/hebrew_utf8_cr.txt → src/tests/auxiliary/eformat-tests/hebrew_utf8_cr.txt
View file

0
src/tests/regressions/eformat-tests/hebrew_utf8_crlf.txt → src/tests/auxiliary/eformat-tests/hebrew_utf8_crlf.txt
View file

0
src/tests/regressions/eformat-tests/hebrew_utf8_lf.txt → src/tests/auxiliary/eformat-tests/hebrew_utf8_lf.txt
View file

0
src/tests/regressions/eformat-tests/kafka_cp1252_cr.txt → src/tests/auxiliary/eformat-tests/kafka_cp1252_cr.txt
View file

0
src/tests/regressions/eformat-tests/kafka_cp1252_crlf.txt → src/tests/auxiliary/eformat-tests/kafka_cp1252_crlf.txt
View file

0
src/tests/regressions/eformat-tests/kafka_cp1252_lf.txt → src/tests/auxiliary/eformat-tests/kafka_cp1252_lf.txt
View file

0
src/tests/regressions/eformat-tests/kafka_latin1_cr.txt → src/tests/auxiliary/eformat-tests/kafka_latin1_cr.txt
View file

0
src/tests/regressions/eformat-tests/kafka_latin1_crlf.txt → src/tests/auxiliary/eformat-tests/kafka_latin1_crlf.txt
View file

0
src/tests/regressions/eformat-tests/kafka_latin1_lf.txt → src/tests/auxiliary/eformat-tests/kafka_latin1_lf.txt
View file

0
src/tests/regressions/eformat-tests/kafka_utf8_cr.txt → src/tests/auxiliary/eformat-tests/kafka_utf8_cr.txt
View file

0
src/tests/regressions/eformat-tests/kafka_utf8_crlf.txt → src/tests/auxiliary/eformat-tests/kafka_utf8_crlf.txt
View file

0
src/tests/regressions/eformat-tests/kafka_utf8_lf.txt → src/tests/auxiliary/eformat-tests/kafka_utf8_lf.txt
View file

0
src/tests/regressions/eformat-tests/russian_koi8r_cr.txt → src/tests/auxiliary/eformat-tests/russian_koi8r_cr.txt
View file

0
src/tests/regressions/eformat-tests/russian_koi8r_crlf.txt → src/tests/auxiliary/eformat-tests/russian_koi8r_crlf.txt
View file

0
src/tests/regressions/eformat-tests/russian_koi8r_lf.txt → src/tests/auxiliary/eformat-tests/russian_koi8r_lf.txt
View file

0
src/tests/regressions/eformat-tests/russian_utf8_cr.txt → src/tests/auxiliary/eformat-tests/russian_utf8_cr.txt
View file

0
src/tests/regressions/eformat-tests/russian_utf8_crlf.txt → src/tests/auxiliary/eformat-tests/russian_utf8_crlf.txt
View file

0
src/tests/regressions/eformat-tests/russian_utf8_lf.txt → src/tests/auxiliary/eformat-tests/russian_utf8_lf.txt
View file

0
src/tests/regressions/eformat-tests/tilton_ascii_cr.txt → src/tests/auxiliary/eformat-tests/tilton_ascii_cr.txt
View file

0
src/tests/regressions/eformat-tests/tilton_ascii_crlf.txt → src/tests/auxiliary/eformat-tests/tilton_ascii_crlf.txt
View file

0
src/tests/regressions/eformat-tests/tilton_ascii_lf.txt → src/tests/auxiliary/eformat-tests/tilton_ascii_lf.txt
View file

0
src/tests/regressions/eformat-tests/tilton_utf8_cr.txt → src/tests/auxiliary/eformat-tests/tilton_utf8_cr.txt
View file

0
src/tests/regressions/eformat-tests/tilton_utf8_crlf.txt → src/tests/auxiliary/eformat-tests/tilton_utf8_crlf.txt
View file

0
src/tests/regressions/eformat-tests/tilton_utf8_lf.txt → src/tests/auxiliary/eformat-tests/tilton_utf8_lf.txt
View file

0
src/tests/regressions/eformat-tests/unicode_demo_ucs2_cr_be.txt → src/tests/auxiliary/eformat-tests/unicode_demo_ucs2_cr_be.txt
View file

0
src/tests/regressions/eformat-tests/unicode_demo_ucs2_cr_le.txt → src/tests/auxiliary/eformat-tests/unicode_demo_ucs2_cr_le.txt
View file

0
src/tests/regressions/eformat-tests/unicode_demo_ucs2_crlf_be.txt → src/tests/auxiliary/eformat-tests/unicode_demo_ucs2_crlf_be.txt
View file

0
src/tests/regressions/eformat-tests/unicode_demo_ucs2_crlf_le.txt → src/tests/auxiliary/eformat-tests/unicode_demo_ucs2_crlf_le.txt
View file

0
src/tests/regressions/eformat-tests/unicode_demo_ucs2_lf_be.txt → src/tests/auxiliary/eformat-tests/unicode_demo_ucs2_lf_be.txt
View file

0
src/tests/regressions/eformat-tests/unicode_demo_ucs2_lf_le.txt → src/tests/auxiliary/eformat-tests/unicode_demo_ucs2_lf_le.txt
View file

0
src/tests/regressions/eformat-tests/unicode_demo_ucs4_cr_be.txt → src/tests/auxiliary/eformat-tests/unicode_demo_ucs4_cr_be.txt
View file

0
src/tests/regressions/eformat-tests/unicode_demo_ucs4_cr_le.txt → src/tests/auxiliary/eformat-tests/unicode_demo_ucs4_cr_le.txt
View file

0
src/tests/regressions/eformat-tests/unicode_demo_ucs4_crlf_be.txt → src/tests/auxiliary/eformat-tests/unicode_demo_ucs4_crlf_be.txt
View file

0
src/tests/regressions/eformat-tests/unicode_demo_ucs4_crlf_le.txt → src/tests/auxiliary/eformat-tests/unicode_demo_ucs4_crlf_le.txt
View file

0
src/tests/regressions/eformat-tests/unicode_demo_ucs4_lf_be.txt → src/tests/auxiliary/eformat-tests/unicode_demo_ucs4_lf_be.txt
View file

0
src/tests/regressions/eformat-tests/unicode_demo_ucs4_lf_le.txt → src/tests/auxiliary/eformat-tests/unicode_demo_ucs4_lf_le.txt
View file

0
src/tests/regressions/eformat-tests/unicode_demo_utf8_cr.txt → src/tests/auxiliary/eformat-tests/unicode_demo_utf8_cr.txt
View file

0
src/tests/regressions/eformat-tests/unicode_demo_utf8_crlf.txt → src/tests/auxiliary/eformat-tests/unicode_demo_utf8_crlf.txt
View file

0
src/tests/regressions/eformat-tests/unicode_demo_utf8_lf.txt → src/tests/auxiliary/eformat-tests/unicode_demo_utf8_lf.txt
View file

76
src/tests/config.lsp.in
View file

@ -3,6 +3,7 @@
;;;
;;; (c) 2011, Juan Jose Garcia-Ripoll
;;; (c) 2016, Daniel Kochmański
;;;
;;; Set up the test environment.
;;;
@ -23,37 +24,25 @@
(defvar *test-sources* (merge-pathnames "tests/" *ecl-sources*))
(defvar *here* (merge-pathnames "@builddir@/"))
(defvar *cache* (merge-pathnames "./cache/" *here*))
(defvar *test-image* (or (ext:getenv "TEST_IMAGE")
#+windows
(namestring (truename #+windows "sys:ecl.exe"))
#-windows
"@prefix@/bin/ecl"))
(defvar *test-image*
(or (ext:getenv "TEST_IMAGE")
#+windows (namestring (truename "sys:ecl.exe"))
#-windows "@prefix@/bin/ecl"))
(defvar *test-image-args*
(cond ((search "ecl" *test-image*)
'("-norc" "-eval" "(print (ext:getenv \"ECLDIR\"))"
;#+windows "-eval" #+windows "(require :cmp)"
))
((search "sbcl" *test-image*)
'("--no-userinit" "--no-sysinit"))
(t
'())))
`("-norc"
"-eval" "(print (ext:getenv \"ECLDIR\"))"
"-eval" "(ignore-errors (require :cmp))"
"-load" ,(namestring (merge-pathnames "doit.lsp" *test-sources*))
"-eval" "(quit)"))
#+ecl
(ext:setenv "ECLDIR" (namestring (truename "SYS:")))
(defvar *test-name* (or (ext:getenv "TEST_NAME") "ecl"))
(defvar *output-directory* *here*)
(defvar *regressions-sources* (merge-pathnames "regressions/" *test-sources*))
(defvar *regressions-sandbox* (merge-pathnames "regressions/" *here*))
(defvar *wild-inferiors* (make-pathname :name :wild
:type :wild
:version :wild
:directory '(:relative :wild-inferiors)))
(defvar *cleanup-extensions* '("fasl" "fasb" "c" "h" "obj" "o" "a" "lib" "dll" "dylib" "data"))
(defvar *sandbox* (merge-pathnames "temporary/" *here*))
(defun lisp-system-directory ()
(loop with root = (si::get-library-pathname)
@ -68,19 +57,9 @@
(merge-pathnames "**/*.*"
(lisp-system-directory)))))
(require :cmp)
;;;
;;; PREPARATION OF DIRECTORIES AND FILES
;;;
(defun setup-asdf ()
(require :asdf)
(ensure-directories-exist *cache*)
(setf (symbol-value (read-from-string "asdf::*user-cache*"))
(list *cache* :implementation)))
(defun delete-everything (path)
;; Recursively run through children
(labels ((recursive-deletion (path)
@ -100,43 +79,20 @@
(and (probe-file path)
(recursive-deletion path))))
(defun copy-directory (orig dest)
(setf orig (truename orig))
(print dest)
(loop for f in (directory (merge-pathnames *wild-inferiors* orig))
for f2 = (enough-namestring f orig)
for f3 = (merge-pathnames f2 dest)
unless (and (probe-file f3)
(>= (file-write-date f3)
(file-write-date f2)))
do (ensure-directories-exist f3)
do (ext:copy-file f f3)))
(defun ensure-regressions ()
(unless (probe-file *regressions-sandbox*)
(copy-directory *regressions-sources* *regressions-sandbox*)))
(defun cleanup-directory (path)
(loop for i in (directory (merge-pathnames *wild-inferiors*
path))
when (member (pathname-type i) *cleanup-extensions* :test #'string-equal)
do (delete-file i)))
;;;
;;; RUNNING TESTS
;;;
(defun run-regressions-tests ()
(ensure-regressions)
(defun run-tests ()
;; Cleanup stray files
(cleanup-directory *regressions-sandbox*)
(delete-everything *sandbox*)
(ensure-directories-exist *sandbox*)
(unwind-protect
(progn
(ext:chdir *regressions-sandbox*)
(ext:chdir *sandbox*)
(ext:run-program *test-image*
*test-image-args*
:input (merge-pathnames "doit.lsp" *regressions-sandbox*)
:input nil
:output t
:error :output))
(ext:chdir *here*)))

12
src/tests/doit.lsp Normal file
View file

@ -0,0 +1,12 @@
(in-package #:common-lisp-user)
(eval-when (:compile-toplevel :load-toplevel :execute)
(require :asdf))
(let ((cache (merge-pathnames "./cache/" *default-pathname-defaults*)))
(ensure-directories-exist cache)
(setf asdf:*user-cache* cache)
(asdf:load-asd (merge-pathnames "ecl-tests.asd" *load-pathname*)))
(asdf:operate 'asdf:load-source-op 'ecl-tests)
(2am-ecl:run 'cl-test::make-check)

37
src/tests/ecl-tests.asd Normal file
View file

@ -0,0 +1,37 @@
;;;; ecl-tests.asd
(asdf:defsystem #:ecl-tests
:description "Various tests for ECL"
:author "Daniel Kochmański <daniel@turtleware.eu>"
:license "LGPL-2.1+"
:serial t
:components ((:file "2am") ; continuous integration
(:file "ecl-tests")
(:file "universe")
(:module regressions
:default-component-class asdf:cl-source-file.lsp
:components
((:file "ansi")
(:file "mixed")
(:file "compiler")
(:file "embedding" :if-feature (:not :ecl-bytecmp))
(:file "foreign-interface" :if-feature :ffi)
(:file "metaobject-protocol" :if-feature :clos)
(:file "multiprocessing" :if-feature :threads)))
(:module features
:default-component-class asdf:cl-source-file.lsp
:components
((:file "external-formats" :if-feature :unicode)))))
(asdf:defsystem #:ecl-tests/stress
:serial t
:components
((:file "1am") ; for stress tests
(:module stress
:default-component-class asdf:cl-source-file.lsp
:components
((:file "multiprocessing" :if-feature :threads)))))
;;; General tests
(asdf:defsystem #:ecl-tests/ansi)
(asdf:defsystem #:ecl-tests/benchmark)

147
src/tests/ecl-tests.lisp Normal file
View file

@ -0,0 +1,147 @@
;;;; ecl-tests.lisp
(defpackage #:cl-test
(:use #:cl #:2am-ecl))
(in-package #:cl-test)
;;; Set pathnames
(defparameter *aux-dir*
(merge-pathnames
"auxiliary/"
(make-pathname :directory (pathname-directory
(asdf:system-definition-pathname 'ecl-tests)))))
(defparameter *tmp-dir*
(merge-pathnames
"temporary/"
(make-pathname :directory (pathname-directory *default-pathname-defaults*))))
;;;; Declare the suites
(suite 'ecl-tests
'(regressions
features))
(suite 'make-check
'(features/eformat
regressions/ansi+
regressions/mixed
regressions/cmp
regressions/emb
regressions/ffi
regressions/mop
;; disable regressions/mp due to fails
#+ (or) regressions/mp))
(suite 'regressions
'(regressions/ansi+
regressions/mixed
regressions/cmp
regressions/emb
regressions/ffi
regressions/mop
regressions/mp))
(suite 'features
'(features/eformat))
;;; Some syntactic sugar for 2am
(defmacro once-only (specs &body body)
"Once-Only ({(Var Value-Expression)}*) Form*
Create a Let* which evaluates each Value-Expression, binding a
temporary variable to the result, and wrapping the Let* around the
result of the evaluation of Body. Within the body, each Var is
bound to the corresponding temporary variable."
(labels ((frob (specs body)
(if (null specs)
`(progn ,@body)
(let ((spec (first specs)))
(when (/= (length spec) 2)
(error "Malformed Once-Only binding spec: ~S." spec))
(let ((name (first spec))
(exp-temp (gensym)))
`(let ((,exp-temp ,(second spec))
(,name (gensym "OO-")))
`(let ((,,name ,,exp-temp))
,,(frob (rest specs) body))))))))
(frob specs body)))
(defmacro is-true (form)
(once-only ((result form))
`(is (eql ,result t) "Expected T, but got ~s" ,result)))
(defmacro is-false (form)
(once-only ((result form))
`(is (null ,result) "Expected NIL, but got ~s" ,result)))
(defmacro is-equal (what form)
(once-only ((what what)
(form form))
`(is (equal ,what ,form) "EQUAL: ~s to ~s" ',form ,what ,form)))
(defmacro is-eql (what form)
(once-only ((what what)
(form form))
`(is (eql ,what ,form) "EQL: ~s to ~s" ,what ,form)))
(defmacro pass (form &rest args)
(declare (ignore form args))
`(passed))
(defmacro fail (form &rest args
&aux
(fmt-ctrl (or (car args) ""))
(fmt-args (cdr args)))
(declare (ignore form))
`(failed (make-condition 'test-failure
:name *test-name*
:format-control ,fmt-ctrl
:format-arguments (list ,@fmt-args))))
;;;; Author: Juan Jose Garcia-Ripoll
;;;; Created: Fri Apr 14 11:13:17 CEST 2006
;;;; Contains: Tools for doing tests, intercepting functions, etc.
(defmacro with-dflet (functions &body body)
"Syntax:
(with-dflet ((fname form*)*) body)
Evaluate BODY in an environment in which the function FNAME has been
redefined to evaluate the given forms _before_ executing the orginal
code."
(let ((vars '()) (in-forms '()) (out-forms '()))
(loop for (name . forms) in functions
do (let ((var (gensym)))
(push `(,var #',name) vars)
(push `(setf (fdefinition ',name)
#'(lambda (&rest args) ,@forms (apply ,var args)))
in-forms)
(push `(setf (fdefinition ',name) ,var) out-forms)))
`(let ,vars
(unwind-protect
(progn ,@in-forms ,@body)
(progn ,@out-forms)))))
(defmacro with-compiler ((filename &rest compiler-args) &body forms)
"Create a lisp file with the given forms and compile it. The forms
are evaluated unless they are strings. Strings are simply inlined to
allow using reader macros. The output is stored in a string and output
as a second value."
`(progn
(with-open-file (s ,filename :direction :output :if-exists :supersede
:if-does-not-exist :create)
,@(loop for f in forms collect (if (stringp f)
`(format s "~A" ,f)
`(print ,f s))))
(let* ((compiled-file t)
(output
(with-output-to-string (*standard-output*)
(let ((*error-output* *standard-output*)
(*compile-verbose* t)
(*compile-print* t))
(setf compiled-file (compile-file ,filename ,@compiler-args))))))
(values compiled-file output))))

344
src/tests/features/external-formats.lsp Normal file
View file

@ -0,0 +1,344 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*-
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
;;;; Author: Juan Jose Garcia-Ripoll
;;;; Created: Sat Jan 03 2:56:03 CEST 2007
;;;; Contains: External format tests
;;;;
;;;; Based on the code and files from FLEXI-STREAMS 1.0.7
;;;;
(in-package :cl-test)
(suite 'features/eformat)
;;; eformat-001
(defconstant +buffer-size+ 8192
"Size of buffers for COPY-STREAM* below.")
(defparameter *copy-function* 'copy-stream
"Which function to use when copying from one stream to the other -
see for example COPY-FILE below.")
(defparameter *eformat-test-files*
'(("unicode_demo" (:utf8 :ucs2 :ucs4))
("kafka" (:utf8 :latin1 :cp1252))
("hebrew" (:utf8 :latin8))
("russian" (:utf8 :koi8r))
("tilton" (:utf8 :ascii)))
"A list of test files where each entry consists of the name
prefix and a list of encodings.")
(defparameter *eformat-tests-directory*
(merge-pathnames "eformat-tests/" *aux-dir*))
(defparameter *eformat-sandbox-directory*
(merge-pathnames "eformat-tests/" *tmp-dir*))
(defun create-file-variants (file-name symbol)
"For a name suffix FILE-NAME and a symbol SYMBOL denoting an
encoding returns a list of pairs where the car is a full file
name and the cdr is the corresponding external format. This list
contains all possible variants w.r.t. to line-end conversion and
endianness."
(let ((variants (ecase symbol
(:ascii '(:us-ascii))
(:latin1 '(:latin-1))
(:latin8 '(:iso-8859-8))
(:cp1252 '(:windows-cp1252))
(:koi8r '(:koi8-r))
(:utf8 '(:utf-8))
(:ucs2 '(:ucs-2be :ucs-2le))
(:ucs4 '(:ucs-4be :ucs-4le)))))
(loop for arg in variants
nconc (let* ((endian-suffix (case arg
((:ucs-2be :ucs-4be) "_be")
((:ucs-2le :ucs-4le) "_le")
(t ""))))
(loop for eol-style in '(:lf :cr :crlf)
collect (cons (format nil "~A_~(~A~)_~(~A~)~A.txt"
file-name symbol eol-style endian-suffix)
(list eol-style arg)))))))
(defun create-test-combinations (file-name symbols &optional simplep)
"For a name suffix FILE-NAME and a list of symbols SYMBOLS denoting
different encodings of the corresponding file returns a list of lists
which can be used as arglists by DO-EFORMAT-TEST-001. If SIMPLEP is true, a
list which can be used for the string and sequence tests below is
returned."
(let ((file-variants (loop for symbol in symbols
nconc (create-file-variants file-name symbol))))
(loop for (name-in . external-format-in) in file-variants
when simplep
collect (list name-in external-format-in)
else
nconc (loop for (name-out . external-format-out) in file-variants
collect (list name-in external-format-in name-out external-format-out)))))
(defun file-equal (file1 file2)
"Returns a true value iff FILE1 and FILE2 have the same
contents \(viewed as binary files)."
(with-open-file (stream1 file1 :element-type '(unsigned-byte 8))
(with-open-file (stream2 file2 :element-type '(unsigned-byte 8))
(if (= (file-length stream1) (file-length stream2))
(loop for p1 = (file-position stream1)
for byte1 = (read-byte stream1 nil nil)
for byte2 = (read-byte stream2 nil nil)
while (and byte1 byte2)
unless (= byte1 byte2)
do (return (values nil p1))
finally (return (values t 0)))
(values nil -1)))))
(defun copy-stream (in out)
"Copies the contents of the binary stream STREAM-IN to the
binary stream STREAM-OUT using flexi streams - STREAM-IN is read
with the external format EXTERNAL-FORMAT-IN and STREAM-OUT is
written with EXTERNAL-FORMAT-OUT."
(loop for line = (read-line in nil nil)
while line
do (write-line line out)))
(defun copy-stream* (in out)
"Like COPY-STREAM, but uses READ-SEQUENCE and WRITE-SEQUENCE instead
of READ-LINE and WRITE-LINE."
(let ((buffer (make-array +buffer-size+ :element-type 'char*)))
(loop
(let ((position (read-sequence buffer in)))
(when (zerop position) (return))
(write-sequence buffer out :end position)))))
(defun do-eformat-test-001 (*copy-function*)
"Each test in this suite copies the contents of one file \(in the
`test' directory) to another file \(in a temporary directory) using
flexi streams with different external formats. The resulting file is
compared with an existing file in the `test' directory to check if the
outcome is as expected. Uses various variants of the :DIRECTION
keyword when opening the files.
Returns a true value iff all tests succeeded. Prints information
about each individual comparison if VERBOSE is true."
(labels
((copy-file (path-in external-format-in path-out external-format-out
direction-out direction-in)
(with-open-file (in path-in
:element-type 'character
:direction direction-in
:if-does-not-exist :error
:if-exists :overwrite
:external-format external-format-in)
(with-open-file (out path-out
:element-type 'character
:direction direction-out
:if-does-not-exist :create
:if-exists :supersede
:external-format external-format-out)
(funcall *copy-function* in out))))
(one-comparison (path-in external-format-in path-out external-format-out)
(loop with full-path-in = (merge-pathnames path-in *eformat-tests-directory*)
and full-path-out = (ensure-directories-exist
(merge-pathnames path-out *eformat-sandbox-directory*))
and full-path-orig = (merge-pathnames path-out *eformat-tests-directory*)
for direction-out in '(:output :io)
nconc (loop for direction-in in '(:input :io)
for args = (list path-in external-format-in direction-in
path-out external-format-out direction-out)
with ok = nil
with pos = 0
unless (progn
(copy-file full-path-in external-format-in
full-path-out external-format-out
direction-out direction-in)
(is (multiple-value-setq (ok pos)
(file-equal full-path-out full-path-orig))
"~%~A -> ~A" path-in path-out))
collect (progn
(format t "~%;;; Discordance at pos ~D~%between ~A~% and ~A~%"
pos full-path-out full-path-orig)
args)))))
(loop with do-eformat-test-001-args-list =
(loop for (file-name symbols) in *eformat-test-files*
nconc (create-test-combinations file-name symbols))
for (path-in external-format-in path-out external-format-out) in do-eformat-test-001-args-list
nconc (one-comparison path-in external-format-in path-out external-format-out))))
;;; Date: 02/01/2007
;;; From: Juanjo
;;; Fixed: Not a bug
;;; Description:
;;;
;;; Test external formats by transcoding several files into all possible
;;; supported formats and checking against the expected results. This
;;; test uses READ/WRITE-CHAR via READ/WRITE-LINE.
;;;
(test external-format.0001-transcode-read-char
(is-false (do-eformat-test-001 'copy-stream)))
;;; Date: 02/01/2007
;;; From: Juanjo
;;; Fixed: Not a bug
;;; Description:
;;;
;;; Test external formats by transcoding several files into all possible
;;; supported formats and checking against the expected results. This
;;; test uses READ/WRITE-CHAR via READ/WRITE-LINE.
;;;
(test external-format.0002-transcode-read-char
(is-false (do-eformat-test-001 'copy-stream*)))
;;; eformat-002
(load "sys:encodings;tools")
(setf *print-circle* t) ; some mappings contain circular structures
(defun binary-dump (filename &optional (position 0) (limit nil))
(format t "~%FILE: ~A from ~D, ~D bytes" filename position limit)
(with-open-file (file filename :element-type '(unsigned-byte 8))
(file-position file position)
(loop for i from 0
for byte = (read-byte file nil nil)
for c = (and byte (code-char byte))
while (and byte (or (null limit) (< i limit)))
do (progn (when (zerop (mod i 8)) (terpri))
(format t "~5X ~3A" byte
(cond ((and (< 31 byte 127) (standard-char-p c))
c)
((eql c #\Esc) "ESC")
(t " ")))
)))
(terpri)
(force-output))
(defun random-strings (char-bag n)
(if (consp char-bag)
(apply #'concatenate 'string
(loop for i from 0 below 2
for actual-bag = (elt char-bag (random (length char-bag)))
collect (random-strings actual-bag (random n))))
(concatenate 'string
(loop for i from 0 to n
for c = (char char-bag (random (length char-bag)))
unless (eql c #\Newline)
collect c))))
(defun compare-files (a b &optional all-chars)
(with-open-file (sa a :direction :input :element-type '(unsigned-byte 8))
(with-open-file (sb b :direction :input :element-type '(unsigned-byte 8))
(loop for b1 = (read-byte sa nil nil)
for b2 = (read-byte sb nil nil)
while (or b1 b2)
do (unless (eql b1 b2)
(let* ((position (1- (file-position sa)))
(start-dump (max 0 (- position 8))))
(setf position (logandc2 position 3))
(binary-dump a start-dump 32)
(binary-dump b start-dump 32)
(format t "~%Mismatch between~%~T~A~% and~T~A~% at file position ~D~%"
a b position)
(when all-chars
(loop with imin = (floor start-dump 4)
with imax = (min (+ imin 9) (length all-chars))
for i from imin below imax
for j from 0
for c = (char all-chars i)
do (progn (when (zerop (mod j 8)) (terpri))
(format t "~4X " (char-code c))))
(terpri))
(return nil)))
finally (return t)))))
(defun test-output (format-name &optional iconv-name (nlines 128) (nchars 10))
(set 'ext::foo format-name)
(let* ((*print-circle* t)
(mappings (loop for table = (ext::make-encoding format-name)
while (and table (symbolp table))
do (setf format-name table)
finally (return (or table format-name))))
(char-bags (all-valid-unicode-chars mappings))
(encoded-filename (format nil "sandbox/eformat-tmp/iconv-~A.txt" format-name))
(decoded-filename (format nil "sandbox/eformat-tmp/iconv-~A-utf32.txt" format-name))
(iconv-filename (format nil "sandbox/eformat-tmp/iconv-~A-iconv-utf32.txt" format-name))
(random-lines (loop for line from 1 to nlines
collect (random-strings char-bags nchars)))
(all-chars (apply #'concatenate 'string
(loop for i in random-lines
nconc (list i (list #\Newline))))))
(ensure-directories-exist encoded-filename)
;; Output in that format
(with-open-file (out encoded-filename :direction :output :external-format format-name
:if-exists :supersede)
(loop for i in random-lines
do (write-line i out)))
(with-open-file (out decoded-filename :direction :output :external-format :ucs-4be
:if-exists :supersede)
(loop for i in random-lines
do (write-line i out)))
(with-open-file (in encoded-filename :direction :input :external-format format-name)
(loop for line = (read-line in nil nil)
for i in random-lines
for n from 1
while line
unless (string= i line)
do (progn
(format t "Mismatch on line ~D between~% ~S and~% ~S" n line i)
(return-from test-output nil))))
(when iconv-name
(let ((command (format nil "iconv -f ~A -t UTF-32BE ~A > ~A"
iconv-name encoded-filename iconv-filename)))
(if (zerop
(si::system command))
(compare-files decoded-filename iconv-filename all-chars)
(prog1 T
(format t "~&;;; iconv command failed:~A~%" command)))))))
;;; Date: 09/01/2007
;;; From: Juanjo
;;; Fixed: Not a bug
;;; Description:
;;;
;;; Test external formats by transcoding random sequences of characters using
;;; ECL and iconv.
;;;
#-msvc
;; In Windows SYSTEM does not fail with a nonzero code when it
;; fails to execute a command. Hence in that case we assume
;; we simply can not run these tests
(when (zerop (si::system "iconv -l >/dev/null 2>&1"))
(test external-format.simple-iconv-check
(is-false
(loop for name in '(:ISO-8859-1 :ISO-8859-2 :ISO-8859-3 :ISO-8859-4
:ISO-8859-5 :ISO-8859-6 :ISO-8859-7 :ISO-8859-8
:ISO-8859-9 :ISO-8859-10 :ISO-8859-11 :ISO-8859-13
:ISO-8859-14 :ISO-8859-15 :ISO-8859-16
:KOI8-R :KOI8-U
:IBM437 :IBM850 :IBM852 :IBM855 :IBM857 :IBM860
:IBM861 :IBM862 :IBM863 :IBM864 :IBM865 :IBM866
:IBM869
:CP936 :CP949 :CP950
:WINDOWS-1250 :WINDOWS-1251 :WINDOWS-1252 :WINDOWS-1253
:WINDOWS-1254 :WINDOWS-1256 :WINDOWS-1257
;; :CP932 :WINDOWS-1255 :WINDOWS-1258 with
;; iconv may output combined characters, when ECL would
;; output the base and the comibining one. Hence, no simple
;; comparison is possible.
:ISO-2022-JP
;; :ISO-2022-JP-1
;; iconv doesn't support ISO-2022-JP-1 (hue hue hue)
)
unless (progn
(loop for i from 1 to 10
always (is (test-output name (symbol-name name))
"iconv test ~s failed" name)))
collect name))))

1189
src/tests/regressions/ansi-aux.lsp
View file

File diff suppressed because it is too large Load diff

75
src/tests/regressions/ansi.lsp Normal file
View file

@ -0,0 +1,75 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*-
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
(in-package :cl-test)
(suite 'regressions/ansi+)
;; HyperSpec – 3.*
;;;;;;;;;;;;;;;;;;;
;; Deftype tests ;;
;;;;;;;;;;;;;;;;;;;
(ext:with-clean-symbols (ordinary1 ordinary2)
(test ansi.0001.ordinary
(deftype ordinary1 ()
`(member nil t))
(deftype ordinary2 (a b)
(if a 'CONS `(INTEGER 0 ,b)))
(is-true (typep T 'ordinary1))
(is-false (typep :a 'ordinary1))
(is-false (typep T '(ordinary2 nil 3)))
(is-true (typep 3 '(ordinary2 nil 4)))
(is-false (typep T '(ordinary2 T nil)))
(is-true (typep '(1 . 2) '(ordinary2 T nil)))))
(ext:with-clean-symbols (opt)
(test ansi.0002.optional
(deftype opt (a &optional b)
(if a 'CONS `(INTEGER 0 ,b)))
(is-true (typep 5 '(opt nil)))
(is-false (typep 5 '(opt nil 4)))))
(ext:with-clean-symbols (nest)
(test ansi.0003.nested
(deftype nest ((a &optional b) c . d)
(assert (listp d))
`(member ,a ,b ,c))
(is-true (typep 1 '(nest (1 2) 3 4 5 6)))
(is-false (typep 1 '(nest (2 2) 3 4 5 6)))
(is-true (typep '* '(nest (3) 3)))
(is-true (typep 3 '(nest (2) 3)))))
;;;;;;;;;;;;;;;;;;;;;;;;;
;; 19.* Pathname tests ;;
;;;;;;;;;;;;;;;;;;;;;;;;;
;; Issue #103 ;; logical-pathname-translations not translating
;; https://gitlab.com/embeddable-common-lisp/ecl/issues/103
(test ansi.0004.wildcards
(setf (logical-pathname-translations "prog")
'(("CODE;*.*.*" "/tmp/prog/")))
(is (equal
(namestring (translate-logical-pathname "prog:code;documentation.lisp"))
"/tmp/prog/documentation.lisp")))
;;;;;;;;;;;;;;;;;;;;;;;
;; 23.* Reader tests ;;
;;;;;;;;;;;;;;;;;;;;;;;
(progn
(defstruct example-struct a)
(test ansi.0005.sharp-s-reader
(finishes
(read-from-string
"(#1=\"Hello\" #S(cl-test::example-struct :A #1#))"))))

1160
src/tests/regressions/compiler.lsp Normal file
View file

File diff suppressed because it is too large Load diff

58
src/tests/regressions/doit.lsp
View file

@ -1,58 +0,0 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*-
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
;;; Remove compiled files
(let* ((fn (compile-file-pathname "doit.lsp"))
(type (pathname-type fn))
(dir-pathname (make-pathname :name :wild :type type))
(files (union (directory "aux*.*") (directory dir-pathname) :test #'equal)))
(assert type)
(assert (not (string-equal type "lsp")))
(mapc #'delete-file files))
(si::package-lock (find-package "COMMON-LISP") nil)
(require 'rt)
#+ecl (compile nil '(lambda () nil))
(setq *load-verbose* nil
*load-print* nil
*compile-verbose* nil
*compile-print* nil)
(unless (find-package :cl-test)
(make-package :cl-test))
(in-package :cl-test)
(use-package :sb-rt)
(load "tools.lsp")
(load "universe.lsp")
(load "ansi-aux.lsp")
(load "tests/test-ansi.lsp")
(load "tests/mixed.lsp")
(load "tests/compiler.lsp")
#-ecl-bytecmp
(progn
(load "tests/embedding.lsp")
#+ffi (load "tests/foreign-interface.lsp"))
#+clos
(load "tests/metaobject-protocol.lsp")
#+threads
(load "tests/multiprocessing.lsp")
#+unicode
(load "tests/external-formats.lsp")
(load "tests/random-states.lsp")
(setf sb-rt::*expected-failures*
(nconc sb-rt::*expected-failures*
'(SEM-SIGNAL-N-PROCESSES
SEM-SIGNAL-ONLY-N-PROCESSES
SEM-INTERRUPTED-RESIGNALS)))
(time (sb-rt:do-tests))

25
src/tests/regressions/tests/embedding.lsp → src/tests/regressions/embedding.lsp
View file

@ -7,6 +7,8 @@
(in-package :cl-test)
(suite 'regressions/emb)
(defun test-C-program (c-code &key capture-output)
(ensure-directories-exist "tmp/")
(with-open-file (s "tmp/aux.c" :direction :output :if-exists :supersede
@ -44,8 +46,9 @@
;;;
;;; Fixed: 03/2006 (juanjo)
;;;
(deftest embedding.0001.shutdown
(let* ((skeleton "
(test emb.0001.shutdown
(is (equal
(let* ((skeleton "
#include <ecl/ecl.h>
#include <stdlib.h>
int main (int argc, char **argv) {
@ -55,11 +58,11 @@ int main (int argc, char **argv) {
cl_shutdown();
exit(0);
}")
(form '(push (lambda () (print :shutdown)) si::*exit-hooks*))
(c-code (format nil skeleton (format nil "~S" form)))
(data (test-C-program c-code :capture-output t)))
data)
(:shutdown))
(form '(push (lambda () (print :shutdown)) si::*exit-hooks*))
(c-code (format nil skeleton (format nil "~S" form)))
(data (test-C-program c-code :capture-output t)))
data)
'(:shutdown))))
;;; Date: 2016-05-25 (Vadim Penzin)
;;; Date: 2016-05-27 (Vadim Penzin)
@ -78,8 +81,9 @@ int main (int argc, char **argv) {
;;; user interaction (ie picking the restart), hence we only test
;;; the ECL_HANDLER_CASE.
;;;
(deftest embedding.0002.handlers
(let* ((c-code "
(test emb.0002.handlers
(is-true
(let* ((c-code "
#include <stdio.h>
#include <ecl/ecl.h>
@ -102,5 +106,4 @@ main ( const int argc, const char * const argv [] )
return result;
}
"))
(test-C-program c-code))
T)
(test-C-program c-code))))

77
src/tests/regressions/tests/external-formats.lsp → src/tests/regressions/external-formats.lsp
View file

@ -8,13 +8,10 @@
;;;; Based on the code and files from FLEXI-STREAMS 1.0.7
;;;;
#+(or)
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package :cl-test)
(make-package :cl-test)))
(in-package :cl-test)
(suite 'features/eformat)
;;; eformat-001
@ -135,7 +132,6 @@ about each individual comparison if VERBOSE is true."
:external-format external-format-out)
(funcall *copy-function* in out))))
(one-comparison (path-in external-format-in path-out external-format-out)
(format t "~%;;; ~A -> ~A" path-in path-out)
(loop with full-path-in = (merge-pathnames path-in "./eformat-tests/")
and full-path-out = (ensure-directories-exist
(merge-pathnames path-out "./eformat-tmp/"))
@ -150,8 +146,9 @@ about each individual comparison if VERBOSE is true."
(copy-file full-path-in external-format-in
full-path-out external-format-out
direction-out direction-in)
(multiple-value-setq (ok pos)
(file-equal full-path-out full-path-orig)))
(is (multiple-value-setq (ok pos)
(file-equal full-path-out full-path-orig))
"~%~A -> ~A" path-in path-out))
collect (progn
(format t "~%;;; Discordance at pos ~D~%between ~A~% and ~A~%"
pos full-path-out full-path-orig)
@ -171,9 +168,8 @@ about each individual comparison if VERBOSE is true."
;;; supported formats and checking against the expected results. This
;;; test uses READ/WRITE-CHAR via READ/WRITE-LINE.
;;;
(deftest external-format.0001-transcode-read-char
(do-eformat-test-001 'copy-stream)
nil)
(test external-format.0001-transcode-read-char
(is-false (do-eformat-test-001 'copy-stream)))
;;; Date: 02/01/2007
;;; From: Juanjo
@ -184,9 +180,8 @@ about each individual comparison if VERBOSE is true."
;;; supported formats and checking against the expected results. This
;;; test uses READ/WRITE-CHAR via READ/WRITE-LINE.
;;;
(deftest external-format.0002-transcode-read-char
(do-eformat-test-001 'copy-stream*)
nil)
(test external-format.0002-transcode-read-char
(is-false (do-eformat-test-001 'copy-stream*)))
;;; eformat-002
@ -293,7 +288,7 @@ about each individual comparison if VERBOSE is true."
(si::system command))
(compare-files decoded-filename iconv-filename all-chars)
(prog1 T
(format t "~&;;; iconv command failed:~A" command)))))))
(format t "~&;;; iconv command failed:~A~%" command)))))))
;;; Date: 09/01/2007
;;; From: Juanjo
@ -308,37 +303,37 @@ about each individual comparison if VERBOSE is true."
;; fails to execute a command. Hence in that case we assume
;; we simply can not run these tests
(when (zerop (si::system "iconv -l >/dev/null 2>&1"))
(deftest external-format.simple-iconv-check
(loop for name in '(:ISO-8859-1 :ISO-8859-2 :ISO-8859-3 :ISO-8859-4
:ISO-8859-5 :ISO-8859-6 :ISO-8859-7 :ISO-8859-8
:ISO-8859-9 :ISO-8859-10 :ISO-8859-11 :ISO-8859-13
:ISO-8859-14 :ISO-8859-15 :ISO-8859-16
(test external-format.simple-iconv-check
(is-false
(loop for name in '(:ISO-8859-1 :ISO-8859-2 :ISO-8859-3 :ISO-8859-4
:ISO-8859-5 :ISO-8859-6 :ISO-8859-7 :ISO-8859-8
:ISO-8859-9 :ISO-8859-10 :ISO-8859-11 :ISO-8859-13
:ISO-8859-14 :ISO-8859-15 :ISO-8859-16
:KOI8-R :KOI8-U
:KOI8-R :KOI8-U
:IBM437 :IBM850 :IBM852 :IBM855 :IBM857 :IBM860
:IBM861 :IBM862 :IBM863 :IBM864 :IBM865 :IBM866
:IBM869
:IBM437 :IBM850 :IBM852 :IBM855 :IBM857 :IBM860
:IBM861 :IBM862 :IBM863 :IBM864 :IBM865 :IBM866
:IBM869
:CP936 :CP949 :CP950
:CP936 :CP949 :CP950
:WINDOWS-1250 :WINDOWS-1251 :WINDOWS-1252 :WINDOWS-1253
:WINDOWS-1254 :WINDOWS-1256 :WINDOWS-1257
:WINDOWS-1250 :WINDOWS-1251 :WINDOWS-1252 :WINDOWS-1253
:WINDOWS-1254 :WINDOWS-1256 :WINDOWS-1257
;; :CP932 :WINDOWS-1255 :WINDOWS-1258 with
;; iconv may output combined characters, when ECL would
;; output the base and the comibining one. Hence, no simple
;; comparison is possible.
;; :CP932 :WINDOWS-1255 :WINDOWS-1258 with
;; iconv may output combined characters, when ECL would
;; output the base and the comibining one. Hence, no simple
;; comparison is possible.
:ISO-2022-JP
;; :ISO-2022-JP-1
;; iconv doesn't support ISO-2022-JP-1 (hue hue hue)
)
unless (progn
(format t "~%;;; Testing ~A " name)
(loop for i from 1 to 10
always (test-output name (symbol-name name))))
collect name)
nil))
:ISO-2022-JP
;; :ISO-2022-JP-1
;; iconv doesn't support ISO-2022-JP-1 (hue hue hue)
)
unless (progn
(loop for i from 1 to 10
always (is (test-output name (symbol-name name))
"iconv test ~s failed" name)))
collect name))))

114
src/tests/regressions/foreign-interface.lsp Normal file
View file

@ -0,0 +1,114 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*-
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
;;;; Author: Juan Jose Garcia-Ripoll
;;;; Author: Daniel Kochmański
;;;; Created: Fri Apr 14 11:13:17 CEST 2006
;;;; Contains: Foreign Function Interface regression tests
(in-package :cl-test)
(suite 'regressions/ffi)
;;; Date: 23/03/2006
;;; From: Klaus Falb
;;; Fixed: 26/02/2006 (juanjo)
;;; Description:
;;;
;;; Callback functions have to be declared static so that there
;;; are no conflicts among callbacks in different files.
;;;
;;; Fixed: 13/04/2006 (juanjo)
;;; Description:
;;;
;;; Header <internal.h> should be included as <ecl/internal.h>
;;;
(test ffi.0001.callback
(is
(and (zerop (si::system "rm -rf tmp; mkdir tmp"))
(with-open-file (s "tmp/a.lsp" :direction :output
:if-exists :supersede
:if-does-not-exist :create)
(print '(ffi:defcallback foo :void () nil) s))
(with-open-file (s "tmp/b.lsp" :direction :output
:if-exists :supersede
:if-does-not-exist :create)
(print '(ffi:defcallback foo :void () nil) s))
(compile-file "tmp/a.lsp" :system-p t)
(compile-file "tmp/b.lsp" :system-p t)
(c:build-program "tmp/foo" :lisp-files
(list (compile-file-pathname "tmp/a.lsp" :type :object)
(compile-file-pathname "tmp/b.lsp" :type :object)))
(probe-file (compile-file-pathname "tmp/foo" :type :program))
(zerop (si::system "rm -rf tmp")))))
;;; Date: 29/07/2008
;;; From: Juajo
;;; Description:
;;; Callback examples based on the C compiler
;;;
(test ffi.0002.callback-sffi-example
(is
(and (zerop (si::system "rm -rf tmp; mkdir tmp"))
(with-open-file (s "tmp/c.lsp" :direction :output
:if-exists :supersede
:if-does-not-exist :create)
(print
'(defun callback-user (callback arg)
(ffi:c-inline (callback arg) (:pointer-void :int) :int "
int (*foo)(int) = #0;
@(return) = foo(#1);
"
:one-liner nil :side-effects nil))
s)
(print
'(ffi:defcallback ffi-002-foo :int ((a :int))
(1+ a))
s))
(compile-file "tmp/c.lsp" :load t)
(eql (callback-user (ffi:callback 'ffi-002-foo) 2) 3)
t)))
;;; Date: 29/07/2008
;;; From: Juajo
;;; Description:
;;; Callback examples based on the DFFI. Only work if this feature
;;; has been linked in.
;;;
#+dffi
(test ffi.0003.callback-dffi-example
(is
(and (zerop (si::system "rm -rf tmp; mkdir tmp"))
(with-open-file (s "tmp/c.lsp" :direction :output
:if-exists :supersede
:if-does-not-exist :create)
(print
'(defun callback-user (callback arg)
(ffi:c-inline (callback arg) (:pointer-void :int) :int "
int (*foo)(int) = #0;
@(return) = foo(#1);
"
:one-liner nil :side-effects nil))
s))
(compile-file "tmp/c.lsp" :load t)
(eval '(ffi:defcallback foo-002b :int ((a :int))
(1+ a)))
(eql (callback-user (ffi:callback 'foo-002b) 2) 3)
t)))
;;; Date: 25/04/2010 (Juanjo)
;;; Description:
;;; Regression test to ensure that two foreign data compare
;;; EQUAL when their addresses are the same.
(test ffi.0004.foreign-data-equal
(is
(equal (ffi:make-pointer 1234 :void)
(ffi:make-pointer 1234 :int))))
;;; Date: 2016-01-04 (jackdaniel)
;;; Description:
;;; Regression test to ensure, that the string is properly
;;; recognized as an array
(test ffi.0005.string-is-array
(finishes
(si::make-foreign-data-from-array "dan")))

620
src/tests/regressions/metaobject-protocol.lsp Normal file
View file

@ -0,0 +1,620 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*-
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
;;;; Author: Juan Jose Garcia-Ripoll
;;;; Author: Daniel Kochmański
;;;; Created: Fri Apr 14 11:13:17 CEST 2006
;;;; Contains: Metaobject Protocol tests
(in-package #:cl-test)
(suite 'regressions/mop)
;; mop-001
(defun delete-class (&rest class-names)
;;; do nothing. We will figure out later what to do.
(values))
;;; Fixed: 14/04/2006 (juanjo)
;;; Description:
;;;
;;; The slot definitions from some classes did not get converted.
;;; Besides, metaobject CLASS had the same list for direct and effective
;;; slots.
;;;
(test mop.0001.fixup
(is-false
(block top
(labels ((test-class (class-object)
(let ((x (find-if-not #'(lambda (x)
(typep x 'clos:standard-direct-slot-definition))
(clos:class-direct-slots class-object))))
(when x
(format t "Class ~a has as direct slot ~a" class-object x)
(return-from top (class-name class-object))))
(let ((x (find-if-not #'(lambda (x)
(typep x 'clos:standard-effective-slot-definition))
(clos:class-slots class-object))))
(when x
(format t "Class ~a has as effective slot ~a" class-object x)
(return-from top (class-name class-object))))
(mapc #'test-class (clos:class-direct-subclasses class-object))))
(test-class (find-class 't))
nil))))
;;; Date: 13/02/2006
;;; From: Dan Debertin
;;; Fixed: 24-02-2006 (juanjo)
;;; Description:
;;;
;;; Subclasses of STANDARD-CLASS would not inherit all their slots
;;; and thus would cause runtime errors when creating instances.
;;;
(test mop.0002.metaclasses
(is
(= 3
(eval '(progn
(defclass foo-metaclass (standard-class) ())
(defclass faa () ((a :initform 2 :initarg :a)) (:metaclass foo-metaclass))
(prog1 (slot-value (make-instance 'faa :a 3) 'a)
(cl-test::delete-class 'foo-metaclass 'faa)))))))
;;; Date: 02/03/2006
;;; From: Pascal Costanza
;;; Fixed: 07/03/2006 (juanjo)
;;; Description:
;;;
;;; CLOS should export the symbols from the AMOP.
;;;
(defconstant +mop-symbols+ '("DIRECT-SLOT-DEFINITION"
"EFFECTIVE-SLOT-DEFINITION" "EQL-SPECIALIZER" "FORWARD-REFERENCED-CLASS"
"FUNCALLABLE-STANDARD-CLASS" "FUNCALLABLE-STANDARD-OBJECT" "METAOBJECT"
"SLOT-DEFINITION" "SPECIALIZER" "STANDARD-ACCESSOR-METHOD"
"STANDARD-DIRECT-SLOT-DEFINITION" "STANDARD-EFFECTIVE-SLOT-DEFINITION"
"STANDARD-READER-METHOD" "STANDARD-SLOT-DEFINITION" "STANDARD-WRITER-METHOD"
"ACCESSOR-METHOD-SLOT-DEFINITION" "ADD-DEPENDENT" "ADD-DIRECT-METHOD"
"ADD-DIRECT-SUBCLASS" "CLASS-DEFAULT-INITARGS"
"CLASS-DIRECT-DEFAULT-INITARGS" "CLASS-DIRECT-SLOTS"
"CLASS-DIRECT-SUBCLASSES" "CLASS-DIRECT-SUPERCLASSES" "CLASS-FINALIZED-P"
"CLASS-PRECEDENCE-LIST" "CLASS-PROTOTYPE" "CLASS-SLOTS"
"COMPUTE-APPLICABLE-METHODS-USING-CLASSES" "COMPUTE-CLASS-PRECEDENCE-LIST"
"COMPUTE-DEFAULT-INITARGS" "COMPUTE-DISCRIMINATING-FUNCTION"
"COMPUTE-EFFECTIVE-METHOD" "COMPUTE-EFFECTIVE-SLOT-DEFINITION"
"COMPUTE-SLOTS" "DIRECT-SLOT-DEFINITION-CLASS"
"EFFECTIVE-SLOT-DEFINITION-CLASS" "ENSURE-CLASS" "ENSURE-CLASS-USING-CLASS"
"ENSURE-GENERIC-FUNCTION-USING-CLASS" "EQL-SPECIALIZER-OBJECT"
"EXTRACT-LAMBDA-LIST" "EXTRACT-SPECIALIZER-NAMES" "FINALIZE-INHERITANCE"
"FIND-METHOD-COMBINATION" "FUNCALLABLE-STANDARD-INSTANCE-ACCESS"
"GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER"
"GENERIC-FUNCTION-DECLARATIONS" "GENERIC-FUNCTION-LAMBDA-LIST"
"GENERIC-FUNCTION-METHOD-CLASS" "GENERIC-FUNCTION-METHOD-COMBINATION"
"GENERIC-FUNCTION-METHODS" "GENERIC-FUNCTION-NAME" "INTERN-EQL-SPECIALIZER"
"MAKE-METHOD-LAMBDA" "MAP-DEPENDENTS" "METHOD-FUNCTION"
"METHOD-GENERIC-FUNCTION" "METHOD-LAMBDA-LIST" "METHOD-SPECIALIZERS"
"READER-METHOD-CLASS" "REMOVE-DEPENDENT" "REMOVE-DIRECT-METHOD"
"REMOVE-DIRECT-SUBCLASS" "SET-FUNCALLABLE-INSTANCE-FUNCTION"
"SLOT-BOUNDP-USING-CLASS" "SLOT-DEFINITION-ALLOCATION"
"SLOT-DEFINITION-INITARGS" "SLOT-DEFINITION-INITFORM"
"SLOT-DEFINITION-INITFUNCTION" "SLOT-DEFINITION-LOCATION"
"SLOT-DEFINITION-NAME" "SLOT-DEFINITION-READERS" "SLOT-DEFINITION-WRITERS"
"SLOT-DEFINITION-TYPE" "SLOT-MAKUNBOUND-USING-CLASS"
"SLOT-VALUE-USING-CLASS" "SPECIALIZER-DIRECT-GENERIC-FUNCTIONS"
"SPECIALIZER-DIRECT-METHODS" "STANDARD-INSTANCE-ACCESS" "UPDATE-DEPENDENT"
"VALIDATE-SUPERCLASS" "WRITER-METHOD-CLASS"))
(test mop.0003.amop-symbols
(is-false
(let ((*package* (find-package "CLOS")))
(remove-if #'(lambda (x)
(multiple-value-bind (s to)
(find-symbol x *package*)
(and s (eq to :external))))
+mop-symbols+))))
;;; Date: 02/03/2006
;;; From: Dank Corkill
;;; Fixed: 02-03-2006 (Dan Corkill)
;;; Description:
;;;
;;; DEFCLASS allows additional options which should be handled by the
;;; metaclass.
;;;
;;; Description:
;;;
;;; Readers and writers for slot documentation.
;;;
(test mop.0004.defclass-options
(is
(equal
'(T)
(eval '(let ((*aux* 5))
(declare (special *aux*))
(defclass foo-metaclass (standard-class) ())
(defmethod shared-initialize ((class foo-metaclass) slot-names
&rest initargs &key option)
(prog1 (call-next-method)
(setf *aux* option)))
(defclass faa ()
((a :initform *aux* :initarg :a))
(:metaclass foo-metaclass)
(:option t))
(prog1 (slot-value (make-instance 'faa) 'a)
(cl-test::delete-class 'foo-metaclass 'faa)))))
"DEFCLASS allows additional options which should be handled by ~
the metaclass")
(is
(equal (eval '(progn
(defclass fee ()
((a :initform *aux* :initarg :a)))
(setf (documentation (first (clos:class-slots (find-class 'fee))) t)
#1="hola")
(documentation (first (clos:class-slots (find-class 'fee))) t)))
#1#)
"Readers and writers for slot documentation"))
;;; Date: 25/03/2006
;;; From: Pascal Costanza
;;; Fixed: 03/04/2006 (juanjo)
;;; Description:
;;;
;;; The default slot setter methods had the first argument
;;; (i.e. the new value) specialized to NIL. This makes it
;;; impossible to write further specializations.
;;;
(test mop.0005.setf-specializer
(defclass fee ()
((a :accessor fee-a)))
(is
(equal '(t fee)
(mapcar #'class-name
(clos:method-specializers
(first (clos:generic-function-methods #'(setf fee-a)))))))
(is
(equal '(fee)
(mapcar #'class-name
(clos:method-specializers
(first (clos:generic-function-methods #'fee-a))))))
(delete-class 'fee))
;;; Date: 06/04/2006
;;; From: Pascal Costanza
;;; Fixed: ---
;;; Description:
;;;
;;; When a required argument in a method is not explicitely given
;;; an specializer, the specializer should be T. Thus
;;; (defmethod foo (a))
;;; is equivalent to
;;; (defmethod foo ((a t)))
;;;
(ext:with-clean-symbols (test-method)
(test mop.0006.method-specializer
(defmethod test-method (a))
(is (equal
(mop:method-specializers
(first (mop:generic-function-methods #'test-method)))
(list (find-class t))))
(fmakunbound 'test-method)))
;;; Date: 22/04/2006
;;; From: M. Goffioul
;;; Fixed: 23/04/2006 (juanjo)
;;; Description:
;;;
;;; When a class inherits from two other classes which have a slot
;;; with the same name, the new class should inherit the accessors
;;; from both classes.
;;;
(ext:with-clean-symbols (fee-1 fee-2 fee-3 c-slot-0)
(test mop.0007.slot-inheritance
(defclass fee-1 ()
((slot-0 :initform 0 :reader slot-0)
(slot-1 :initform 1 :reader slot-1)))
(defclass fee-2 ()
((slot-0 :initform 2 :reader slot-2)))
(defclass fee-3 (fee-1 fee-2)
((slot-0 :initform 3 :accessor c-slot-0)))
(flet ((accessors (class)
(list (class-name class)
(mapcar #'clos:slot-definition-readers (clos:class-slots class))
(mapcar #'clos:slot-definition-readers (clos:class-slots class)))))
(is (equal (accessors (find-class 'fee-1))
'(fee-1 ((slot-0) (slot-1)) ((slot-0) (slot-1)))))
(is (equal (accessors (find-class 'fee-2))
'(fee-2 ((slot-2)) ((slot-2)))))
(is (equal (accessors (find-class 'fee-3))
'(fee-3 ((c-slot-0 slot-0 slot-2) (slot-1))
((c-slot-0 slot-0 slot-2) (slot-1)))))
(is (equal (mapcar #'(lambda (o)
(mapcar #'(lambda (method)
(handler-case (funcall method o)
(error (c) nil)))
'(slot-0 slot-2 c-slot-0)))
(mapcar #'make-instance '(fee-1 fee-2 fee-3)))
'((0 nil nil)
(nil 2 nil)
(3 3 3))))
(delete-class 'fee-1 'fee-2 'fee-3))))
;;; Date: 28/04/2006
;;; From: P. Costanza
;;; Fixed: 05/05/2006 (P. Costanza)
;;; Description:
;;;
;;; Option names from classes and generic functions which are not
;;; in the keyword package should be quoted. This test is
;;; essentially like mop.0004... because our DEFGENERIC does not
;;; support non-keyword options.
;;;
(test mop.0008.defclass-option-quote
(eval '(let ((*aux* 5))
(declare (special *aux*))
(defclass foo-metaclass (standard-class) ())
(defmethod shared-initialize ((class foo-metaclass) slot-names
&rest initargs &key ((cl-user::option option)))
(prog1 (call-next-method)
(setf *aux* option)))
(defclass faa ()
((a :initform *aux* :initarg :a))
(:metaclass foo-metaclass)
(cl-user::option t))
(is (equal '(t)
(slot-value (make-instance 'faa) 'a)))
(cl-test::delete-class 'foo-metaclass 'faa))))
;;; Date: 05/10/2006
;;; From: Rick Taube
;;; Fixed: 10/10/2006 (juanjo)
;;; Description:
;;;
;;; :INITFORM arguments do not get properly expanded when the form
;;; is a constant variable.
;;;
;;; (defclass a () ((a :initform most-positive-fixnum)))
;;; (slot-value (make-instance a) 'a) => most-positive-fixnum
;;;
(test mop.0009.defclass-initform
(is (equal
(loop for quoting in '(nil t)
collect
(loop for f in '(most-positive-fixnum #1=#.(lambda () 1) 12 "hola" :a t nil)
collect (prog1 (eval `(progn
(defclass foo ()
((a :initform ,(if quoting (list 'quote f) f))))
(slot-value (make-instance 'foo) 'a)))
(cl-test::delete-class 'foo))))
'((#.most-positive-fixnum #1# 12 "hola" :a t nil)
(most-positive-fixnum #1# 12 "hola" :a t nil)))))
;; Test MOP dependents
(defclass mop-dependent-object ()
((log :initform nil :initarg :log :accessor mop-dependent-object-log)))
(defmethod clos:update-dependent ((object t) (dep mop-dependent-object) &rest initargs)
(push (list* object initargs) (mop-dependent-object-log dep)))
;;; Date: 23/04/2012
;;; Description:
;;;
;;; ADD-DEPENDENT uses pushnew
;;;
(test mop.0010.gf-add/non-redundant
(is-true
(let* ((dep (make-instance 'mop-dependent-object))
l1 l2)
(fmakunbound 'mop-gf-add/remove-dependent)
(defgeneric mop-gf-add/remove-dependent (a))
(let ((f #'mop-gf-add/remove-dependent))
(clos:add-dependent f dep)
(setf l1 (clos::generic-function-dependents f))
(clos:add-dependent f dep)
(setf l2 (clos::generic-function-dependents f))
(and (eq l1 l2)
(equalp l1 (list dep)))))))
;;; Date: 23/04/2012
;;; Description:
;;;
;;; Generic functions have dependents and are activated
;;;
(test mop.0011.gf-add/remove-dependent
(let* ((dep (make-instance 'mop-dependent-object))
l1 l2 l3 l4 l5 l6)
(fmakunbound 'mop-gf-add/remove-dependent)
(defgeneric mop-gf-add/remove-dependent (a))
(let ((f #'mop-gf-add/remove-dependent)
m1 m2)
;;
;; * ADD-DEPENDENT registers the object with the function
;;
(clos:add-dependent f dep)
(setf l1 (clos::generic-function-dependents f))
;;
;; * ADD-METHOD invokes UPDATE-DEPENDENT
;;
(defmethod mop-gf-add/remove-dependent ((a number)) (cos a))
(setf l2 (mop-dependent-object-log dep))
;;
;; * REMOVE-METHOD invokes UPDATE-DEPENDENT
;;
(setf m1 (first (compute-applicable-methods f (list 1.0))))
(remove-method f m1)
(setf l3 (mop-dependent-object-log dep))
;;
;; * REMOVE-DEPENDENT eliminates all dependencies
;;
(clos:remove-dependent f dep)
(setf l4 (clos::generic-function-dependents f))
;;
;; * ADD-METHOD invokes UPDATE-DEPENDENT but has no effect
;;
(defmethod mop-gf-add/remove-dependent ((a symbol)) a)
(setf l5 (mop-dependent-object-log dep))
;;
;; * REMOVE-METHOD invokes UPDATE-DEPENDENT but has no effect
;;
(setf m2 (first (compute-applicable-methods f (list 'a))))
(setf l6 (mop-dependent-object-log dep))
;; the first call to defmethod adds two entries: one for the
;; add-method and another one for a reinitialize-instance with
;; the name of the function
(is-true (equalp l1 (list dep)))
(is-true (eq l2 (rest l3)))
(is-true (equalp l3
(list (list f 'remove-method m1)
(list f 'add-method m1)
(list f))))
(is-true (null l4))
(is-true (eq l5 l3))
(is-true (eq l6 l3)))))
;;; Date: 23/04/2012
;;; Description:
;;;
;;; ADD-DEPENDENT does not duplicate elements
;;;
(test mop.0012.class-add/remove-dependent
(let* ((dep (make-instance 'mop-dependent-object))
l1 l2)
(when (find-class 'mop-class-add/remove-dependent nil)
(setf (class-name (find-class 'mop-class-add/remove-dependent)) nil))
(defclass mop-class-add/remove-dependent () ())
(let ((f (find-class 'mop-class-add/remove-dependent)))
(clos:add-dependent f dep)
(setf l1 (clos::class-dependents f))
(clos:add-dependent f dep)
(setf l2 (clos::class-dependents f))
(is-true
(and (eq l1 l2)
(equalp l1 (list dep)))))))
;;; Date: 23/04/2012
;;; Description:
;;;
;;; Standard classes have dependents and are activated
;;;
(test mop.0013.class-add/remove-dependent
(let* ((dep (make-instance 'mop-dependent-object))
l1 l2 l3 l4 l5)
(when (find-class 'mop-class-add/remove-dependent nil)
(setf (class-name (find-class 'mop-class-add/remove-dependent)) nil))
(defclass mop-class-add/remove-dependent () ())
(let ((f (find-class 'mop-class-add/remove-dependent)))
;;
;; * ADD-DEPENDENT registers the object with the class
;;
(clos:add-dependent f dep)
(setf l1 (clos::class-dependents f))
;;
;; * SHARED-INITIALIZE invokes UPDATE-DEPENDENT
;;
(defclass mop-class-add/remove-dependent () (a))
(setf l2 (clos::class-dependents f))
(setf l3 (mop-dependent-object-log dep))
;;
;; * REMOVE-DEPENDENT eliminates object from list
;;
(clos:remove-dependent f dep)
(setf l4 (clos::class-dependents f))
;;
;; * SHARED-INITIALIZE invokes UPDATE-DEPENDENT without effect
;;
(defclass mop-class-add/remove-dependent () ())
(setf l5 (mop-dependent-object-log dep))
;;
;; the first call to defclass adds one entry with the reinitialization
;; of the class both in name and list of slots
(is-true
(and (equalp l1 (list dep))
(eq l1 l2)
(equalp l3
(list (list f :name 'mop-class-add/remove-dependent
:direct-superclasses nil
:direct-slots '((:name a)))))
(null l4)
(eq l5 l3))))))
;; Test MOP dispatch
;;; Date: 23/04/2012
;;; Description:
;;;
;;; COMPUTE-APPLICABLE-METHODS-USING-CLASSES works with one and
;;; two methods and no EQL.
;;;
(test mop.0014.c-a-m-u-c-two-methods
(fmakunbound 'mop-fn)
(defgeneric mop-fn (a)
(:method ((a number)) (cos a))
(:method ((a symbol)) a))
(let ((m1 (compute-applicable-methods #'mop-fn (list 1.0)))
(m2 (compute-applicable-methods #'mop-fn (list 'a))))
(flet ((f (class)
(multiple-value-list (clos:compute-applicable-methods-using-classes
#'mop-fn (list (find-class class))))))
(is-true
(and (equalp (f 'number) (list m1 t))
(equalp (f 'real) (list m1 t))
(equalp (f 'symbol) (list m2 t))
(equalp (f 'cons) '(nil t)))))))
;;; Date: 23/04/2012
;;; Description:
;;;
;;; COMPUTE-APPLICABLE-METHODS-USING-CLASSES fails with EQL
;;; specializers when one of the specializers is covered by the
;;; classes.
;;;
(test mop.0015.-c-a-m-u-c-fails-with-eql
(fmakunbound 'mop-fn)
(defgeneric mop-fn (a)
(:method ((a (eql 1))) 1)
(:method ((a (eql 'a))) 2)
(:method ((a float)) 3))
(let ((m1 (compute-applicable-methods #'mop-fn (list 1)))
(m2 (compute-applicable-methods #'mop-fn (list 'a)))
(m3 (compute-applicable-methods #'mop-fn (list 1.0))))
(flet ((f (class)
(multiple-value-list (clos:compute-applicable-methods-using-classes
#'mop-fn (list (find-class class))))))
(is-true
(and (equalp (f 'integer) (list nil nil))
(equalp (f 'number) (list nil nil))
(equalp (f 'symbol) (list nil nil))
(equalp (f 'float) (list m3 t))
(= (length m1) 1)
(= (length m2) 1)
(= (length m3) 1))))))
;;; Date: 24/04/2012
;;; Description:
;;;
;;; COMPUTE-DISCRIMINATING-FUNCTION is invoked and honored by ECL.
;;;
(test mop.0016.discriminator
(fmakunbound 'foo)
(defclass my-generic-function (standard-generic-function)
())
(defmethod clos:compute-discriminating-function ((gf my-generic-function))
;; We compute the invocaions of c-d-f. Note that it is invoked
;; quite often -- we could probably optimize this.
#'(lambda (&rest args)
args))
(defgeneric foo (a)
(:generic-function-class my-generic-function))
(is (equal '(2)
(unwind-protect
(foo 2)
(fmakunbound 'foo)))))
;;; Date: 24/04/2012
;;; Description:
;;;
;;; COMPUTE-DISCRIMINATING-FUNCTION is invoked on ADD-METHOD, REMOVE-METHOD,
;;; DEFGENERIC, INITIALIZE-INSTANCE and REINITIALIZE-INSTANCE acting on
;;; generic functions.
;;;
(ext:with-clean-symbols (*mop-discriminator-recomputation* foo my-generic-function)
(test mop.0017.discriminator-recomputation
(defparameter *mop-discriminator-recomputation* 0)
(defclass my-generic-function (standard-generic-function) ())
(defmethod clos:compute-discriminating-function ((gf my-generic-function))
;; We compute the invocaions of c-d-f. Note that it is invoked
;; quite often -- we could probably optimize this.
(incf *mop-discriminator-recomputation*)
(call-next-method))
(is-true
(and (progn
(setf *mop-discriminator-recomputation* 0)
(eval '(defgeneric foo (a)
(:generic-function-class my-generic-function)))
(plusp *mop-discriminator-recomputation* ))
(typep #'foo 'my-generic-function)
(progn
(setf *mop-discriminator-recomputation* 0)
(eval '(defmethod foo ((a number)) (print a)))
(plusp *mop-discriminator-recomputation*))
(progn
(setf *mop-discriminator-recomputation* 0)
(eval '(remove-method #'foo (first (compute-applicable-methods
#'foo
(list 1.0)))))
(plusp *mop-discriminator-recomputation*))))))
;;; Date: 24/04/2012
;;; Description:
;;;
;;; Verify ECL calls COMPUTE-APPLICABLE-METHODS-USING-CLASSES for
;;; user-defined generic function classes.
;;;
(ext:with-clean-symbols (*mop-dispatch-used* my-generic-function foo)
(test mop.0018.c-a-m-u-c-is-honored
(defparameter *mop-dispatch-used* 0)
(defclass my-generic-function (standard-generic-function) ())
(defmethod clos:compute-applicable-methods-using-classes
((gf my-generic-function) classes)
(incf *mop-dispatch-used*)
(call-next-method))
(defgeneric foo (a)
(:generic-function-class my-generic-function)
(:method ((a number)) (cos 1.0)))
(is-true
(and (zerop *mop-dispatch-used*)
(progn (foo 1.0) (plusp *mop-dispatch-used*))))))
;;; Date: 24/04/2012
;;; Description:
;;;
;;; Verify ECL calls COMPUTE-APPLICABLE-METHODS for
;;; user-defined generic function classes.
;;;
(ext:with-clean-symbols (*mop-dispatch-used* my-generic-function foo)
(test mop.0019.compute-applicable-methods-is-honored
(defparameter *mop-dispatch-used* 0)
(defclass my-generic-function (standard-generic-function) ())
(defmethod clos:compute-applicable-methods-using-classes
((gf my-generic-function) classes)
(incf *mop-dispatch-used*)
(values nil nil))
(defmethod compute-applicable-methods
((gf my-generic-function) args)
(incf *mop-dispatch-used*)
(call-next-method))
(defgeneric foo (a)
(:generic-function-class my-generic-function)
(:method ((a number)) (cos 1.0)))
(is-true
(and (zerop *mop-dispatch-used*)
(progn (foo 1.0) (= *mop-dispatch-used* 2))))))
;;; From: Pascal Costanza
;;; Description:
;;;
;;; sort-applicable-methods is invoked by two methods and one
;;; invocation triggers a disambiguation error:
;;;
;;; Condition of type: SIMPLE-ERROR
;;; The type specifiers #<The STANDARD-CLASS COMMON-LISP-USER::B> and #<The STANDARD-CLASS COMMON-LISP-USER::A> can not be disambiguated with respect to the argument specializer: #<The STANDARD-CLASS STANDARD-CLASS>
(ext:with-clean-symbols (a b c f)
(defclass a () ())
(defclass b () ())
(defclass c (a b) ())
(defmethod f ((o a)))
(defmethod f ((o b)))
(test mop.0020.c-a-m-disambiguation
(finishes
(clos:compute-applicable-methods-using-classes
#'f (list (find-class 'c))))))

176
src/tests/regressions/mixed.lsp Normal file
View file

@ -0,0 +1,176 @@
;;;; -*- 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 'regressions/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)")))

382
src/tests/regressions/tests/multiprocessing.lsp → src/tests/regressions/multiprocessing.lsp
View file

@ -7,6 +7,8 @@
(in-package :cl-test)
(suite 'regressions/mp)
;; Auxiliary routines for multithreaded tests
@ -39,9 +41,10 @@ creating stray processes."
(let ((all-processes (gensym))
(output (gensym))
(leftover (gensym)))
`(deftest ,name
(mp-test-run #'(lambda () ,body))
,expected-value)))
`(test ,name
(is-equal
(mp-test-run #'(lambda () ,body))
,expected-value))))
;; Locks
@ -54,7 +57,7 @@ creating stray processes."
;;; When a WITH-LOCK is interrupted, it is not able to release
;;; the resulting lock and an error is signaled.
;;;
(def-mp-test mp-0001-with-lock
(test mp-0001-with-lock
(let ((flag t)
(lock (mp:make-lock :name "mp-0001-with-lock" :recursive nil)))
(mp:with-lock (lock)
@ -76,38 +79,35 @@ creating stray processes."
;; and the process should gracefully quit, without
;; signalling any serious condition
(and (progn (sleep 1)
(mp:process-kill background-process))
(is (mp:process-kill background-process)))
(progn (sleep 1)
(not (mp:process-active-p background-process)))
(eq flag 1)
t))))
t)
(is (not (mp:process-active-p background-process))))
(is (eq flag 1)))))))
;; Semaphores
;;; Date: 14/04/2012
;;; Ensure that at creation name and counter are set
(deftest sem-make-and-counter
(loop with name = "sem-make-and-counter"
for count from 0 to 10
for sem = (mp:make-semaphore :name name :count count)
always (and (eq (mp:semaphore-name sem) name)
(= (mp:semaphore-count sem) count)
(zerop (mp:semaphore-wait-count sem))))
t)
(test sem-make-and-counter
(is (loop with name = "sem-make-and-counter"
for count from 0 to 10
for sem = (mp:make-semaphore :name name :count count)
always (and (eq (mp:semaphore-name sem) name)
(= (mp:semaphore-count sem) count)
(zerop (mp:semaphore-wait-count sem))))))
;;; Date: 14/04/2012
;;; Ensure that signal changes the counter by the specified amount
(deftest sem-signal-semaphore-count
(loop with name = "sem-signal-semaphore-count"
for count from 0 to 10
always (loop for delta from 0 to 10
for sem = (mp:make-semaphore :name name :count count)
always (and (= (mp:semaphore-count sem) count)
(null (mp:signal-semaphore sem delta))
(= (mp:semaphore-count sem ) (+ count delta)))))
t)
(test sem-signal-semaphore-count
(is
(loop with name = "sem-signal-semaphore-count"
for count from 0 to 10
always (loop for delta from 0 to 10
for sem = (mp:make-semaphore :name name :count count)
always (and (= (mp:semaphore-count sem) count)
(null (mp:signal-semaphore sem delta))
(= (mp:semaphore-count sem ) (+ count delta)))))))
;;; Date: 14/04/2012
;;; A semaphore with a count of zero blocks a process
@ -127,51 +127,51 @@ creating stray processes."
;;; Date: 14/04/2012
;;; We can signal multiple processes
(def-mp-test sem-signal-n-processes
(loop for count from 1 upto 10 always
(let* ((counter 0)
(lock (mp:make-lock :name "sem-signal-n-processes"))
(sem (mp:make-semaphore :name "sem-signal-n-processs"))
(all-process
(loop for i from 1 upto count
collect (mp:process-run-function
"sem-signal-n-processes"
#'(lambda ()
(mp:wait-on-semaphore sem)
(mp:with-lock (lock) (incf counter)))))))
(and (zerop counter)
(every #'mp:process-active-p all-process)
(= (mp:semaphore-wait-count sem) count)
(progn (mp:signal-semaphore sem count) (sleep 0.2)
(= counter count))
(= (mp:semaphore-count sem) 0))))
t)
(test sem-signal-n-processes
(loop for count from 1 upto 10 always
(let* ((counter 0)
(lock (mp:make-lock :name "sem-signal-n-processes"))
(sem (mp:make-semaphore :name "sem-signal-n-processs"))
(all-process
(loop for i from 1 upto count
collect (mp:process-run-function
"sem-signal-n-processes"
#'(lambda ()
(mp:wait-on-semaphore sem)
(mp:with-lock (lock) (incf counter)))))))
(and (is (zerop counter))
(is (every #'mp:process-active-p all-process))
(is (= (mp:semaphore-wait-count sem) count))
(is (progn (mp:signal-semaphore sem count)
(sleep 0.2)
(= counter count)))
(is (= (mp:semaphore-count sem) 0))))))
;;; Date: 14/04/2012
;;; When we signal N processes and N+M are waiting, only N awake
(def-mp-test sem-signal-only-n-processes
(loop for m from 1 upto 3 always
(loop for n from 1 upto 4 always
(let* ((counter 0)
(lock (mp:make-lock :name "sem-signal-n-processes"))
(sem (mp:make-semaphore :name "sem-signal-n-processs"))
(all-process
(loop for i from 1 upto (+ n m)
collect (mp:process-run-function
"sem-signal-n-processes"
#'(lambda ()
(mp:wait-on-semaphore sem)
(mp:with-lock (lock) (incf counter)))))))
(and (zerop counter)
(every #'mp:process-active-p all-process)
(= (mp:semaphore-wait-count sem) (+ m n))
(progn (mp:signal-semaphore sem n) (sleep 0.02)
(= counter n))
(= (mp:semaphore-wait-count sem) m)
(progn (mp:signal-semaphore sem m) (sleep 0.02)
(= counter (+ n m)))
))))
t)
(test sem-signal-only-n-processes
(loop for m from 1 upto 3 always
(loop for n from 1 upto 4 always
(let* ((counter 0)
(lock (mp:make-lock :name "sem-signal-n-processes"))
(sem (mp:make-semaphore :name "sem-signal-n-processs"))
(all-process
(loop for i from 1 upto (+ n m)
collect (mp:process-run-function
"sem-signal-n-processes"
#'(lambda ()
(mp:wait-on-semaphore sem)
(mp:with-lock (lock) (incf counter)))))))
(and (is (zerop counter))
(is (every #'mp:process-active-p all-process))
(is (= (mp:semaphore-wait-count sem) (+ m n)))
(is (progn (mp:signal-semaphore sem n)
(sleep 0.02)
(= counter n)))
(is (= (mp:semaphore-wait-count sem) m))
(is (progn (mp:signal-semaphore sem m)
(sleep 0.02)
(= counter (+ n m)))))))))
;;; Date: 14/04/2012
;;; It is possible to kill processes waiting for a semaphore.
@ -220,41 +220,39 @@ creating stray processes."
;;; killed, but the process must still be in the queue for the semaphore
;;; to awake it. The way we solve this is by intercepting the kill signal.
;;;
(def-mp-test sem-interrupted-resignals
(let* ((sem (mp:make-semaphore :name "sem-interrupted-resignals"))
(flag1 nil)
(flag2 nil)
(process1 (mp:process-run-function
"sem-interrupted-resignals"
#'(lambda ()
(unwind-protect
(mp:wait-on-semaphore sem)
(sleep 4)
(setf flag1 t)
))))
(process2 (mp:process-run-function
"sem-interrupted-resignals"
#'(lambda ()
(mp:wait-on-semaphore sem)
(setf flag2 t)))))
(sleep 0.2)
(and (= (mp:semaphore-wait-count sem) 2)
(mp:process-active-p process1)
(mp:process-active-p process2)
;; We kill the process but ensure it is still running
(progn (mp:process-kill process1)
(mp:process-active-p process1))
(null flag1)
;; ... and in the queue
(= (mp:semaphore-wait-count sem) 2)
;; We awake it and it should awake the other one
(progn (format t "~%;;; Signaling semaphore")
(mp:signal-semaphore sem)
(sleep 1)
(zerop (mp:semaphore-wait-count sem)))
flag2
t))
t)
(test sem-interrupted-resignals
(let* ((sem (mp:make-semaphore :name "sem-interrupted-resignals"))
(flag1 nil)
(flag2 nil)
(process1 (mp:process-run-function
"sem-interrupted-resignals"
#'(lambda ()
(unwind-protect
(mp:wait-on-semaphore sem)
(sleep 4)
(setf flag1 t)
))))
(process2 (mp:process-run-function
"sem-interrupted-resignals"
#'(lambda ()
(mp:wait-on-semaphore sem)
(setf flag2 t)))))
(sleep 0.2)
(and (is (= (mp:semaphore-wait-count sem) 2))
(is (mp:process-active-p process1))
(is (mp:process-active-p process2))
;; We kill the process but ensure it is still running
(is (progn (mp:process-kill process1)
(mp:process-active-p process1)))
(is (null flag1))
;; ... and in the queue
(is (= (mp:semaphore-wait-count sem) 2))
;; We awake it and it should awake the other one
(is (progn (format t "~%;;; Signaling semaphore")
(mp:signal-semaphore sem)
(sleep 1)
(zerop (mp:semaphore-wait-count sem))))
(is flag2))))
;;; Date: 14/04/2012
;;; 1 producer and N consumers, non-blocking, because the initial count
@ -310,37 +308,35 @@ creating stray processes."
;;; Date: 12/04/2012
;;; Non-recursive mutexes should signal an error when they
;;; cannot be relocked.
(deftest mutex-001-recursive-error
(let* ((mutex (mp:make-lock :name 'mutex-001-recursive-error)))
(and
(mp:get-lock mutex)
(eq (mp:lock-owner mutex) mp:*current-process*)
(handler-case
(progn (mp:get-lock mutex) nil)
(error (c) t))
(mp:giveup-lock mutex)
(null (mp:lock-owner mutex))
(zerop (mp:lock-count mutex))
t))
t)
(test mutex-001-recursive-error
(is-true
(let* ((mutex (mp:make-lock :name 'mutex-001-recursive-error)))
(and
(mp:get-lock mutex)
(eq (mp:lock-owner mutex) mp:*current-process*)
(handler-case
(progn (mp:get-lock mutex) nil)
(error (c) t))
(mp:giveup-lock mutex)
(null (mp:lock-owner mutex))
(zerop (mp:lock-count mutex))))))
;;; Date: 12/04/2012
;;; Recursive locks increase the counter.
(deftest mutex-002-recursive-count
(let* ((mutex (mp:make-lock :name 'mutex-002-recursive-count :recursive t)))
(and
(loop for i from 1 upto 10
always (and (mp:get-lock mutex)
(= (mp:lock-count mutex) i)
(eq (mp:lock-owner mutex) mp:*current-process*)))
(loop for i from 9 downto 0
always (and (eq (mp:lock-owner mutex) mp:*current-process*)
(mp:giveup-lock mutex)
(= (mp:lock-count mutex) i)))
(null (mp:lock-owner mutex))
(zerop (mp:lock-count mutex))
t))
t)
(test mutex-002-recursive-count
(is-true
(let* ((mutex (mp:make-lock :name 'mutex-002-recursive-count :recursive t)))
(and
(loop for i from 1 upto 10
always (and (mp:get-lock mutex)
(= (mp:lock-count mutex) i)
(eq (mp:lock-owner mutex) mp:*current-process*)))
(loop for i from 9 downto 0
always (and (eq (mp:lock-owner mutex) mp:*current-process*)
(mp:giveup-lock mutex)
(= (mp:lock-count mutex) i)))
(null (mp:lock-owner mutex))
(zerop (mp:lock-count mutex))))))
;;; Date: 12/04/2012
@ -415,36 +411,34 @@ creating stray processes."
;;; Date: 14/04/2012
;;; Ensure that at creation name and counter are set, and mailbox is empty.
(deftest mailbox-make-and-counter
(loop with name = "mbox-make-and-counter"
for count from 4 to 63
for mbox = (mp:make-mailbox :name name :count count)
always (and (eq (mp:mailbox-name mbox) name)
(>= (mp:mailbox-count mbox) count)
(mp:mailbox-empty-p mbox)
t))
t)
(test mailbox-make-and-counter
(is
(loop with name = "mbox-make-and-counter"
for count from 4 to 63
for mbox = (mp:make-mailbox :name name :count count)
always (and (eq (mp:mailbox-name mbox) name)
(>= (mp:mailbox-count mbox) count)
(mp:mailbox-empty-p mbox)))))
;;; Date: 14/04/2012
;;; Ensure that the mailbox works in a nonblocking fashion (when the
;;; number of messages < mailbox size in a single producer and single
;;; consumer setting. We do not need to create new threads for this.
(deftest mbox-mailbox-nonblocking-io-1-to-1
(loop with count = 30
with name = "mbox-mailbox-nonblocking-io-1-to-1"
with mbox = (mp:make-mailbox :name name :count count)
for l from 1 to 10
for messages = (loop for i from 1 to l
do (mp:mailbox-send mbox i)
collect i)
always
(and (not (mp:mailbox-empty-p mbox))
(equalp (loop for i from 1 to l
collect (mp:mailbox-read mbox))
messages)
(mp:mailbox-empty-p mbox)
t))
t)
(test mbox-mailbox-nonblocking-io-1-to-1
(is
(loop with count = 30
with name = "mbox-mailbox-nonblocking-io-1-to-1"
with mbox = (mp:make-mailbox :name name :count count)
for l from 1 to 10
for messages = (loop for i from 1 to l
do (mp:mailbox-send mbox i)
collect i)
always
(and (not (mp:mailbox-empty-p mbox))
(equalp (loop for i from 1 to l
collect (mp:mailbox-read mbox))
messages)
(mp:mailbox-empty-p mbox)))))
;;; Date: 14/04/2012
;;; The mailbox blocks a process when it saturates the write queue.
@ -501,48 +495,46 @@ creating stray processes."
;;; Date: 14/04/2012
;;; 1 producer and N consumer, but they do not block, because the
;;; queue is large enough and pre-filled with messages
(def-mp-test mbox-1-to-n-non-blocking
(loop with lock = (mp:make-lock :name "mbox-1-to-n-communication")
for n from 1 to 10
for m = (round 128 n)
for length = (* n m)
for mbox = (mp:make-mailbox :name "mbox-1-to-n-communication" :count length)
for flags = (make-array length :initial-element nil)
for aux = (loop for i from 0 below length
do (mp:mailbox-send mbox i))
for producers = (loop for i from 0 below n
do (mp:process-run-function
"mbox-1-to-n-consumer"
#'(lambda ()
(loop for i from 0 below m
for msg = (mp:mailbox-read mbox)
do (setf (aref flags msg) t)))))
do (sleep 0.1)
always (and (every #'identity flags)
(mp:mailbox-empty-p mbox)))
t)
(test mbox-1-to-n-non-blocking
(loop with lock = (mp:make-lock :name "mbox-1-to-n-communication")
for n from 1 to 10
for m = (round 128 n)
for length = (* n m)
for mbox = (mp:make-mailbox :name "mbox-1-to-n-communication" :count length)
for flags = (make-array length :initial-element nil)
for aux = (loop for i from 0 below length
do (mp:mailbox-send mbox i))
for producers = (loop for i from 0 below n
do (mp:process-run-function
"mbox-1-to-n-consumer"
#'(lambda ()
(loop for i from 0 below m
for msg = (mp:mailbox-read mbox)
do (setf (aref flags msg) t)))))
do (sleep 0.1)
always (and (is (every #'identity flags))
(is (mp:mailbox-empty-p mbox)))))
;;; Date: 14/04/2012
;;; 1 producer and N consumers, which block, because the producer
;;; is started _after_ them and is slower.
(def-mp-test mbox-1-to-n-blocking
(loop for n from 1 to 10
for m = (round 10000 n)
for length = (* n m)
for mbox = (mp:make-mailbox :name "mbox-1-to-n-communication" :count length)
for flags = (make-array length :initial-element nil)
for producers = (loop for i from 0 below n
do (mp:process-run-function
"mbox-1-to-n-consumer"
#'(lambda ()
(loop for i from 0 below m
for msg = (mp:mailbox-read mbox)
do (setf (aref flags msg) t)))))
do (loop for i from 0 below length
do (mp:mailbox-send mbox i))
do (sleep 0.1)
always (and (every #'identity flags)
(mp:mailbox-empty-p mbox)))
t)
(test mbox-1-to-n-blocking
(loop for n from 1 to 10
for m = (round 10000 n)
for length = (* n m)
for mbox = (mp:make-mailbox :name "mbox-1-to-n-communication" :count length)
for flags = (make-array length :initial-element nil)
for producers = (loop for i from 0 below n
do (mp:process-run-function
"mbox-1-to-n-consumer"
#'(lambda ()
(loop for i from 0 below m
for msg = (mp:mailbox-read mbox)
do (setf (aref flags msg) t)))))
do (loop for i from 0 below length
do (mp:mailbox-send mbox i))
do (sleep 0.1)
always (and (is (every #'identity flags))
(is (mp:mailbox-empty-p mbox)))))

1183
src/tests/regressions/tests/compiler.lsp
View file

File diff suppressed because it is too large Load diff

119
src/tests/regressions/tests/foreign-interface.lsp
View file

@ -1,119 +0,0 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*-
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
;;;; Author: Juan Jose Garcia-Ripoll
;;;; Author: Daniel Kochmański
;;;; Created: Fri Apr 14 11:13:17 CEST 2006
;;;; Contains: Foreign Function Interface regression tests
(in-package :cl-test)
;;; Date: 23/03/2006
;;; From: Klaus Falb
;;; Fixed: 26/02/2006 (juanjo)
;;; Description:
;;;
;;; Callback functions have to be declared static so that there
;;; are no conflicts among callbacks in different files.
;;;
;;; Fixed: 13/04/2006 (juanjo)
;;; Description:
;;;
;;; Header <internal.h> should be included as <ecl/internal.h>
;;;
(deftest foreign-interface.0001.callback
(and
(zerop (si::system "rm -rf tmp; mkdir tmp"))
(with-open-file (s "tmp/a.lsp" :direction :output
:if-exists :supersede
:if-does-not-exist :create)
(print '(ffi:defcallback foo :void () nil) s))
(with-open-file (s "tmp/b.lsp" :direction :output
:if-exists :supersede
:if-does-not-exist :create)
(print '(ffi:defcallback foo :void () nil) s))
(compile-file "tmp/a.lsp" :system-p t)
(compile-file "tmp/b.lsp" :system-p t)
(c:build-program "tmp/foo" :lisp-files
(list (compile-file-pathname "tmp/a.lsp" :type :object)
(compile-file-pathname "tmp/b.lsp" :type :object)))
(probe-file (compile-file-pathname "tmp/foo" :type :program))
(zerop (si::system "rm -rf tmp"))
t)
t)
;;; Date: 29/07/2008
;;; From: Juajo
;;; Description:
;;; Callback examples based on the C compiler
;;;
(deftest foreign-interface.0002.callback
(and
(zerop (si::system "rm -rf tmp; mkdir tmp"))
(with-open-file (s "tmp/c.lsp" :direction :output
:if-exists :supersede
:if-does-not-exist :create)
(print
'(defun callback-user (callback arg)
(ffi:c-inline (callback arg) (:pointer-void :int) :int "
int (*foo)(int) = #0;
@(return) = foo(#1);
"
:one-liner nil :side-effects nil))
s)
(print
'(ffi:defcallback ffi-002-foo :int ((a :int))
(1+ a))
s))
(compile-file "tmp/c.lsp" :load t)
(eql (callback-user (ffi:callback 'ffi-002-foo) 2) 3)
t)
t)
;;; Date: 29/07/2008
;;; From: Juajo
;;; Description:
;;; Callback examples based on the DFFI. Only work if this feature
;;; has been linked in.
;;;
#+dffi
(deftest foreign-interface.0003.callback
(and
(zerop (si::system "rm -rf tmp; mkdir tmp"))
(with-open-file (s "tmp/c.lsp" :direction :output
:if-exists :supersede
:if-does-not-exist :create)
(print
'(defun callback-user (callback arg)
(ffi:c-inline (callback arg) (:pointer-void :int) :int "
int (*foo)(int) = #0;
@(return) = foo(#1);
"
:one-liner nil :side-effects nil))
s))
(compile-file "tmp/c.lsp" :load t)
(eval '(ffi:defcallback foo-002b :int ((a :int))
(1+ a)))
(eql (callback-user (ffi:callback 'foo-002b) 2) 3)
t)
t)
;;; Date: 25/04/2010 (Juanjo)
;;; Description:
;;; Regression test to ensure that two foreign data compare
;;; EQUAL when their addresses are the same.
(deftest foreign-interface.0004.foreign-data-equal
(equal (ffi:make-pointer 1234 :void)
(ffi:make-pointer 1234 :int))
t)
;;; Date: 2016-01-04 (jackdaniel)
;;; Description:
;;; Regression test to ensure, that the string is properly
;;; recognized as an array
(deftest foreign-interface.0004
(progn
(si::make-foreign-data-from-array "dan")
t)
t)

638
src/tests/regressions/tests/metaobject-protocol.lsp
View file

@ -1,638 +0,0 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*-
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
;;;; Author: Juan Jose Garcia-Ripoll
;;;; Author: Daniel Kochmański
;;;; Created: Fri Apr 14 11:13:17 CEST 2006
;;;; Contains: Metaobject Protocol tests
(in-package :cl-test)
(use-package :clos)
;; mop-001
(defun delete-class (&rest class-names)
;;; do nothing. We will figure out later what to do.
(values))
;;; Fixed: 14/04/2006 (juanjo)
;;; Description:
;;;
;;; The slot definitions from some classes did not get converted.
;;; Besides, metaobject CLASS had the same list for direct and effective
;;; slots.
;;;
(deftest mop-0001-fixup
(block top
(labels ((test-class (class-object)
(let ((x (find-if-not #'(lambda (x)
(typep x 'standard-direct-slot-definition))
(class-direct-slots class-object))))
(when x
(format t "Class ~a has as direct slot ~a" class-object x)
(return-from top (class-name class-object))))
(let ((x (find-if-not #'(lambda (x)
(typep x 'standard-effective-slot-definition))
(class-slots class-object))))
(when x
(format t "Class ~a has as effective slot ~a" class-object x)
(return-from top (class-name class-object))))
(mapc #'test-class (clos::class-direct-subclasses class-object))))
(test-class (find-class 't))
nil))
nil)
;;; Date: 13/02/2006
;;; From: Dan Debertin
;;; Fixed: 24-02-2006 (juanjo)
;;; Description:
;;;
;;; Subclasses of STANDARD-CLASS would not inherit all their slots
;;; and thus would cause runtime errors when creating instances.
;;;
(deftest mop-0002-metaclasses
(eval '(progn
(defclass foo-metaclass (standard-class) ())
(defclass faa () ((a :initform 2 :initarg :a)) (:metaclass foo-metaclass))
(prog1 (slot-value (make-instance 'faa :a 3) 'a)
(cl-test::delete-class 'foo-metaclass 'faa))))
3)
;;; Date: 02/03/2006
;;; From: Pascal Costanza
;;; Fixed: 07/03/2006 (juanjo)
;;; Description:
;;;
;;; CLOS should export the symbols from the AMOP.
;;;
(defconstant +mop-symbols+ '("DIRECT-SLOT-DEFINITION"
"EFFECTIVE-SLOT-DEFINITION" "EQL-SPECIALIZER" "FORWARD-REFERENCED-CLASS"
"FUNCALLABLE-STANDARD-CLASS" "FUNCALLABLE-STANDARD-OBJECT" "METAOBJECT"
"SLOT-DEFINITION" "SPECIALIZER" "STANDARD-ACCESSOR-METHOD"
"STANDARD-DIRECT-SLOT-DEFINITION" "STANDARD-EFFECTIVE-SLOT-DEFINITION"
"STANDARD-READER-METHOD" "STANDARD-SLOT-DEFINITION" "STANDARD-WRITER-METHOD"
"ACCESSOR-METHOD-SLOT-DEFINITION" "ADD-DEPENDENT" "ADD-DIRECT-METHOD"
"ADD-DIRECT-SUBCLASS" "CLASS-DEFAULT-INITARGS"
"CLASS-DIRECT-DEFAULT-INITARGS" "CLASS-DIRECT-SLOTS"
"CLASS-DIRECT-SUBCLASSES" "CLASS-DIRECT-SUPERCLASSES" "CLASS-FINALIZED-P"
"CLASS-PRECEDENCE-LIST" "CLASS-PROTOTYPE" "CLASS-SLOTS"
"COMPUTE-APPLICABLE-METHODS-USING-CLASSES" "COMPUTE-CLASS-PRECEDENCE-LIST"
"COMPUTE-DEFAULT-INITARGS" "COMPUTE-DISCRIMINATING-FUNCTION"
"COMPUTE-EFFECTIVE-METHOD" "COMPUTE-EFFECTIVE-SLOT-DEFINITION"
"COMPUTE-SLOTS" "DIRECT-SLOT-DEFINITION-CLASS"
"EFFECTIVE-SLOT-DEFINITION-CLASS" "ENSURE-CLASS" "ENSURE-CLASS-USING-CLASS"
"ENSURE-GENERIC-FUNCTION-USING-CLASS" "EQL-SPECIALIZER-OBJECT"
"EXTRACT-LAMBDA-LIST" "EXTRACT-SPECIALIZER-NAMES" "FINALIZE-INHERITANCE"
"FIND-METHOD-COMBINATION" "FUNCALLABLE-STANDARD-INSTANCE-ACCESS"
"GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER"
"GENERIC-FUNCTION-DECLARATIONS" "GENERIC-FUNCTION-LAMBDA-LIST"
"GENERIC-FUNCTION-METHOD-CLASS" "GENERIC-FUNCTION-METHOD-COMBINATION"
"GENERIC-FUNCTION-METHODS" "GENERIC-FUNCTION-NAME" "INTERN-EQL-SPECIALIZER"
"MAKE-METHOD-LAMBDA" "MAP-DEPENDENTS" "METHOD-FUNCTION"
"METHOD-GENERIC-FUNCTION" "METHOD-LAMBDA-LIST" "METHOD-SPECIALIZERS"
"READER-METHOD-CLASS" "REMOVE-DEPENDENT" "REMOVE-DIRECT-METHOD"
"REMOVE-DIRECT-SUBCLASS" "SET-FUNCALLABLE-INSTANCE-FUNCTION"
"SLOT-BOUNDP-USING-CLASS" "SLOT-DEFINITION-ALLOCATION"
"SLOT-DEFINITION-INITARGS" "SLOT-DEFINITION-INITFORM"
"SLOT-DEFINITION-INITFUNCTION" "SLOT-DEFINITION-LOCATION"
"SLOT-DEFINITION-NAME" "SLOT-DEFINITION-READERS" "SLOT-DEFINITION-WRITERS"
"SLOT-DEFINITION-TYPE" "SLOT-MAKUNBOUND-USING-CLASS"
"SLOT-VALUE-USING-CLASS" "SPECIALIZER-DIRECT-GENERIC-FUNCTIONS"
"SPECIALIZER-DIRECT-METHODS" "STANDARD-INSTANCE-ACCESS" "UPDATE-DEPENDENT"
"VALIDATE-SUPERCLASS" "WRITER-METHOD-CLASS"))
(deftest mop-0003-symbols
(let ((*package* (find-package "CLOS")))
(and (remove-if #'(lambda (x)
(multiple-value-bind (s t)
(find-symbol x *package*)
(and s (eq t :external))))
+mop-symbols+)
t))
nil)
;;; Date: 02/03/2006
;;; From: Dank Corkill
;;; Fixed: 02-03-2006 (Dan Corkill)
;;; Description:
;;;
;;; DEFCLASS allows additional options which should be handled by the
;;; metaclass.
;;;
(deftest mop-0004-defclass-options
(eval '(let ((*aux* 5))
(declare (special *aux*))
(defclass foo-metaclass (standard-class) ())
(defmethod shared-initialize ((class foo-metaclass) slot-names
&rest initargs &key option)
(prog1 (call-next-method)
(setf *aux* option)))
(defclass faa ()
((a :initform *aux* :initarg :a))
(:metaclass foo-metaclass)
(:option t))
(prog1 (slot-value (make-instance 'faa) 'a)
(cl-test::delete-class 'foo-metaclass 'faa))))
(T))
;;; Date: 02/03/2006
;;; From: Dank Corkill
;;; Fixed: 02-03-2006 (Dan Corkill)
;;; Description:
;;;
;;; Readers and writers for slot documentation.
;;;
(deftest mop-0004b-slot-documentation
(eval '(progn
(defclass fee ()
((a :initform *aux* :initarg :a)))
(setf (documentation (first (clos:class-slots (find-class 'fee))) t)
#1="hola")
(documentation (first (clos:class-slots (find-class 'fee))) t)))
#1#)
;;; Date: 25/03/2006
;;; From: Pascal Costanza
;;; Fixed: 03/04/2006 (juanjo)
;;; Description:
;;;
;;; The default slot setter methods had the first argument
;;; (i.e. the new value) specialized to NIL. This makes it
;;; impossible to write further specializations.
;;;
(deftest mop-0005-setf-specializer
(progn
(defclass fee ()
((a :accessor fee-a)))
(prog1
(list
(mapcar #'class-name
(method-specializers (first (generic-function-methods #'(setf fee-a)))))
(mapcar #'class-name
(method-specializers (first (generic-function-methods #'fee-a)))))
(delete-class 'fee)))
((t fee) (fee)))
;;; Date: 06/04/2006
;;; From: Pascal Costanza
;;; Fixed: ---
;;; Description:
;;;
;;; When a required argument in a method is not explicitely given
;;; an specializer, the specializer should be T. Thus
;;; (defmethod foo (a))
;;; is equivalent to
;;; (defmethod foo ((a t)))
;;;
(deftest mop-0006-method-specializer
(progn
(defmethod mop-0006-foo (a))
(prog1
(method-specializers (first (generic-function-methods #'mop-0006-foo)))
(fmakunbound 'mop-0006-foo)))
(#.(find-class t)))
;;; Date: 22/04/2006
;;; From: M. Goffioul
;;; Fixed: 23/04/2006 (juanjo)
;;; Description:
;;;
;;; When a class inherits from two other classes which have a slot
;;; with the same name, the new class should inherit the accessors
;;; from both classes.
;;;
(deftest mop-0007-slot-inheritance
(progn
(defclass fee-1 ()
((slot-0 :initform 0 :reader slot-0)
(slot-1 :initform 1 :reader slot-1)))
(defclass fee-2 ()
((slot-0 :initform 2 :reader slot-2)))
(defclass fee-3 (fee-1 fee-2)
((slot-0 :initform 3 :accessor c-slot-0)))
(flet ((accessors (class)
(list (class-name class)
(mapcar #'slot-definition-readers (class-slots class))
(mapcar #'slot-definition-readers (class-slots class)))))
(prog1
(list (accessors (find-class 'fee-1))
(accessors (find-class 'fee-2))
(accessors (find-class 'fee-3))
(mapcar #'(lambda (o)
(mapcar #'(lambda (method)
(handler-case (funcall method o)
(error (c) nil)))
'(slot-0 slot-2 c-slot-0)))
(mapcar #'make-instance '(fee-1 fee-2 fee-3))))
(delete-class 'fee-1 'fee-2 'fee-3))))
((fee-1 ((slot-0) (slot-1)) ((slot-0) (slot-1)))
(fee-2 ((slot-2)) ((slot-2)))
(fee-3 ((c-slot-0 slot-0 slot-2) (slot-1))
((c-slot-0 slot-0 slot-2) (slot-1)))
((0 nil nil)
(nil 2 nil)
(3 3 3))))
;;; Date: 28/04/2006
;;; From: P. Costanza
;;; Fixed: 05/05/2006 (P. Costanza)
;;; Description:
;;;
;;; Option names from classes and generic functions which are not
;;; in the keyword package should be quoted. This test is
;;; essentially like mop-0004-... because our DEFGENERIC does not
;;; support non-keyword options.
;;;
(deftest mop-0008-defclass-option-quote
(eval '(let ((*aux* 5))
(declare (special *aux*))
(defclass foo-metaclass (standard-class) ())
(defmethod shared-initialize ((class foo-metaclass) slot-names
&rest initargs &key ((cl-user::option option)))
(prog1 (call-next-method)
(setf *aux* option)))
(defclass faa ()
((a :initform *aux* :initarg :a))
(:metaclass foo-metaclass)
(cl-user::option t))
(prog1 (slot-value (make-instance 'faa) 'a)
(cl-test::delete-class 'foo-metaclass 'faa))))
(t))
;;; Date: 05/10/2006
;;; From: Rick Taube
;;; Fixed: 10/10/2006 (juanjo)
;;; Description:
;;;
;;; :INITFORM arguments do not get properly expanded when the form
;;; is a constant variable.
;;;
;;; (defclass a () ((a :initform most-positive-fixnum)))
;;; (slot-value (make-instance a) 'a) => most-positive-fixnum
;;;
(deftest mop-0009-defclass-initform
(loop for quoting in '(nil t)
collect
(loop for f in '(most-positive-fixnum #1=#.(lambda () 1) 12 "hola" :a t nil)
collect (prog1 (eval `(progn
(defclass foo () ((a :initform ,(if quoting (list 'quote f) f))))
(slot-value (make-instance 'foo) 'a)))
(cl-test::delete-class 'foo))))
((#.most-positive-fixnum #1# 12 "hola" :a t nil)
(most-positive-fixnum #1# 12 "hola" :a t nil)))
;; Test MOP dependents
(defclass mop-dependent-object ()
((log :initform nil :initarg :log :accessor mop-dependent-object-log)))
(defmethod update-dependent ((object t) (dep mop-dependent-object) &rest initargs)
(push (list* object initargs) (mop-dependent-object-log dep)))
;;; Date: 23/04/2012
;;; Description:
;;;
;;; ADD-DEPENDENT uses pushnew
;;;
(deftest mop-gf-add-non-redundant
(let* ((dep (make-instance 'mop-dependent-object))
l1 l2)
(fmakunbound 'mop-gf-add/remove-dependent)
(defgeneric mop-gf-add/remove-dependent (a))
(let ((f #'mop-gf-add/remove-dependent))
(clos:add-dependent f dep)
(setf l1 (clos::generic-function-dependents f))
(clos:add-dependent f dep)
(setf l2 (clos::generic-function-dependents f))
(and (eq l1 l2)
(equalp l1 (list dep))
t)))
t)
;;; Date: 23/04/2012
;;; Description:
;;;
;;; Generic functions have dependents and are activated
;;;
(deftest mop-gf-add/remove-dependent
(let* ((dep (make-instance 'mop-dependent-object))
l1 l2 l3 l4 l5 l6)
(fmakunbound 'mop-gf-add/remove-dependent)
(defgeneric mop-gf-add/remove-dependent (a))
(let ((f #'mop-gf-add/remove-dependent)
m1 m2)
;;
;; * ADD-DEPENDENT registers the object with the function
;;
(clos:add-dependent f dep)
(setf l1 (clos::generic-function-dependents f))
;;
;; * ADD-METHOD invokes UPDATE-DEPENDENT
;;
(defmethod mop-gf-add/remove-dependent ((a number)) (cos a))
(setf l2 (mop-dependent-object-log dep))
;;
;; * REMOVE-METHOD invokes UPDATE-DEPENDENT
;;
(setf m1 (first (compute-applicable-methods f (list 1.0))))
(remove-method f m1)
(setf l3 (mop-dependent-object-log dep))
;;
;; * REMOVE-DEPENDENT eliminates all dependencies
;;
(clos:remove-dependent f dep)
(setf l4 (clos::generic-function-dependents f))
;;
;; * ADD-METHOD invokes UPDATE-DEPENDENT but has no effect
;;
(defmethod mop-gf-add/remove-dependent ((a symbol)) a)
(setf l5 (mop-dependent-object-log dep))
;;
;; * REMOVE-METHOD invokes UPDATE-DEPENDENT but has no effect
;;
(setf m2 (first (compute-applicable-methods f (list 'a))))
(setf l6 (mop-dependent-object-log dep))
;; the first call to defmethod adds two entries: one for the
;; add-method and another one for a reinitialize-instance with
;; the name of the function
(values (equalp l1 (list dep))
(eq l2 (rest l3))
(equalp l3
(list (list f 'remove-method m1)
(list f 'add-method m1)
(list f)))
(null l4)
(eq l5 l3)
(eq l6 l3)
t)))
t t t t t t t)
;;; Date: 23/04/2012
;;; Description:
;;;
;;; ADD-DEPENDENT does not duplicate elements
;;;
(deftest mop-class-add/remove-dependent
(let* ((dep (make-instance 'mop-dependent-object))
l1 l2)
(when (find-class 'mop-class-add/remove-dependent nil)
(setf (class-name (find-class 'mop-class-add/remove-dependent)) nil))
(defclass mop-class-add/remove-dependent () ())
(let ((f (find-class 'mop-class-add/remove-dependent)))
(clos:add-dependent f dep)
(setf l1 (clos::class-dependents f))
(clos:add-dependent f dep)
(setf l2 (clos::class-dependents f))
(and (eq l1 l2)
(equalp l1 (list dep))
t)))
t)
;;; Date: 23/04/2012
;;; Description:
;;;
;;; Standard classes have dependents and are activated
;;;
(deftest mop-class-add/remove-dependent
(let* ((dep (make-instance 'mop-dependent-object))
l1 l2 l3 l4 l5)
(when (find-class 'mop-class-add/remove-dependent nil)
(setf (class-name (find-class 'mop-class-add/remove-dependent)) nil))
(defclass mop-class-add/remove-dependent () ())
(let ((f (find-class 'mop-class-add/remove-dependent)))
;;
;; * ADD-DEPENDENT registers the object with the class
;;
(clos:add-dependent f dep)
(setf l1 (clos::class-dependents f))
;;
;; * SHARED-INITIALIZE invokes UPDATE-DEPENDENT
;;
(defclass mop-class-add/remove-dependent () (a))
(setf l2 (clos::class-dependents f))
(setf l3 (mop-dependent-object-log dep))
;;
;; * REMOVE-DEPENDENT eliminates object from list
;;
(clos:remove-dependent f dep)
(setf l4 (clos::class-dependents f))
;;
;; * SHARED-INITIALIZE invokes UPDATE-DEPENDENT without effect
;;
(defclass mop-class-add/remove-dependent () ())
(setf l5 (mop-dependent-object-log dep))
;;
;; the first call to defclass adds one entry with the reinitialization
;; of the class both in name and list of slots
(and (equalp l1 (list dep))
(eq l1 l2)
(equalp l3
(list (list f :name 'mop-class-add/remove-dependent
:direct-superclasses nil
:direct-slots '((:name a)))))
(null l4)
(eq l5 l3)
t)))
t)
;; Test MOP dispatch
;;; Date: 23/04/2012
;;; Description:
;;;
;;; COMPUTE-APPLICABLE-METHODS-USING-CLASSES works with one and
;;; two methods and no EQL.
;;;
(deftest mop-c-a-m-u-c-two-methods
(progn
(fmakunbound 'mop-fn)
(defgeneric mop-fn (a)
(:method ((a number)) (cos a))
(:method ((a symbol)) a))
(let ((m1 (compute-applicable-methods #'mop-fn (list 1.0)))
(m2 (compute-applicable-methods #'mop-fn (list 'a))))
(flet ((f (class)
(multiple-value-list (clos:compute-applicable-methods-using-classes
#'mop-fn (list (find-class class))))))
(and (equalp (f 'number) (list m1 t))
(equalp (f 'real) (list m1 t))
(equalp (f 'symbol) (list m2 t))
(equalp (f 'cons) '(nil t))
t))))
t)
;;; Date: 23/04/2012
;;; Description:
;;;
;;; COMPUTE-APPLICABLE-METHODS-USING-CLASSES fails with EQL
;;; specializers when one of the specializers is covered by the
;;; classes.
;;;
(deftest mop-c-a-m-u-c-fails-with-eql
(progn
(fmakunbound 'mop-fn)
(defgeneric mop-fn (a)
(:method ((a (eql 1))) 1)
(:method ((a (eql 'a))) 2)
(:method ((a float)) 3))
(let ((m1 (compute-applicable-methods #'mop-fn (list 1)))
(m2 (compute-applicable-methods #'mop-fn (list 'a)))
(m3 (compute-applicable-methods #'mop-fn (list 1.0))))
(flet ((f (class)
(multiple-value-list (clos:compute-applicable-methods-using-classes
#'mop-fn (list (find-class class))))))
(and (equalp (f 'integer) (list nil nil))
(equalp (f 'number) (list nil nil))
(equalp (f 'symbol) (list nil nil))
(equalp (f 'float) (list m3 t))
(= (length m1) 1)
(= (length m2) 1)
(= (length m3) 1)
t))))
t)
;;; Date: 24/04/2012
;;; Description:
;;;
;;; COMPUTE-DISCRIMINATING-FUNCTION is invoked and honored by ECL.
;;;
(deftest mop-discriminator
(progn
(fmakunbound 'foo)
(defclass my-generic-function (standard-generic-function)
())
(defmethod clos:compute-discriminating-function ((gf my-generic-function))
;; We compute the invocaions of c-d-f. Note that it is invoked
;; quite often -- we could probably optimize this.
#'(lambda (&rest args)
args))
(defgeneric foo (a)
(:generic-function-class my-generic-function))
(unwind-protect
(foo 2)
(fmakunbound 'foo)))
(2))
;;; Date: 24/04/2012
;;; Description:
;;;
;;; COMPUTE-DISCRIMINATING-FUNCTION is invoked on ADD-METHOD, REMOVE-METHOD,
;;; DEFGENERIC, INITIALIZE-INSTANCE and REINITIALIZE-INSTANCE acting on
;;; generic functions.
;;;
(deftest mop-discriminator-recomputation
(progn
(defparameter *mop-discriminator-recomputation* 0)
(fmakunbound 'foo)
(defclass my-generic-function (standard-generic-function)
())
(defmethod clos:compute-discriminating-function ((gf my-generic-function))
;; We compute the invocaions of c-d-f. Note that it is invoked
;; quite often -- we could probably optimize this.
(incf *mop-discriminator-recomputation*)
(call-next-method))
(and (progn
(setf *mop-discriminator-recomputation* 0)
(eval '(defgeneric foo (a)
(:generic-function-class my-generic-function)))
(plusp *mop-discriminator-recomputation* ))
(typep #'foo 'my-generic-function)
(progn
(setf *mop-discriminator-recomputation* 0)
(eval '(defmethod foo ((a number)) (print a)))
(plusp *mop-discriminator-recomputation*))
(progn
(setf *mop-discriminator-recomputation* 0)
(eval '(remove-method #'foo (first (compute-applicable-methods
#'foo
(list 1.0)))))
(plusp *mop-discriminator-recomputation*))
t))
t)
;;; Date: 24/04/2012
;;; Description:
;;;
;;; Verify ECL calls COMPUTE-APPLICABLE-METHODS-USING-CLASSES for
;;; user-defined generic function classes.
;;;
(deftest mop-compute-applicable-methods-using-classes-is-honored
(progn
(defparameter *mop-dispatch-used* 0)
(fmakunbound 'foo)
(defclass my-generic-function (standard-generic-function)
())
(defmethod clos:compute-applicable-methods-using-classes
((gf my-generic-function) classes)
(incf *mop-dispatch-used*)
(call-next-method))
(defgeneric foo (a)
(:generic-function-class my-generic-function)
(:method ((a number)) (cos 1.0)))
(and (zerop *mop-dispatch-used*)
(progn (foo 1.0) (plusp *mop-dispatch-used*))))
t)
;;; Date: 24/04/2012
;;; Description:
;;;
;;; Verify ECL calls COMPUTE-APPLICABLE-METHODS for
;;; user-defined generic function classes.
;;;
(deftest mop-compute-applicable-methods-is-honored
(progn
(defparameter *mop-dispatch-used* 0)
(fmakunbound 'foo)
(defclass my-generic-function (standard-generic-function)
())
(defmethod clos:compute-applicable-methods-using-classes
((gf my-generic-function) classes)
(incf *mop-dispatch-used*)
(values nil nil))
(defmethod compute-applicable-methods
((gf my-generic-function) args)
(incf *mop-dispatch-used*)
(call-next-method))
(defgeneric foo (a)
(:generic-function-class my-generic-function)
(:method ((a number)) (cos 1.0)))
(and (zerop *mop-dispatch-used*)
(progn (foo 1.0) (= *mop-dispatch-used* 2))))
t)
;;; From: Pascal Costanza
;;; Description:
;;;
;;; sort-applicable-methods is invoked by two methods and one
;;; invocation triggers a disambiguation error:
;;;
;;; Condition of type: SIMPLE-ERROR
;;; The type specifiers #<The STANDARD-CLASS COMMON-LISP-USER::B> and #<The STANDARD-CLASS COMMON-LISP-USER::A> can not be disambiguated with respect to the argument specializer: #<The STANDARD-CLASS STANDARD-CLASS>
(deftest mop-compute-applicable-methods-disambiguation.0001
(ext:with-clean-symbols (a b c f)
(defclass a () ())
(defclass b () ())
(defclass c (a b) ())
(defmethod f ((o a)))
(defmethod f ((o b)))
(compute-applicable-methods-using-classes
#'f (list (find-class 'c)))
T)
T)

146
src/tests/regressions/tests/mixed.lsp
View file

@ -1,146 +0,0 @@
;;;; -*- 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)
;;; (EXT:PACKAGE-LOCK) returned the wrong value.
;;; Fixed in 77a267c7e42860affac8eddfcddb8e81fccd44e5
(deftest mixed-0001-package-lock
(progn
;; Don't know the first state
(ext:package-lock "CL-USER" nil)
(values
(ext:package-lock "CL-USER" t)
(ext:package-lock "CL-USER" nil)
(ext:package-lock "CL-USER" nil)))
nil t nil)
;; Bugs from sourceforge
(deftest mixed.0002.mvb-not-evaled
(assert
(eq :ok
(block nil
(tagbody
(return (multiple-value-bind ()
(go :fail) :bad))
:fail
(return :ok)))))
nil)
(declaim (ftype (function (cons) t) mixed.0003.foo))
(declaim (ftype (function (t cons) t) (setf mixed.0003.foo)))
(defun mixed.0003.foo (cons)
(first cons))
(defun (setf mixed.0003.foo) (value cons)
(setf (first cons) value))
(defvar mixed.0003.*c* (cons 'x 'y))
(deftest mixed.0003.declaim-type.1
(mixed.0003.foo mixed.0003.*c*) ;; correctly returns x
x)
;; signals an error:
;; Z is not of type CONS.
;; [Condition of type TYPE-ERROR]
(deftest mixed.0004.declaim-type.2
(assert (eq 'z
(setf (mixed.0003.foo mixed.0003.*c*) 'z)))
nil)
(compile nil
`(lambda (x)
(1+ (the (values integer string)
(funcall x)))))
(deftest mixed.0005.style-warning-argument-order
(let ((warning nil))
(assert
(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))))))
(assert (not warning)))
nil)
(deftest mixed.0006.write-hash-readable
(hash-table-count
(read-from-string
(write-to-string (make-hash-table)
:readably t)))
0)
(deftest mixed.0007.find-package.1
(assert
(let ((string ":cl-user"))
(find-package
(let ((*package* (find-package :cl)))
(read-from-string string)))))
nil)
(deftest mixed.0008.find-package.2
(assert
(let ((string ":cl-user"))
(let ((*package* (find-package :cl)))
(find-package
(read-from-string string)))))
nil)
;;; 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)))
(deftest mixed.0009.restart-case-body
(handler-bind ((x (lambda (c) (slot-value c 'y))))
(restart-case
(signal 'x :y 1)))
nil))
;;; 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)
(deftest mixed.0010.*trace-output*
(progn
(defun fact (n) (if (zerop n) :boom (fact (1- n))))
(zerop (length
(with-output-to-string (*trace-output*)
(trace fact)
(fact 3)
(untrace fact)
*trace-output*))))
nil))

55
src/tests/regressions/tests/random-states.lsp
View file

@ -1,55 +0,0 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*-
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
;;;; Author: Daniel Kochmański
;;;; Created: 2015-09-21
;;;; Contains: Random state tests
(in-package :cl-test)
;; Trivial case
(deftest random-states.0001
(numberp (random 18))
T)
;; Check if we can generate random number from a read random state
(deftest random-states.0002
(numberp (random 18 #$1))
T)
;; Check if we can generate random number from a new random state
(deftest random-states.0003
(numberp (random 18 (make-random-state)))
T)
;; Check if we can copy use copied random state from reader
(deftest random-states.0004
(numberp (random 18 (make-random-state #$1)))
T)
;; Check if the same seed produces the same result
(deftest random-states.0005
(= (random 18 #$1)
(random 18 #$1)
(random 18 #$1))
T)
;; Check if we get the same table from the same seed
(deftest random-states.0005
(let ((*print-readably* t)
(rs (make-random-state #$1)))
(equalp
(format nil "~S" #$1)
(format nil "~S" rs)))
T)
;; Check if we can read back the random state
(deftest random-states.0006
(let* ((*print-readably* t)
(rs (make-random-state #$1))
(rs-read (read-from-string
(format nil "~S" rs))))
(equalp
(format nil "~S" rs-read)
(format nil "~S" rs)))
T)

126
src/tests/regressions/tests/test-ansi.lsp
View file

@ -1,126 +0,0 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*-
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
(in-package :cl-test)
;;;;;;;;;;;;;;;;;;;;;;;;;
;; 2.* Readtable tests ;;
;;;;;;;;;;;;;;;;;;;;;;;;;
(symbol-macrolet ((lookup-table
'(:SYMBOL ("zebra" "Zebra" "ZEBRA" "zebr\\a" "zebr\\A"
"ZEBR\\a""ZEBR\\A" "Zebr\\a" "Zebr\\A")
:UPCASE (|ZEBRA| |ZEBRA| |ZEBRA| |ZEBRa|
|ZEBRA| |ZEBRa| |ZEBRA| |ZEBRa| |ZEBRA|)
:DOWNCASE (|zebra| |zebra| |zebra| |zebra|
|zebrA| |zebra| |zebrA| |zebra| |zebrA|)
:PRESERVE (|zebra| |Zebra| |ZEBRA| |zebra|
|zebrA| |ZEBRa| |ZEBRA| |Zebra| |ZebrA|)
:INVERT (|ZEBRA| |Zebra| |zebra| |ZEBRa|
|ZEBRA| |zebra| |zebrA| |Zebra| |ZebrA|))))
(macrolet
((def-readtable-case-test (reader-case)
`(deftest ,(concatenate 'string "TEST-ANSI.READTABLE.CASE-"
(symbol-name reader-case))
(let ((*readtable* (copy-readtable)))
(setf (readtable-case *readtable*) ,reader-case)
(mapcar #'(lambda (x)
(read-from-string x))
',(getf lookup-table :symbol)))
,(getf lookup-table reader-case))))
(def-readtable-case-test :upcase)
(def-readtable-case-test :downcase)
(def-readtable-case-test :preserve)
(def-readtable-case-test :invert)))
;; when readtable was :invert characters got inverted too
(deftest test-ansi.readtable.invert-char
(let ((*readtable* (copy-readtable)))
(setf (readtable-case *readtable*) :invert)
(read-from-string "#\\a"))
#\a 3)
;; HyperSpec – 3.*
;;;;;;;;;;;;;;;;;;;
;; Deftype tests ;;
;;;;;;;;;;;;;;;;;;;
(deftest test-ansi.deftype.ordinary.1
(progn
(deftype ordinary1 () `(member nil t))
(values (typep T 'ordinary1)
(typep :a 'ordinary1)))
T NIL)
(deftest test-ansi.deftype.ordinary.2
(progn
(deftype ordinary2 (a b)
(if a
'CONS
`(INTEGER 0 ,b)))
(values (typep T '(ordinary2 nil 3))
(typep 3 '(ordinary2 nil 4))
(typep T '(ordinary2 T nil))
(typep '(1 . 2) '(ordinary2 T nil))))
nil t nil t)
(deftest test-ansi.deftype.optional
(progn
(deftype optional (a &optional b)
(if a
'CONS
`(INTEGER 0 ,b)))
(values (typep 5 '(optional nil))
(typep 5 '(optional nil 4))))
t nil)
(deftest test-ansi.deftype.nested
(progn
(deftype nested ((a &optional b) c . d)
(assert (listp d))
`(member ,a ,b ,c))
(values
(typep 1 '(nested (1 2) 3 4 5 6))
(typep 1 '(nested (2 2) 3 4 5 6))
(typep '* '(nested (3) 3))
(typep 3 '(nested (2) 3))))
t nil t t)
;;;;;;;;;;;;;;;;;;;;;;;;;
;; 19.* Pathname tests ;;
;;;;;;;;;;;;;;;;;;;;;;;;;
;; Issue #103 ;; logical-pathname-translations not translating
;; https://gitlab.com/embeddable-common-lisp/ecl/issues/103
(deftest* test-ansi.pathname.wildcards.1
(namestring
(progn
(setf (logical-pathname-translations "prog")
'(("CODE;*.*.*" "/tmp/prog/")))
(translate-logical-pathname "prog:code;documentation.lisp")))
(list (namestring #P"/tmp/prog/documentation.lisp")))
;;;;;;;;;;;;;;;;;;;;;;;
;; 23.* Reader tests ;;
;;;;;;;;;;;;;;;;;;;;;;;
(defstruct sharp-s-reader.1.example-struct a)
(deftest test-ansi.reader.sharp-s-reader.1
(prog1
(signals-error
(read-from-string
"(#1=\"Hello\" #S(sharp-s-reader.1.example-struct :A #1#))")
program-error))
nil)

43
src/tests/regressions/tools.lsp
View file

@ -1,43 +0,0 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*-
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
;;;; Author: Juan Jose Garcia-Ripoll
;;;; Created: Fri Apr 14 11:13:17 CEST 2006
;;;; Contains: Tools for doing tests, intercepting functions, etc.
(defmacro with-dflet (functions &body body)
"Syntax:
(with-dflet ((fname form*)*) body)
Evaluate BODY in an environment in which the function FNAME has been redefined
to evaluate the given forms _before_ executing the orginal code."
(let ((vars '()) (in-forms '()) (out-forms '()))
(loop for (name . forms) in functions
do (let ((var (gensym)))
(push `(,var #',name) vars)
(push `(setf (fdefinition ',name)
#'(lambda (&rest args) ,@forms (apply ,var args)))
in-forms)
(push `(setf (fdefinition ',name) ,var) out-forms)))
`(let ,vars
(unwind-protect
(progn ,@in-forms ,@body)
(progn ,@out-forms)))))
(defmacro with-compiler ((filename &rest compiler-args) &body forms)
"Create a lisp file with the given forms and compile it. The forms are
evaluated. The output is stored in a string and output as a second value."
`(progn
(with-open-file (s ,filename :direction :output :if-exists :supersede
:if-does-not-exist :create)
,@(loop for f in forms collect `(print ,f s)))
(let* ((ok t)
(output
(with-output-to-string (*standard-output*)
(let ((*error-output* *standard-output*)
(*compile-verbose* t)
(*compile-print* t))
(setf ok (compile-file ,filename ,@compiler-args))))))
(values ok output))))

89
src/tests/stress/tests/multiprocessing.lsp → src/tests/stress/multiprocessing.lsp
View file

@ -4,35 +4,33 @@
;; Author: Daniel Kochmański
;; Contains: Multiprocessing stress tests
(defparameter *runs* 1000)
;; Submitted by James M. Lawrence
;;
;; Notes: couldn't reproduce on 64-bit machine, but author uses 32-bit
;; This test uses infinite loop, this should be fixed.
(defun test (message-count worker-count)
(let ((to-workers (mp:make-semaphore))
(1am-ecl:test semaphore.wait/signal
(let ((message-count 10000)
(worker-count 64)
(to-workers (mp:make-semaphore))
(from-workers (mp:make-semaphore)))
(loop repeat worker-count
do (mp:process-run-function
"test"
(lambda ()
(loop
(mp:wait-on-semaphore to-workers)
(mp:signal-semaphore from-workers)))))
(loop
(loop repeat message-count
do (mp:signal-semaphore to-workers))
(loop repeat message-count
do (mp:wait-on-semaphore from-workers))
(assert (zerop (mp:semaphore-count to-workers)))
(assert (zerop (mp:semaphore-count from-workers)))
(format t ".")
(finish-output))))
(defun run ()
(test 10000 64))
(run)
do (mp:process-run-function
"test"
(lambda ()
(loop
(mp:wait-on-semaphore to-workers)
(mp:signal-semaphore from-workers)))))
(dotimes (i *runs*)
(loop repeat message-count
do (mp:signal-semaphore to-workers))
(loop repeat message-count
do (mp:wait-on-semaphore from-workers))
(1am-ecl:is (zerop (mp:semaphore-count to-workers)))
(1am-ecl:is (zerop (mp:semaphore-count from-workers)))
(finish-output))))
;; Submitted by James M. Lawrence
@ -58,8 +56,10 @@
(mp:condition-variable-wait
(sema-cvar sema) (sema-lock sema)))))))
(defun test (message-count worker-count)
(let ((to-workers (make-sema))
(1am-ecl:test semaphore/condition-wait
(let ((message-count 10000)
(worker-count 64)
(to-workers (make-sema))
(from-workers (make-sema)))
(loop repeat worker-count
do (mp:process-run-function
@ -68,20 +68,14 @@
(loop
(dec-sema to-workers)
(inc-sema from-workers)))))
(loop
(loop repeat message-count
do (inc-sema to-workers))
(loop repeat message-count
do (dec-sema from-workers))
(assert (zerop (sema-count to-workers)))
(assert (zerop (sema-count from-workers)))
(format t ".")
(finish-output))))
(defun run ()
(test 10000 64))
(run)
(dotimes (i *runs*)
(loop repeat message-count
do (inc-sema to-workers))
(loop repeat message-count
do (dec-sema from-workers))
(1am-ecl:is (zerop (sema-count to-workers)))
(1am-ecl:is (zerop (sema-count from-workers)))
(finish-output))))
;; Submitted by James M. Lawrence
@ -137,12 +131,13 @@
(loop (let ((to-workers (make-queue))
(from-workers (make-queue)))
(loop repeat worker-count
do (mp:process-run-function
"test"
(lambda ()
(loop (let ((message (pop-queue to-workers)))
(push-queue message from-workers)
(unless message (return)))))))
do (mp:process-run-function
"test"
(lambda ()
(dotimes (i *runs*)
(let ((message (pop-queue to-workers)))
(push-queue message from-workers)
(unless message (return)))))))
(loop repeat message-count do (push-queue t to-workers))
(loop repeat message-count do (pop-queue from-workers))
(loop repeat worker-count do (push-queue nil to-workers))
@ -150,8 +145,8 @@
(format t ".")
(finish-output))))
(qtest 0 64) ; => segfault
(qtest 1 64) ; => hang
(qtest 10000 64) ; => error "Attempted to recursively lock..."
(1am-ecl:test qtest.1 (qtest 0 64)) ; => segfault
(1am-ecl:test qtest.2 (qtest 1 64)) ; => hang
(1am-ecl:test qtest.3 (qtest 10000 64)) ; => error "Attempted to recursively lock..."

0
src/tests/regressions/universe.lsp → src/tests/universe.lisp
View file