diff --git a/CHANGELOG b/CHANGELOG
index cd2cd1c3c..408d88a06 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -40,6 +40,8 @@
- Added code walker (present as *feature* :walker)
+ - Testing framework cleanup
+
** Issues fixed:
- PPC64le builds with bundled GMP work (autoreconf with recent
diff --git a/src/tests/Makefile.in b/src/tests/Makefile.in
index 2433f8adb..a583364ec 100755
--- a/src/tests/Makefile.in
+++ b/src/tests/Makefile.in
@@ -4,7 +4,7 @@ all: show-fails
.PHONY: do-regressions cleanup clean-sources update
-BUGS_FILES := $(shell find ../../src/tests/bugs/ -type f)
+BUGS_FILES := $(shell find ../../src/tests/regressions/ -type f)
regressions.log: config.lsp
$(MAKE) do-regressions
@@ -13,7 +13,7 @@ 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 8 regressions.log | head -n 6
+ tail -n 16 regressions.log
#
# Create directories
diff --git a/src/tests/bugs/cl-001.lsp b/src/tests/bugs/cl-001.lsp
deleted file mode 100755
index a26a9e6ca..000000000
--- a/src/tests/bugs/cl-001.lsp
+++ /dev/null
@@ -1,489 +0,0 @@
-;-*- Mode: Lisp -*-
-;;;; Author: Juan Jose Garcia-Ripoll
-;;;; Created: Fri Apr 14 11:13:17 CEST 2006
-;;;; Contains: Compiler regression tests
-
-(in-package :cl-test)
-
-;;; Date: 09/05/2006
-;;; From: Brian Spilsbury
-;;; Fixed: 20/05/2006 (Brian Spilsbury)
-;;; Description:
-;;;
-;;; (DEFPACKAGE "FOO" (:USE) (:IMPORT-FROM "CL" "NIL" "T"))
-;;; fails to import symbol NIL because IMPORT is invoked as
-;;; (IMPORT NIL (find-package "CL")), which does not import
-;;; any symbol.
-;;;
-
-(deftest cl-0001-import
- (progn
- (defpackage "FOO" (:USE) (:IMPORT-FROM "CL" "NIL" "T"))
- (prog1 (multiple-value-list (find-symbol "NIL" (find-package "FOO")))
- (delete-package "FOO")))
- (NIL :INTERNAL))
-
-;;; Date: 09/05/2006
-;;; From: Brian Spilsbury
-;;; Fixed: 20/05/2006 (Brian Spilsbury)
-;;; Description:
-;;;
-;;; Compiled FLET forms failed to shadow global macro definitions, if not
-;;; for the compiler, at least for MACRO-FUNCTION and MACROEXPAND[-1]
-;;;
-
-(deftest cl-0002-macro-shadow
- (progn
- (with-compiler ("aux-cl-0002.lsp")
- '(defmacro foo () 2)
- '(defmacro test (symbol &environment env)
- (and (macro-function symbol env) t))
- '(defun doit () (flet ((foo () 1)) (test foo))))
- (load "aux-cl-0002")
- (delete-file "aux-cl-0002.lsp")
- (delete-file (compile-file-pathname "aux-cl-0002" :type :fas))
- (prog1
- (doit)
- (fmakunbound 'doit)
- (fmakunbound 'test)
- (fmakunbound 'foo)))
- NIL)
-
-;;;
-;;; Fixed: 14/06/2006 (juanjo)
-;;; Description:
-;;;
-;;; APROPOS, APROPOS-LIST and HELP* are case sensitive.
-;;;
-
-(deftest cl-0003-apropos
- (and (equal (apropos-list "bin")
- (apropos-list "bin"))
- t)
- t)
-
-;;; Date: 08/07/2006 (Dave Roberts)
-;;; Fixed: 02/08/2006 (juanjo)
-;;; Description:
-;;;
-;;; SLIME traps when invoking DESCRIBE. Reason is that STREAMP breaks on
-;;; Gray streams.
-;;;
-
-(deftest cl-0004-streamp
- (streamp (make-instance 'gray:fundamental-stream))
- t)
-
-;;; Date: 02/08/2006 (juanjo)
-;;; Description:
-;;;
-;;; There is a problem with SUBTYPEP and type STREAM
-;;;
-
-(deftest cl-0005-subtypep-stream
- (subtypep (find-class 'gray:fundamental-stream) 'stream)
- t t)
-
-;;; Date: 09/07/2006 (Tim S)
-;;; Fixed: 09/07/2006 (Tim S)
-;;; Description:
-;;;
-;;; ENOUGH-NAMESTRING provided too large pathnames even when the
-;;; pathname was a subdirectory of the default pathname.
-;;;
-;;; Date: 31/12/2006 (Richard M. Kreuter)
-;;; Fixed: 5/1/2007 (Juanjo)
-;;; Description:
-;;; ENOUGH-NAMESTRING does not simplify the pathname when the
-;;; directory matches completely that of the default path.
-;;;
-
-(defvar *enough-namestring_tests*
- `(("/A/b/C/"
- ("/A/b/C/drink-up.sot"
- "/A/b/C/loozer/whiskey.sot"
- "/A/b/C/loozer/whiskey"
- "/A/b/whiskey.sot"
- "/A/"
- "whiskey.sot"
- "loozer/whiskey.sot"
- "C/loozer/whisky.sot"
- ""))
- ("A/b/C" ("A/b/C" "A/b/C/loozer" "b/C" "/A/b/C" "/A/" ""))
- ("/" ("/A/b/C/drink-up.sot" "/A/b/C/" "/A/" ""))
- ("" ("/A/b/C/drink-up.sot" "/A/b/C/loozer/whiskey.sot"
- "/A/b/C/loozer/whiskey" "/A/b/whiskey.sot"
- "/A/" "whiskey.sot" "loozer/whiskey.sot" "C/loozer/whisky.sot"))
- ("/A/*/C/drink-up.sot"
- ("/A/*/C/drink-up.sot" "/A/b/C/drink-up.sot" "/A/b/C/loozer/whiskey.*"
- "/A/b/C/loozer/*.sot" "/A/**/whiskey.sot" ""))
- ("/A/b/../c/d.sot" ("/A/b/../c/d.sot" "/A/b/../c/D/e.sot"
- "/A/c/d.sot" "../c/d.sot"
- "c/e/d.sot"))))
-
-(deftest cl-0006-enough-namestring
- (labels ((test-path (path defaults)
- (let* ((e-ns (enough-namestring path defaults))
- (d1 (pathname-directory path))
- (d2 (pathname-directory defaults))
- (d3 (pathname-directory e-ns)))
- (and (equalp (merge-pathnames e-ns defaults)
- (merge-pathnames (parse-namestring path nil defaults)
- defaults))
- ;; If directories concide, the "enough-namestring"
- ;; removes the directory. But only if the pathname is
- ;; absolute.
- (not (and (equal (first d1) ':absolute)
- (equalp d1 d2)
- d3)))))
- (test-default+paths (default+paths)
- (let ((defaults (first default+paths))
- (paths (second default+paths)))
- (every (lambda (path)
- (handler-case (test-path path defaults)
- (error (error) 'NIL)))
- paths))))
- (every #'test-default+paths *enough-namestring_tests*))
- t)
-
-;;; Date: 10/08/2006 (Lars Brinkhoff)
-;;; Fixed: 1/09/2006 (juanjo)
-;;; Details:
-;;;
-;;; ADJUST-ARRAY must signal a type error when the value of :FILL-POINTER is
-;;; not NIL and the adjustable array does not have a fill pointer
-;;;
-
-(deftest cl-0007-adjustable-array
- (loop for fp in '(nil t) collect
- (loop for i in '(t nil 0 1 2 3) collect
- (and
- (handler-case (adjust-array (make-array 3 :adjustable t :fill-pointer fp) 4
- :fill-pointer i)
- (type-error (c) nil)
- (error (c) t))
- t)))
- ((nil t nil nil nil nil) (t t t t t t)))
-
-;;; Date: 09/10/2006 (Dustin Long)
-;;; Fixed: 10/10/2006
-;;; Description:
-;;;
-;;; The namestring "." is improperly parsed, getting a file type of ""
-;;; Additionally we found it more convenient to have the _last_ dot mark
-;;; the file type, so that (pathname-type "foo.mpq.txt") => "txt"
-;;;
-
-(deftest cl-0008-parse-namestring
- (loop for (namestring name type) in
- '(("." "." NIL) (".." "." "") (".foo" ".foo" NIL) (".foo.mpq.txt" ".foo.mpq" "txt")
- ("foo.txt" "foo" "txt") ("foo.mpq.txt" "foo.mpq" "txt"))
- unless (let ((x (parse-namestring namestring)))
- (and (equal name (pathname-name x))
- (equal type (pathname-type x))
- (equal '() (pathname-directory x))))
- collect namestring)
- ())
-
-;;; Date: 28/09/2006
-;;; Fixed: 10/10/2006
-;;; Description:
-;;;
-;;; Nested calls to queue_finalizer trashed the value of cl_core.to_be_finalized
-;;; The following code tests that at least three objects are finalized.
-;;;
-;;; Note: this test fails in multithreaded mode. GC takes too long!
-#-ecl
-(deftest cl-0009-finalization
- (let ((*all-tags* '()))
- (declare (special *all-tags*))
- (flet ((custom-finalizer (tag)
- #'(lambda (o) (push tag *all-tags*))))
- (let ((a '()))
- (dotimes (i 5)
- (let ((x (cons i i)))
- (si::set-finalizer x (custom-finalizer i))
- (push x a))))
- (dotimes (j 100)
- (dotimes (i 10000)
- (cons 1.0 1.0))
- (si::gc t)))
- (sort *all-tags* #'<))
- (0 1 2 3 4))
-
-
-;;; Date: 8/10/2006 (Dustin Long)
-;;; Fixed: 10/10/2006 (Dustin Long)
-;;; Description:
-;;;
-;;; Hash table iterators have to check that their argument is
-;;; really a hash table.
-;;;
-
-(deftest cl-0010-hash-iterator
- (loop for i in *mini-universe*
- when (and (not (hash-table-p i))
- (handler-case (progn (loop for k being the hash-keys of i) t)
- (error (c) nil)))
- collect (type-of i))
- nil)
-
-;;; Date: 31/12/2006 (Richard M. Kreuter)
-;;; Fixed: 5/1/2007 (Juanjo)
-;;; Description:
-;;;
-;;; The keyword :BACK does not work as expected when creating pathnames
-;;; and causes an error when at the beginning: (:RELATIVE :BACK)
-;;;
-
-(deftest cl-0011-make-pathname-with-back
- (loop for i from 0 to 200
- with l = (random 10)
- with x = (if (zerop l) 0 (random (1+ l)))
- with y = (if (= l x) 0 (random (- l x)))
- nconc (let* ((l (loop for i from 0 below l collect (princ-to-string i)))
- (l2 (append (subseq l 0 y) '("break" :back) (subseq l y nil)))
- (d1 (list* :absolute (subseq l2 0 x)))
- (d2 (list* :relative (subseq l2 x nil)))
- (d3 (list* :absolute l2))
- (d4 (list* :relative l2))
- (p1 (handler-case (make-pathname :directory d1)
- (error (c) nil)))
- (p2 (handler-case (make-pathname :directory d2)
- (error (c) nil)))
- (p3 (handler-case (make-pathname :directory d3)
- (error (c) nil)))
- (p4 (handler-case (make-pathname :directory d4)
- (error (c) nil))))
- (if (and p1 p2 p3 p4
- ;; MERGE-PATHNAMES eliminates :BACK
- (equalp l (rest (pathname-directory (merge-pathnames p2 p1))))
- ;; MAKE-PATHNAME does not eliminate :BACK
- (not (equalp l (rest (pathname-directory (make-pathname :directory d3)))))
- (not (equalp l (rest (pathname-directory (make-pathname :directory d4))))))
- nil
- (list (list l d1 d2 d3 d4 l2 x y)))))
- nil)
-
-;;; Date: 11/03/2007 (Fare)
-;;; Fixed: 23/03/2007 (Juanjo)
-;;; Description:
-;;;
-;;; COPY-READTABLE did not copy the entries of the "from" table
-;;; when a second argument, i.e. a "destination" table was supplied.
-;;;
-
-(deftest cl-0012-copy-readtable
- (let ((from-readtable (copy-readtable))
- (to-readtable (copy-readtable))
- (char-list '()))
- (dotimes (i 20)
- (let* ((code (+ 32 (random 70)))
- (c (code-char code)))
- (push c char-list)
- (set-macro-character c
- (eval `(lambda (str ch) ,code))
- nil
- from-readtable)))
- (copy-readtable from-readtable to-readtable)
- (loop for c in char-list
- unless (and (eql (char-code c)
- (let ((*readtable* from-readtable))
- (read-from-string (string c))))
- (eq (get-macro-character c from-readtable)
- (get-macro-character c to-readtable)))
- collect c))
- nil)
-
-;;; Date: 05/01/2008 (Anonymous, SF bug report)
-;;; Fixed: 06/01/2008 (Juanjo)
-;;; Description:
-;;;
-;;; For a file linked as follows "ln -s //usr/ /tmp/foo",
-;;; (truename #p"/tmp/foo") signals an error because //usr is
-;;; parsed as a hostname.
-;;;
-
-#-windows
-(deftest cl-0013-truename
- (progn
- (si:system "rm -rf foo; ln -sf //usr/ foo")
- (prog1 (namestring (truename "./foo"))
- (si::system "rm foo")))
- "/usr/")
-
-;;; Date: 30/08/2008 (Josh Elsasser)
-;;; Fixed: 01/09/2008 (Juanjo)
-;;; Description:
-;;;
-;;; Inside the form read by #., recursive definitions a la #n=
-;;; and #n# were not properly expanded
-;;;
-(deftest cl-0014-sharp-dot
- (with-output-to-string (*standard-output*)
- (let ((*print-circle* t))
- (read-from-string "'#.(princ (list '#1=(1 2) '#1#))")))
- "(#1=(1 2) #1#)")
-
-;;; Date: 30/08/2008 (Josh Elsasser)
-;;; Fixed: 30/08/2008 (Josh Elsasser)
-;;; Description:
-;;;
-;;; A setf expansion that produces a form with a macro that also has
-;;; its own setf expansion does not giver rise to the right code.
-;;;
-(deftest cl-0015-setf-expander
- (progn
- (define-setf-expander triple (place &environment env)
- (multiple-value-bind (dummies vals newval setter getter)
- (get-setf-expansion place env)
- (let ((store (gensym)))
- (values dummies
- vals
- `(,store)
- `(let ((,(car newval) (/ ,store 3)))
- (triple ,setter))
- `(progn
- (triple ,getter))))))
- (defmacro hidden (val)
- `(triple ,val))
- (defmacro triple (val)
- `(* 3 ,val))
- (prog1
- (equalp (eval '(let ((foo 5))
- (list foo (triple foo) (setf (triple foo) 6) foo (triple foo))))
- (eval '(let ((foo 5))
- (list foo (hidden foo) (setf (hidden foo) 6) foo (hidden foo)))))
- (fmakunbound 'hidden)
- (fmakunbound 'triple)))
- T)
-
-;;; Date: 17/2/2009
-;;; Fixed: 17/2/2009
-;;; Description:
-;;;
-;;; The defstruct form fails with an :include field that overwrites
-;;; a slot that is read only.
-;;;
-(deftest cl-0016-defstruct-include
- (progn
- (eval '(progn
- (defstruct cl-0016-a (a 1 :read-only t))
- (defstruct (cl-0016-b (:include cl-0016-a (a 2))))
- (defstruct (cl-0016-c (:include cl-0016-a (a 3 :read-only t))))))
- (values
- (handler-case (eval '(defstruct (cl-0016-d (:include cl-0016-a (a 2 :read-only nil)))))
- (error (c) t))
- (cl-0016-a-a (make-cl-0016-a))
- (cl-0016-b-a (make-cl-0016-b))
- (cl-0016-c-a (make-cl-0016-c))
- (handler-case (eval '(setf (cl-0016-c-a (make-cl-0016-c)) 3))
- (error (c) t))))
- t 1 2 3 t)
-
-;;; Date: 9/11/2009
-;;; Fixed: 9/11/2009
-;;; Description:
-;;;
-;;; LOAD does not work with special files (/dev/null)
-;;;
-(deftest cl-0017-load-special
- (handler-case (and (load #+(or windows mingw32) "NULL"
- #-(or windows mingw32) "/dev/null")
- t)
- (serious-condition (c) nil))
- t)
-
-;;; Date: 16/11/2009 (Gabriel)
-;;; Fixed: 20/11/2009 (Juanjo)
-;;; Description:
-;;;
-;;; #= and ## reader macros do not work well with #.
-;;;
-(deftest cl-0018-sharp-eq
- (handler-case (values (read-from-string "(#1=(0 1 2) #.(length '#1#))"))
- (serious-condition (c) nil))
- ((0 1 2) 3))
-
-;;; Date: 14/11/2009 (M. Mondor)
-;;; Fixed: 20/11/2009 (Juanjo)
-;;; Description:
-;;;
-;;; FDEFINITION and SYMBOL-FUNCTION cause SIGSEGV when acting on NIL.
-;;;
-(deftest cl-0019-fdefinition
- (and (handler-case (fdefinition nil)
- (undefined-function (c) t)
- (serious-condition (c) nil))
- (handler-case (symbol-function nil)
- (undefined-function (c) t)
- (serious-condition (c) nil)))
- t)
-
-
-;;; Date: 29/11/2009 (P. Costanza)
-;;; Fixed: 29/11/2009 (Juanjo)
-;;; Description:
-;;;
-;;; Updating of instances is not triggered by MAKE-INSTANCES-OBSOLETE.
-;;;
-(deftest cl-0020-make-instances-obsolete
- (progn
- (defparameter *update-guard* nil)
- (defclass cl-0020-a () ((b :accessor cl-0020-a-b :initarg :b)))
- (let ((*a* (make-instance 'cl-0020-a :b 2)))
- (defmethod update-instance-for-redefined-class :before
- ((instance standard-object) added-slots discarded-slots property-list
- &rest initargs)
- (setf *update-guard* t))
- (and (null *update-guard*)
- (progn (cl-0020-a-b *a*) (null *update-guard*))
- (progn (make-instances-obsolete (find-class 'cl-0020-a))
- (null *update-guard*))
- (progn (cl-0020-a-b *a*) *update-guard*)
- (progn (setf *update-guard* nil)
- (defclass cl-0020-a () ((b :accessor cl-0020-a-b :initarg :b)))
- (cl-0020-a-b *a*)
- *update-guard*)
- t)))
- t)
-
-;;; Date: 25/03/2009 (R. Toy)
-;;; Fixed: 4/12/2009 (Juanjo)
-;;; Description:
-;;;
-;;; Conversion of rationals into floats is done by truncating, not by
-;;; rounding, what implies a loss of accuracy.
-;;;
-(deftest cl-0021-ratio-to-float
- ;; The test builds a ratio which is very close to 1 but which is below it
- ;; If we truncate instead of rounding the output will not be 1 coerced
- ;; to that floating point type.
- (loop for type in '(short-float single-float double-float long-float)
- for bits = (float-precision (coerce 1 type))
- do (loop for i from (+ bits 7) to (+ bits 13)
- nconc (loop with value = (ash 1 i)
- with expected = (coerce 1 type)
- for j from 0 to 10
- for x = (- value j)
- for r = (/ (1- x) x)
- for f1 = (coerce r type)
- for f2 = (- (coerce (- r) type))
- unless (and (= f1 expected) (= f2 expected))
- collect (list type r))))
- nil)
-
-;;; Date: 06/04/2010 (M. Kocic)
-;;; Fixed: 4/12/2009
-;;; Description:
-;;;
-;;; Inspection of structs is broken due to undefined inspect-indent
-;;;
-(deftest cl-0022-inspect-struct
- (let ((*query-io* (make-string-input-stream "q
-")))
- (defstruct st1 p1)
- (let ((v1 (make-st1 :p1 "tttt")))
- (handler-case (progn (inspect v1) t)
- (error (c) nil))))
- t)
diff --git a/src/tests/bugs/cmp-001.lsp b/src/tests/bugs/cmp-001.lsp
deleted file mode 100644
index cc685aba0..000000000
--- a/src/tests/bugs/cmp-001.lsp
+++ /dev/null
@@ -1,557 +0,0 @@
-;-*- Mode: Lisp -*-
-;;;; Author: Juan Jose Garcia-Ripoll
-;;;; Created: Fri Apr 14 11:13:17 CEST 2006
-;;;; Contains: Compiler regression tests
-
-(in-package :cl-test)
-
-;;; Date: 12/03/2006
-;;; From: Dan Corkill
-;;; Fixed: 14/04/2006 (juanjo)
-;;; Description:
-;;;
-;;; The inner RETURN form should return to the outer block.
-;;; However, the closure (lambda (x) ...) is improperly translated
-;;; by the compiler to (lambda (x) (block nil ...) and thus this
-;;; form outputs '(1 2 3 4).
-;;;
-(deftest cmp-0001-block
- (funcall (compile nil
- '(lambda ()
- (block nil
- (funcall 'mapcar
- #'(lambda (x)
- (when x (return x)))
- '(1 2 3 4))))
- ))
- 1)
-
-;;; Fixed: 12/01/2006 (juanjo)
-;;; Description:
-;;;
-;;; COMPILE-FILE-PATHNAME now accepts both :FAS and :FASL as
-;;; synonyms.
-;;;
-;;;
-(deftest cmp-0002-pathname
- (and (equalp (compile-file-pathname "foo" :type :fas)
- (compile-file-pathname "foo" :type :fasl))
- t)
- t)
-
-;;; Fixed: 21/12/2005 (juanjo)
-;;; Description:
-;;;
-;;; Compute the path of the intermediate files (*.c, *.h, etc)
-;;; relative to that of the fasl or object file.
-;;;
-
-(deftest cmp-0003-paths
- (let* ((output (compile-file-pathname "tmp/aux" :type :fasl))
- (h-file (compile-file-pathname output :type :h))
- (c-file (compile-file-pathname output :type :c))
- (data-file (compile-file-pathname output :type :data)))
- (and
- (zerop (si::system "rm -rf tmp; mkdir tmp"))
- (with-compiler ("aux-cmp-0003-paths.lsp" :output-file output :c-file t
- :h-file t :data-file t)
- '(defun foo (x) (1+ x)))
- (probe-file output)
- (probe-file c-file)
- (probe-file h-file)
- (probe-file data-file)
- (delete-file "aux-cmp-0003-paths.lsp")
- t))
- t)
-
-;;; Date: 08/03/2006
-;;; From: Dan Corkill
-;;; Fixed: 09/03/2006 (juanjo)
-;;; Description:
-;;;
-;;; DEFCONSTANT does not declare the symbol as global and thus the
-;;; compiler issues warnings when the symbol is referenced in the
-;;; same file in which it is defined as constant.
-;;;
-
-#-ecl-bytecmp
-(deftest cmp-0004-defconstant-warn
- (let ((warn nil))
- (with-dflet ((c::cmpwarn (setf warn t)))
- (with-compiler ("aux-cmp-0004.lsp")
- '(defconstant foo (list 1 2 3))
- '(print foo)))
- (delete-file "aux-cmp-0004.lsp")
- (delete-file (compile-file-pathname "aux-cmp-0004.lsp" :type :fas))
- warn)
- nil)
-
-;;; Date: 16/04/2006
-;;; From: Juanjo
-;;; Fixed: 16/04/2006 (juanjo)
-;;; Description:
-;;;
-;;; Special declarations should only affect the variable bound and
-;;; not their initialization forms. That, even if the variables are
-;;; the arguments of a function.
-;;;
-
-(deftest cmp-0005-declaration
- (let ((form '(lambda (y)
- (flet ((faa (&key (x y))
- (declare (special y))
- x))
- (let ((y 4))
- (declare (special y))
- (faa))))))
- ;; We must test that both the intepreted and the compiled form
- ;; output the same value.
- (list (funcall (compile 'nil form) 3)
- (funcall (coerce form 'function) 3)))
- (3 3))
-
-;;; Date: 26/04/2006
-;;; From: Michael Goffioul
-;;; Fixed: ----
-;;; Description:
-;;;
-;;; Functions with more than 64 arguments have to be invoked using
-;;; the lisp stack.
-;;;
-
-(deftest cmp-0006-call-arguments-limit
- (let ((form '(lambda ()
- (list (list
- 'a0 'b0 'c0 'd0 'e0 'f0 'g0 'h0 'i0
- 'j0 'k0 'l0 'm0 'n0 'o0 'p0 'q0
- 'r0 's0 't0 'u0 'v0 'w0 'x0 'y0 'z0
- 'a1 'b1 'c1 'd1 'e1 'f1 'g1 'h1 'i1
- 'j1 'k1 'l1 'm1 'n1 'o1 'p1 'q1
- 'r1 's1 't1 'u1 'v1 'w1 'x1 'y1 'z1
- 'a2 'b2 'c2 'd2 'e2 'f2 'g2 'h2 'i2
- 'j2 'k2 'l2 'm2 'n2 'o2 'p2 'q2
- 'r2 's2 't2 'u2 'v2 'w2 'x2 'y2 'z2
- 'a3 'b3 'c3 'd3 'e3 'f3 'g3 'h3 'i3
- 'j3 'k3 'l3 'm3 'n3 'o3 'p3 'q3
- 'r3 's3 't3 'u3 'v3 'w3 'x3 'y3 'z3
- 'a4 'b4 'c4 'd4 'e4 'f4 'g4 'h4 'i4
- 'j4 'k4 'l4 'm4 'n4 'o4 'p4 'q4
- 'r4 's4 't4 'u4 'v4 'w4 'x4 'y4 'z4
- 'a5 'b5 'c5 'd5 'e5 'f5 'g5 'h5 'i5
- 'j5 'k5 'l5 'm5 'n5 'o5 'p5 'q5
- 'r5 's5 't5 'u5 'v5 'w5 'x5 'y5 'z5
- 'a6 'b6 'c6 'd6 'e6 'f6 'g6 'h6 'i6
- 'j6 'k6 'l6 'm6 'n6 'o6 'p6 'q6
- 'r6 's6 't6 'u6 'v6 'w6 'x6 'y6 'z6)))))
- (equal (funcall (compile 'foo form))
- (funcall (coerce form 'function))))
- t)
-
-;;; Date: 16/05/2005
-;;; Fixed: 18/05/2006 (juanjo)
-;;; Description:
-;;;
-;;; The detection of when a lisp constant has to be externalized using MAKE-LOAD-FORM
-;;; breaks down with some circular structures
-;;;
-
-(defclass cmp-007-class ()
- ((parent :accessor cmp-007-parent :initform nil)
- (children :initarg :children :accessor cmp-007-children :initform nil)))
-
-(defmethod make-load-form ((x cmp-007-class) &optional environment)
- (declare (ignore environment))
- (values
- ;; creation form
- `(make-instance ',(class-of x) :children ',(slot-value x 'children))
- ;; initialization form
- `(setf (cmp-007-parent ',x) ',(slot-value x 'parent))
- ))
-
-(deftest cmp-0007-circular-load-form
- (loop for object in
- (let ((l (list 1 2 3)))
- (list l
- (subst 3 l l)
- (make-instance 'cmp-007-class)
- (subst (make-instance 'cmp-007-class) 3 l)))
- collect (clos::need-to-make-load-form-p object nil))
- (nil nil t t))
-
-;;; Date: 18/05/2005
-;;; Fixed: 17/05/2006 (Brian Spilsbury & juanjo)
-;;; Description:
-;;;
-;;; The compiler is not able to externalize constants that have no printed representation.
-;;; In that case MAKE-LOAD-FORM should be used.
-;;;
-
-(deftest cmp-0008-make-load-form
- (let ((output (compile-file-pathname "aux-cmp-0008.lsp" :type :fasl)))
- (with-open-file (s "aux-cmp-0008.lsp" :if-exists :supersede :if-does-not-exist :create :direction :output)
- (princ "
-(eval-when (:compile-toplevel)
- (defvar s4 (make-instance 'cmp-007-class))
- (defvar s5 (make-instance 'cmp-007-class))
- (setf (cmp-007-parent s5) s4)
- (setf (cmp-007-children s4) (list s5)))
-
-(defvar a '#.s5)
-(defvar b '#.s4)
-(defvar c '#.s5)
-(defun foo ()
- (let ((*print-circle* t))
- (with-output-to-string (s) (princ '#1=(1 2 3 #.s4 #1#) s))))
-" s))
- (compile-file "aux-cmp-0008.lsp")
- (load output)
- (prog1 (foo)
- (delete-file output)
- (delete-file "aux-cmp-0008.lsp")))
- "#1=(1 2 3 # #1#)")
-
-;;; Date: 9/06/2006 (Pascal Costanza)
-;;; Fixed: 13/06/2006 (juanjo)
-;;; Description:
-;;;
-;;; A MACROLET function creates a set of local macro definitions.
-;;; The forms that expand these macros are themselves affected by
-;;; enclosing MACROLET and SYMBOL-MACRO definitions:
-;;; (defun bar ()
-;;; (macrolet ((x () 2))
-;;; (macrolet ((m () (x)))
-;;; (m))))
-;;; (compile 'bar)
-;;; (bar) => 2
-;;;
-(deftest cmp-0009-macrolet
- (list
- (progn
- (defun bar ()
- (macrolet ((x () 2))
- (macrolet ((m () (x)))
- (m))))
- (compile 'bar)
- (bar))
- (progn
- (defun bar ()
- (symbol-macrolet ((x 2))
- (macrolet ((m () x))
- (m))))
- (compile 'bar)
- (bar)))
- (2 2))
-
-;;; Fixed: 13/06/2006 (juanjo)
-;;; Description:
-;;;
-;;; A MACROLET that references a local variable from the form in
-;;; which it appears can cause corruption in the interpreter. We
-;;; solve this by signalling errors whenever such reference
-;;; happens.
-;;;
-;;; Additionally MACROLET forms should not see the other macro
-;;; definitions on the same form, much like FLET functions cannot
-;;; call their siblings.
-;;;
-(deftest cmp-0010-macrolet
- (flet ((eval-with-error (form)
- (handler-case (eval form)
- (error (c) 'error))))
- (makunbound 'cmp-0010-foo)
- (fmakunbound 'cmp-0010-foo)
- (let ((faa 1))
- (declare (special faa))
- (mapcar #'eval-with-error
- '((let ((faa 2))
- (macrolet ((m () faa))
- (m)))
- (let ((faa 4))
- (declare (special faa))
- (macrolet ((m () faa))
- (m)))
- (let ((faa 4))
- (declare (special cmp-0010-foo))
- (macrolet ((m () cmp-0010-foo))
- (m)))
- (let ((faa 5))
- (macrolet ((m () cmp-0010-foo))
- (m)))
- (macrolet ((cmp-0010-foo () 6))
- (macrolet ((m () (cmp-0010-foo)))
- (m)))
- (macrolet ((f1 () 7)
- (f2 () 8))
- ;; M should not see the new definitions F1 and F2
- (macrolet ((f1 () 9)
- (f2 () 10)
- (m () (list 'quote (list (f1) (f2)))))
- (m)))
- (flet ((cmp-0010-foo () 1))
- (macrolet ((m () (cmp-0010-foo)))
- (m)))
- (labels ((cmp-0010-foo () 1))
- (macrolet ((m () (cmp-0010-foo)))
- (m)))))))
- (error 1 error error 6 (7 8) error error ))
-
-;;; Date: 22/06/2006 (juanjo)
-;;; Fixed: 29/06/2006 (juanjo)
-;;; Description:
-;;;
-;;; ECL only accepted functions with less than 65 required
-;;; arguments. Otherwise it refused to compile the function. The fix must
-;;; respect the limit in the number of arguments passed in the C stack and
-;;; use the lisp stack for the other required arguments.
-;;;
-#-ecl-bytecmp
-(deftest cmp-0011-c-arguments-limit
- (mapcar #'(lambda (nargs)
- (let* ((arg-list (loop for i from 0 below nargs
- collect (intern (format nil "arg~d" i))))
- (data (loop for i from 0 below nargs collect i))
- (lambda-form `(lambda ,arg-list
- (and (equalp (list ,@arg-list) ',data)
- ,nargs)))
- (c:*compile-verbose* nil)
- (c:*compile-print* nil)
- (function (compile 'foo lambda-form)))
- (list (apply function (subseq data 0 nargs))
- (handler-case (apply function (make-list (1+ nargs)))
- (error (c) :error))
- (handler-case (apply function (make-list (1- nargs)))
- (error (c) :error)))))
- '(10 20 30 40 50 63 64 65 70))
- ((10 :ERROR :ERROR) (20 :ERROR :ERROR) (30 :ERROR :ERROR) (40 :ERROR :ERROR)
- (50 :ERROR :ERROR) (63 :ERROR :ERROR) (64 :ERROR :ERROR) (65 :ERROR :ERROR)
- (70 :ERROR :ERROR)))
-
-(let* ((nargs 10)
- (arg-list (loop for i from 0 below nargs
- collect (intern (format nil "arg~d" i))))
- (arguments (make-list nargs)))
- (apply (compile 'foo `(lambda ,arg-list
- (length (list ,@arg-list))))
- arguments))
-
-;;; Date: 12/07/2008 (Josh Elsasser)
-;;; Fixed: 02/08/2008 (Juanjo)
-;;; Description:
-;;;
-;;; ECL fails to properly compute the closure type of a function that
-;;; returns a lambda that calls the function itself.
-;;;
-(deftest cmp-0012-compute-closure
- (and (with-compiler ("aux-cmp-0003-paths.lsp" :load t)
- (defun testfun (outer)
- (labels ((testlabel (inner)
- (if inner
- (testfun-map
- (lambda (x) (testlabel x))
- inner))
- (print outer)))
- (testlabel outer))))
- t)
- t)
-
-;;; Date: 02/09/2008 (Josh Elsasser)
-;;; Fixed: 12/09/2008 (Josh Elsasser)
-;;; Description:
-;;;
-;;; FTYPE proclamations and declarations do not accept user defined
-;;; function types.
-;;;
-(deftest cmp-0013-ftype-user-type
- (progn
- (deftype cmp-0013-float-function () '(function (float) float))
- (deftype cmp-0013-float () 'float)
- (loop for (type . fails) in
- '(((function (float) float) . nil)
- (cons . t)
- (cmp-0013-float-function . nil)
- (cmp-0013-float . t))
- always (let ((form1 `(proclaim '(ftype ,type foo)))
- (form2 `(compile nil '(lambda ()
- (declare (ftype ,type foo))
- (foo)))))
- (if fails
- (and (signals-error (eval form1) error)
- (signals-error (eval form2) error)
- t)
- (progn
- (eval form1)
- (eval form2)
- t)))))
- t)
-
-;;; Date: 01/11/2008 (E. Marsden)
-;;; Fixed: 02/11/2008 (Juanjo)
-;;; Description:
-;;;
-;;; When compiled COERCE with type INTEGER may cause double
-;;; evaluation of a form.
-(deftest cmp-0014-coerce
- (funcall
- (compile 'foo '(lambda (x) (coerce (shiftf x 2) 'integer)))
- 1)
- 1)
-
-;;; Date: 03/11/2008 (E. Marsden)
-;;; Fixed: 08/11/2008 (Juanjo)
-;;; Description:
-;;;
-;;; TYPEP, with a real type, produces strange results.
-;;;
-(deftest cmp-0015-coerce
- (funcall
- (compile 'foo '(lambda (x) (typep (shiftf x 1) '(real 10 20))))
- 5)
- NIL)
-
-;;; Date: 20/07/2008 (Juanjo)
-;;; Fixed: 20/07/2008 (Juanjo)
-;;; Description:
-;;;
-;;; In the new compiler, when compiling LET forms with special variables
-;;; the values of the variables are not saved to make the assignments
-;;; really parallel.
-;;;
-(deftest cmp-0016-let-with-specials
- (progn
- (defvar *stak-x*)
- (defvar *stak-y*)
- (defvar *stak-z*)
- (funcall
- (compile
- nil
- '(lambda (*stak-x* *stak-y* *stak-z*)
- (labels
- ((stak-aux ()
- (if (not (< (the fixnum *stak-y*) (the fixnum *stak-x*)))
- *stak-z*
- (let ((*stak-x* (let ((*stak-x* (the fixnum (1- (the fixnum *stak-x*))))
- (*stak-y* *stak-y*)
- (*stak-z* *stak-z*))
- (stak-aux)))
- (*stak-y* (let ((*stak-x* (the fixnum (1- (the fixnum *stak-y*))))
- (*stak-y* *stak-z*)
- (*stak-z* *stak-x*))
- (stak-aux)))
- (*stak-z* (let ((*stak-x* (the fixnum (1- (the fixnum *stak-z*))))
- (*stak-y* *stak-x*)
- (*stak-z* *stak-y*))
- (stak-aux))))
- (stak-aux)))))
- (stak-aux)))) 18 12 6))
- 7)
-
-;;; Date: 06/10/2009 (J. Pellegrini)
-;;; Fixed: 06/10/2009 (Juanjo)
-;;; Description:
-;;; Extended strings were not accepted as documentation by the interpreter.
-;;;
-(deftest cmp-0017-docstrings
- (handler-case
- (progn
- (eval `(defun foo () ,(make-array 10 :initial-element #\Space :element-type 'character) 2))
- (eval (funcall 'foo)))
- (serious-condition (c) nil))
- 2)
-
-;;; Date: 07/11/2009 (A. Hefner)
-;;; Fixed: 07/11/2009 (A. Hefner + Juanjo)
-;;; Description:
-;;; ECL ignores the IGNORABLE declaration
-;;;
-(deftest cmp-0018-ignorable
- (let ((c::*suppress-compiler-messages* t))
- (and
- ;; Issue a warning for unused variables
- (handler-case (and (compile nil '(lambda (x y) (print x))) nil)
- (warning (c) t))
- ;; Do not issue a warning for unused variables declared IGNORE
- (handler-case (and (compile nil '(lambda (x y) (declare (ignore y))
- (print x))) t)
- (warning (c) nil))
- ;; Do not issue a warning for unused variables declared IGNORABLE
- (handler-case (and (compile nil '(lambda (x y) (declare (ignorable y))
- (print x))) t)
- (warning (c) nil))
- ;; Do not issue a warning for used variables declared IGNORABLE
- (handler-case (and (compile nil '(lambda (x y) (declare (ignorable x y))
- (print x))) t)
- (warning (c) nil))))
- t)
-
-;;; Date: 29/11/2009 (P. Costanza)
-;;; Fixed: 29/11/2009 (Juanjo)
-;;; Description:
-;;; When calling a bytecodes (SETF ...) function from a compiled function
-;;; an invalid memory access is produced. This is actually a consequence
-;;; of a mismatch between the position of the fields bytecodes.entry
-;;; and cfun.entry
-;;;
-(deftest cmp-0019-bytecodes-entry-position
- (let ((indices (funcall (compile nil
- '(lambda ()
- (ffi:c-inline () () list "
- union cl_lispunion x[0];
- cl_index bytecodes = (char*)(&(x->bytecodes.entry)) - (char*)x;
- cl_index bclosure = (char*)(&(x->bclosure.entry)) - (char*)x;
- cl_index cfun = (char*)(&(x->cfun.entry)) - (char*)x;
- cl_index cfunfixed = (char*)(&(x->cfunfixed.entry)) - (char*)x;
- cl_index cclosure = (char*)(&(x->cclosure.entry)) - (char*)x;
- @(return) = cl_list(5, MAKE_FIXNUM(bytecodes),
- MAKE_FIXNUM(bclosure),
- MAKE_FIXNUM(cfun),
- MAKE_FIXNUM(cfunfixed),
- MAKE_FIXNUM(cclosure));" :one-liner nil))))))
- (and (apply #'= indices) t))
- t)
-
-;;; Date: 07/02/2010 (W. Hebich)
-;;; Fixed: 07/02/2010 (Juanjo)
-;;; Description:
-;;; THE forms do not understand VALUES types
-;;; (the (values t) (funcall sym))
-;;;
-(deftest cmp-0020-the-and-values
- (handler-case (and (compile 'foo '(lambda () (the (values t) (faa))))
- t)
- (warning (c) nil))
- t)
-
-
-;;; Date: 28/03/2010 (M. Mondor)
-;;; Fixed: 28/03/2010 (Juanjo)
-;;; Description:
-;;; ECL does not compile type declarations of a symbol macro
-;;;
-(deftest cmp-0021-symbol-macro-declaration
- (handler-case (and (compile 'nil
- '(lambda (x)
- (symbol-macrolet ((y x))
- (declare (fixnum y))
- (+ y x))))
- nil)
- (warning (c) t))
- nil)
-
-;;; Date: 24/04/2010 (Juanjo)
-;;; Fixed 24/04/2010 (Juanjo)
-;;; Description:
-;;; New special form, WITH-BACKEND.
-;;;
-(deftest cmp-0022-with-backend
- (progn
- (defparameter *cmp-0022* nil)
- (defun cmp-0022a ()
- (ext:with-backend
- :bytecodes (setf *cmp-0022* :bytecodes)
- :c/c++ (setf *cmp-0022* :c/c++)))
- (list
- (progn (cmp-0022a) *cmp-0022*)
- (cmp-0022a)
- (progn (compile 'cmp-0022a) (cmp-0022a) *cmp-0022*)
- (cmp-0022a)))
- (:bytecodes :bytecodes :c/c++ :c/c++))
diff --git a/src/tests/bugs/doit.lsp b/src/tests/bugs/doit.lsp
deleted file mode 100644
index a2eef8699..000000000
--- a/src/tests/bugs/doit.lsp
+++ /dev/null
@@ -1,79 +0,0 @@
-;;; 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))
-#+(and ecl (not ecl-bytecmp))
-(setq c::*suppress-compiler-warnings* t c::*suppress-compiler-notes* t)
-
-(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 "test-ansi.lsp")
-(load "sf262--declaim-type-foo-setf-foo.lsp")
-(load "sf272--style-warning-argument-order.lsp")
-(load "sf276--write-hash-readably.lsp")
-(load "sf282--mvb-not-evaled.lsp")
-(load "sf286.lsp")
-
-(load "cl-001.lsp")
-
-(load "mixed.lsp")
-
-(load "int-001.lsp")
-
-#-ecl-bytecmp
-(load "cmp-001.lsp")
-
-#+clos
-(progn
- (load "mop-001.lsp")
- (load "mop-dispatch.lsp")
- (load "mop-dependents.lsp"))
-
-#+(and ffi (not ecl-bytecmp))
-(load "ffi-001.lsp")
-
-#+threads
-(progn
- (load "mp-tools.lsp")
- (load "mp-001.lsp")
- (load "mutex-001.lsp")
- (load "mailbox-001.lsp")
- )
-
-#+unicode
-(progn
- ;; 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
- #-msvc
- (when (zerop (si::system "iconv -l >/dev/null 2>&1"))
- (load "eformat-002.lsp"))
- (load "eformat-001.lsp"))
-
-;; (setf sb-rt::*expected-failures*
-;; (nconc sb-rt::*expected-failures*
-;; '(MOP-GF-ADD/REMOVE-DEPENDENT)))
-
-(time (sb-rt:do-tests))
diff --git a/src/tests/bugs/eformat-002.lsp b/src/tests/bugs/eformat-002.lsp
deleted file mode 100644
index 7555cf078..000000000
--- a/src/tests/bugs/eformat-002.lsp
+++ /dev/null
@@ -1,158 +0,0 @@
-;-*- Mode: Lisp -*-
-;;;; 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
-;;;;
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (unless (find-package :cl-test)
- (make-package :cl-test)))
-
-(in-package :cl-test)
-
-(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 "eformat-tmp/iconv-~A.txt" format-name))
- (decoded-filename (format nil "eformat-tmp/iconv-~A-utf32.txt" format-name))
- (iconv-filename (format nil "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.
-;;;
-(deftest eformat-0002-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
-
- :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
- (format t "~%;;; Testing ~A " name)
- (loop for i from 1 to 10
- always (test-output name (symbol-name name))))
- collect name)
- nil)
diff --git a/src/tests/bugs/int-001.lsp b/src/tests/bugs/int-001.lsp
deleted file mode 100644
index 4d4340d82..000000000
--- a/src/tests/bugs/int-001.lsp
+++ /dev/null
@@ -1,38 +0,0 @@
-;-*- Mode: Lisp -*-
-;;;; Author: Juan Jose Garcia-Ripoll
-;;;; Created: Fri Apr 14 11:13:17 CEST 2006
-;;;; Contains: Compiler regression tests
-
-(in-package :cl-test)
-
-;;; Description:
-;;;
-;;; The interpreter selectively complains when assigning a variable
-;;; that has not been declared as special and is not local.
-;;;
-;;; Fixed: 03/2006 (juanjo)
-;;;
-(deftest int-0001-global-setq
- (mapcar
- (lambda (ext:*action-on-undefined-variable*)
- (handler-case
- (progn (eval `(setq ,(gensym) 1)) :no-error)
- (error (c) :error)))
- '(nil ERROR))
- (:no-error :error))
-
-;;; Date: 24/04/2010 (Juanjo)
-;;; Fixed: 24/04/2010 (Juanjo)
-;;; Description:
-;;; The interpreter does not increase the lexical environment depth when
-;;; optimizing certain forms (LIST, LIST*, CONS...) and thus causes some
-;;; of the arguments to be eagerly evaluated.
-;;;
-(deftest int-0002-list-optimizer-error
- (with-output-to-string (*standard-output*)
- (eval '(list (print 1) (progn (print 2) (print 3)))))
- "
-1
-2
-3 ")
-
diff --git a/src/tests/bugs/mailbox-001.lsp b/src/tests/bugs/mailbox-001.lsp
deleted file mode 100644
index 41837b48a..000000000
--- a/src/tests/bugs/mailbox-001.lsp
+++ /dev/null
@@ -1,139 +0,0 @@
-;-*- Mode: Lisp -*-
-;;;; Author: Juan Jose Garcia-Ripoll
-;;;; Created: Fri Apr 14 11:13:17 CEST 2006
-;;;; Contains: Multithreading API regression tests
-
-(in-package :cl-test)
-
-;;; 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)
-
-;;; 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)
-
-;;; Date: 14/04/2012
-;;; The mailbox blocks a process when it saturates the write queue.
-(def-mp-test mbox-blocks-1-to-1
- (let* ((flag nil)
- (mbox (mp:make-mailbox :name "mbox-signal-one" :count 32))
- (size (mp:mailbox-count mbox))
- (a-process (mp:process-run-function
- "mbox-signal-one-process"
- #'(lambda ()
- ;; This does not block
- (loop for i from 1 to size
- do (mp:mailbox-send mbox i))
- ;; Here we block
- (setf flag t)
- (mp:mailbox-send mbox (1+ size))
- ;; Now we unblock
- (setf flag nil)))))
- (sleep 0.2) ; give time for all messages to arrive
- (and (not (mp:mailbox-empty-p mbox)) ; the queue has messages
- (mp:process-active-p a-process) ; the process is active
- flag ; and it is blocked
- (loop for i from 1 to (1+ size) ; messages arrive in order
- always (= i (mp:mailbox-read mbox)))
- (null flag) ; and process unblocked
- (mp:mailbox-empty-p mbox)
- t))
- t)
-
-;;; Date: 14/04/2012
-;;; N producers and 1 consumer
-(def-mp-test mbox-n-to-1-communication
- (loop with length = 10000
- with mbox = (mp:make-mailbox :name "mbox-n-to-1-communication" :count 128)
- for n from 1 to 10
- for m = (round length n)
- for messages = (loop for i from 0 below (* n m) collect i)
- for producers = (loop for i from 0 below n
- do (mp:process-run-function
- "mbox-n-to-1-producer"
- (let ((proc-no i))
- #'(lambda ()
- (loop for i from 0 below m
- for msg = (+ i (* proc-no m))
- do (mp:mailbox-send mbox msg))))))
- always (and (equalp
- (sort (loop for i from 1 to (* n m)
- collect (mp:mailbox-read mbox))
- #'<)
- messages)
- (mp:mailbox-empty-p mbox)))
- t)
-
-;;; 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)
-
-;;; 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)
-
diff --git a/src/tests/bugs/mixed.lsp b/src/tests/bugs/mixed.lsp
deleted file mode 100644
index 6e605bf82..000000000
--- a/src/tests/bugs/mixed.lsp
+++ /dev/null
@@ -1,18 +0,0 @@
-;-*- Mode: Lisp -*-
-;;;; Contains: Some 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)
diff --git a/src/tests/bugs/mop-001.lsp b/src/tests/bugs/mop-001.lsp
deleted file mode 100644
index 83654fb3e..000000000
--- a/src/tests/bugs/mop-001.lsp
+++ /dev/null
@@ -1,290 +0,0 @@
-;-*- Mode: Lisp -*-
-;;;; Author: Juan Jose Garcia-Ripoll
-;;;; Created: Fri Apr 14 11:13:17 CEST 2006
-;;;; Contains: Metaobject Protocol tests
-
-(in-package :cl-test)
-
-(use-package :clos)
-
-(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)))
diff --git a/src/tests/bugs/mop-dependents.lsp b/src/tests/bugs/mop-dependents.lsp
deleted file mode 100644
index a2316350b..000000000
--- a/src/tests/bugs/mop-dependents.lsp
+++ /dev/null
@@ -1,159 +0,0 @@
-;-*- Mode: Lisp -*-
-;;;; Author: Juan Jose Garcia-Ripoll
-;;;; Created: Sat Apr 23 09:02:03 CEST 2012
-;;;; Contains: Metaobject Protocol tests
-
-(in-package :cl-test)
-
-(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)
-
diff --git a/src/tests/bugs/mop-dispatch.lsp b/src/tests/bugs/mop-dispatch.lsp
deleted file mode 100644
index abaa4aa07..000000000
--- a/src/tests/bugs/mop-dispatch.lsp
+++ /dev/null
@@ -1,169 +0,0 @@
-;-*- Mode: Lisp -*-
-;;;; Author: Juan Jose Garcia-Ripoll
-;;;; Created: Sat Apr 23 10:18:00 CEST 2012
-;;;; Contains: Metaobject Protocol tests
-
-(in-package :cl-test)
-
-;;; 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)
-
diff --git a/src/tests/bugs/mp-001.lsp b/src/tests/bugs/mp-001.lsp
deleted file mode 100644
index 26e347bab..000000000
--- a/src/tests/bugs/mp-001.lsp
+++ /dev/null
@@ -1,44 +0,0 @@
-;-*- Mode: Lisp -*-
-;;;; Author: Juan Jose Garcia-Ripoll
-;;;; Created: Fri Apr 14 11:13:17 CEST 2006
-;;;; Contains: Multithreading API regression tests
-
-(in-package :cl-test)
-
-;;; Date: 04/09/2009
-;;; From: Matthew Mondor
-;;; Fixed: 05/09/2009 (Juanjo)
-;;; Description:
-;;;
-;;; 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
- (let ((flag t)
- (lock (mp:make-lock :name "mp-0001-with-lock" :recursive nil)))
- (mp:with-lock (lock)
- (let ((background-process
- (mp:process-run-function
- "mp-0001-with-lock"
- #'(lambda ()
- (handler-case
- (progn
- (setf flag 1)
- (mp:with-lock (lock)
- (setf flag 2)))
- (error (c)
- (princ c)(terpri)
- (setf flag c)))
- (setf flag 2)))))
- ;; The background process should not be able to get
- ;; the lock, and will simply wait. Now we interrupt it
- ;; and the process should gracefully quit, without
- ;; signalling any serious condition
- (and (progn (sleep 1)
- (mp:process-kill background-process))
- (progn (sleep 1)
- (not (mp:process-active-p background-process)))
- (eq flag 1)
- t))))
- t)
diff --git a/src/tests/bugs/mp-tools.lsp b/src/tests/bugs/mp-tools.lsp
deleted file mode 100644
index 8fb39c1c5..000000000
--- a/src/tests/bugs/mp-tools.lsp
+++ /dev/null
@@ -1,39 +0,0 @@
-;-*- Mode: Lisp -*-
-;;;; Author: Juan Jose Garcia-Ripoll
-;;;; Created: Fri Apr 14 CEST 2012
-;;;; Contains: Supporting routines for multithreaded tests
-
-(in-package :cl-test)
-
-(defun kill-and-wait (process-list &optional original wait)
- "Kills a list of processes, which may be the difference between two lists,
-waiting for all processes to finish. Currently it has no timeout, meaning
-it may block hard the lisp image."
- (let ((process-list (set-difference process-list original)))
- (when (member mp:*current-process* process-list)
- (error "Found myself in the kill list"))
- (mapc #'mp:process-kill process-list)
- (when wait
- (loop for i in process-list
- do (mp:process-join i)))
- process-list))
-
-(defun mp-test-run (closure)
- (let* ((all-processes (mp:all-processes))
- (output (multiple-value-list (funcall closure))))
- (sleep 0.2) ; time to exit some processes
- (let ((leftovers (kill-and-wait (mp:all-processes) all-processes)))
- (cond (leftovers
- (format t "~%;;; Stray processes: ~A" leftovers))
- (t
- (values-list output))))))
-
-(defmacro def-mp-test (name body expected-value)
- "Runs some test code and only returns the output when the code exited without
-creating stray processes."
- (let ((all-processes (gensym))
- (output (gensym))
- (leftover (gensym)))
- `(deftest ,name
- (mp-test-run #'(lambda () ,body))
- ,expected-value)))
diff --git a/src/tests/bugs/mutex-001.lsp b/src/tests/bugs/mutex-001.lsp
deleted file mode 100644
index 627032148..000000000
--- a/src/tests/bugs/mutex-001.lsp
+++ /dev/null
@@ -1,109 +0,0 @@
-;-*- Mode: Lisp -*-
-;;;; Author: Juan Jose Garcia-Ripoll
-;;;; Created: Fri Apr 12 CEST 2012
-;;;; Contains: Mutex tests
-
-(in-package :cl-test)
-
-;;; 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)
-
-;;; 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)
-
-
-;;; Date: 12/04/2012
-;;; When multiple threads compete for a mutex, they should
-;;; all get the same chance of accessing the resource
-;;;
-(def-mp-test mutex-003-fairness
- (let* ((mutex (mp:make-lock :name 'mutex-001-fairness))
- (nthreads 10)
- (count 10)
- (counter (* nthreads count))
- (array (make-array count :element-type 'fixnum :initial-element 0)))
- (flet ((slave (n)
- (loop with continue = t
- for i from 1 by 1
- while continue do
- (mp:get-lock mutex)
- (cond ((plusp counter)
- (decf counter)
- (setf (aref array n) i))
- (t
- (setf continue nil)))
- (mp:giveup-lock mutex))))
- ;; Launch all agents. They will be locked
- (let ((all-processes
- (mp:with-lock (mutex)
- (loop for n from 0 below nthreads
- collect (mp:process-run-function n #'slave n)
- ;; ... and give them some time to block on this mutex
- finally (sleep 1)))))
- ;; Now they are released and operate. They should all have
- ;; the same share of counts.
- (loop for p in all-processes
- do (mp:process-join p))
- (loop for i from 0 below nthreads
- always (= (aref array i) count)))))
- t)
-
-;;; Date: 12/04/2012
-;;; It is possible to kill processes waiting for a lock. We launch a lot of
-;;; processes, 50% of which are zombies: they acquire the lock and do not
-;;; do anything. These processes are then killed, resulting in the others
-;;; doing their job.
-;;;
-(def-mp-test mutex-004-interruptible
- (let* ((mutex (mp:make-lock :name "mutex-003-fairness"))
- (nprocesses 20)
- (counter 0))
- (flet ((normal-thread ()
- (mp:with-lock (mutex)
- (incf counter)))
- (zombie-thread ()
- (mp:with-lock (mutex)
- (loop (sleep 10)))))
- (let* ((all-processes (loop for i from 0 below nprocesses
- for zombie = (zerop (mod i 2))
- for fn = (if zombie #'zombie-thread #'normal-thread)
- collect (cons zombie
- (mp:process-run-function
- "mutex-003-fairness"
- fn))))
- (zombies (mapcar #'cdr (remove-if-not #'car all-processes))))
- (and (zerop counter) ; No proces works because the first one is a zombie
- (kill-and-wait zombies)
- (progn (sleep 0.2) (= counter (/ nprocesses 2)))
- (not (mp:lock-owner mutex))
- t))))
- t)
diff --git a/src/tests/bugs/num-001.lsp b/src/tests/bugs/num-001.lsp
deleted file mode 100644
index 23810770b..000000000
--- a/src/tests/bugs/num-001.lsp
+++ /dev/null
@@ -1,33 +0,0 @@
-;-*- Mode: Lisp -*-
-;;;; Author: Juan Jose Garcia-Ripoll
-;;;; Created: Fri Apr 14 11:13:17 CEST 2006
-;;;; Contains: Compiler regression tests
-
-(in-package :cl-test)
-
-;;; Date: 10/08/2008
-;;; From: Juanjo
-;;; Fixed: 10/08/2008
-;;; Description:
-;;;
-;;; COS, SIN and TAN were expanded using a wrong C expression.
-;;;
-
-(deftest num-0001-inline-cos
- (loop with *compile-verbose* = nil
- with *compile-print* = nil
- for type in '(short-float single-float double-float long-float)
- for sample = (coerce 1.0 type)
- for epsilon in '(#.short-float-epsilon #.single-float-epsilon #.double-float-epsilon #.long-float-epsilon)
- unless (loop for op in '(sin cos tan sinh cosh tanh)
- for f = (compile 'nil `(lambda (x)
- (declare (,type x)
- (optimize (safety 0)
- (speed 3)))
- (+ ,sample (,op x))))
- always (loop for x from (- pi) below pi by 0.05
- for xf = (float x sample)
- for error = (- (funcall f xf) (+ 1 (funcall op xf)))o
- always (< (abs error) epsilon)))
- collect type)
- nil)
diff --git a/src/tests/bugs/sem-001.lsp b/src/tests/bugs/sem-001.lsp
deleted file mode 100644
index e0adfe1cc..000000000
--- a/src/tests/bugs/sem-001.lsp
+++ /dev/null
@@ -1,226 +0,0 @@
-;-*- Mode: Lisp -*-
-;;;; Author: Juan Jose Garcia-Ripoll
-;;;; Created: Fri Apr 14 11:13:17 CEST 2006
-;;;; Contains: Multithreading API regression tests
-
-(in-package :cl-test)
-
-;;; 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)
-
-;;; 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)
-
-;;; Date: 14/04/2012
-;;; A semaphore with a count of zero blocks a process
-(def-mp-test sem-signal-one-process
- (let* ((flag nil)
- (sem (mp:make-semaphore :name "sem-signal-one"))
- (a-process (mp:process-run-function
- "sem-signal-one-process"
- #'(lambda ()
- (mp:wait-on-semaphore sem)
- (setf flag t)))))
- (and (null flag)
- (mp:process-active-p a-process)
- (progn (mp:signal-semaphore sem) (sleep 0.2) flag)
- (= (mp:semaphore-count sem) 0)))
- t)
-
-;;; 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)
-
-;;; 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)
-
-;;; Date: 14/04/2012
-;;; It is possible to kill processes waiting for a semaphore.
-;;;
-(def-mp-test sem-interruptible
- (loop with sem = (mp:make-semaphore :name "sem-interruptible")
- with flag = nil
- for count from 1 to 10
- for all-processes = (loop for i from 1 upto count
- collect (mp:process-run-function
- "sem-interruptible"
- #'(lambda ()
- (mp:wait-on-semaphore sem)
- (setf flag t))))
- always (and (progn (sleep 0.2) (null flag))
- (every #'mp:process-active-p all-processes)
- (= (mp:semaphore-wait-count sem) count)
- (mapc #'mp:process-kill all-processes)
- (progn (sleep 0.2) (notany #'mp:process-active-p all-processes))
- (null flag)
- (zerop (mp:semaphore-wait-count sem))
- t))
- t)
-
-;;; Date: 14/04/2012
-;;; When we kill a process, it is removed from the wait queue.
-;;;
-(def-mp-test sem-interrupt-updates-queue
- (let* ((sem (mp:make-semaphore :name "sem-interrupt-updates-queue"))
- (process (mp:process-run-function
- "sem-interrupt-updates-queue"
- #'(lambda () (mp:wait-on-semaphore sem)))))
- (sleep 0.2)
- (and (= (mp:semaphore-wait-count sem) 1)
- (mp:process-active-p process)
- (progn (mp:process-kill process)
- (sleep 0.2)
- (not (mp:process-active-p process)))
- (zerop (mp:semaphore-wait-count sem))
- t))
- t)
-
-;;; Date: 14/04/2012
-;;; When we kill a process, it signals another one. This is tricky,
-;;; because we need the awake signal to arrive _after_ the process is
-;;; 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)
-
-;;; Date: 14/04/2012
-;;; 1 producer and N consumers, non-blocking, because the initial count
-;;; is larger than the consumed data.
-(def-mp-test sem-1-to-n-non-blocking
- (loop with counter = 0
- with lock = (mp:make-lock :name "sem-1-to-n-communication")
- for n from 1 to 10
- for m = (round 128 n)
- for length = (* n m)
- for sem = (mp:make-semaphore :name "sem-1-to-n-communication" :count length)
- for producers = (progn
- (setf counter 0)
- (loop for i from 0 below n
- collect (mp:process-run-function
- "sem-1-to-n-consumer"
- #'(lambda ()
- (loop for i from 0 below m
- do (mp:wait-on-semaphore sem)
- do (mp:with-lock (lock) (incf counter)))))))
- do (mapc #'mp:process-join producers)
- always (and (= counter length)
- (zerop (mp:semaphore-count sem))
- (zerop (mp:semaphore-wait-count sem))))
- t)
-
-;;; Date: 14/04/2012
-;;; 1 producer and N consumers, blocking due to a slow producer.
-(def-mp-test sem-1-to-n-blocking
- (loop with lock = (mp:make-lock :name "sem-1-to-n-communication")
- for n from 1 to 10
- for m = (round 10000 n)
- for length = (* n m)
- for sem = (mp:make-semaphore :name "sem-1-to-n-communication" :count 0)
- for counter = 0
- for producers = (loop for i from 0 below n
- collect (mp:process-run-function
- "sem-1-to-n-consumer"
- #'(lambda ()
- (loop for i from 0 below m
- do (mp:wait-on-semaphore sem))
- (mp:with-lock (lock) (incf counter)))))
- do (loop for i from 0 below length
- do (mp:signal-semaphore sem))
- do (mapc #'mp:process-join producers)
- always (and (= counter n)
- (zerop (mp:semaphore-count sem))
- (zerop (mp:semaphore-wait-count sem))))
- t)
-4
diff --git a/src/tests/bugs/sf262--declaim-type-foo-setf-foo.lsp b/src/tests/bugs/sf262--declaim-type-foo-setf-foo.lsp
deleted file mode 100644
index 997e74c55..000000000
--- a/src/tests/bugs/sf262--declaim-type-foo-setf-foo.lsp
+++ /dev/null
@@ -1,22 +0,0 @@
-;; http://sourceforge.net/p/ecls/bugs/262
-
-(declaim (ftype (function (cons) t) foo))
-(declaim (ftype (function (t cons) t) (setf foo)))
-
-(defun foo (cons)
- (first cons))
-
-(defun (setf foo) (value cons)
- (setf (first cons) value))
-
-(defvar *c* (cons 'x 'y))
-
-(foo *c*) ;; correctly returns 'x
-
-;; signals an error:
-;; Z is not of type CONS.
-;; [Condition of type TYPE-ERROR]
-(deftest sf262--declaim-type-foo-setf-foo.lsp
- (assert (eq 'z
- (setf (foo *c*) 'z)))
- nil)
diff --git a/src/tests/bugs/sf272--style-warning-argument-order.lsp b/src/tests/bugs/sf272--style-warning-argument-order.lsp
deleted file mode 100644
index ec14cfa4c..000000000
--- a/src/tests/bugs/sf272--style-warning-argument-order.lsp
+++ /dev/null
@@ -1,21 +0,0 @@
-;; https://sourceforge.net/p/ecls/bugs/272
-
-(compile nil
- `(lambda (x) (1+ (the (values integer string) (funcall x)))))
-
-(deftest sf272--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)
diff --git a/src/tests/bugs/sf276--write-hash-readably.lsp b/src/tests/bugs/sf276--write-hash-readably.lsp
deleted file mode 100644
index f406dd95a..000000000
--- a/src/tests/bugs/sf276--write-hash-readably.lsp
+++ /dev/null
@@ -1,13 +0,0 @@
-; https://sourceforge.net/p/ecls/bugs/276/
-
-
-(print
- (write-to-string (make-hash-table)
- :readably t))
-
-(deftest sf-276-write-hash-readable
- (hash-table-count
- (read-from-string
- (write-to-string (make-hash-table)
- :readably t)))
- 0)
diff --git a/src/tests/bugs/sf282--mvb-not-evaled.lsp b/src/tests/bugs/sf282--mvb-not-evaled.lsp
deleted file mode 100644
index cd0bc8eb0..000000000
--- a/src/tests/bugs/sf282--mvb-not-evaled.lsp
+++ /dev/null
@@ -1,12 +0,0 @@
-
-;; https://sourceforge.net/p/ecls/bugs/282
-
-(deftest sf282--mvb-not-evaled
- (assert
- (eq :ok
- (block nil
- (tagbody
- (return (multiple-value-bind () (go :fail) :bad))
- :fail
- (return :ok)))))
- nil)
diff --git a/src/tests/bugs/sf286.lsp b/src/tests/bugs/sf286.lsp
deleted file mode 100644
index e5e3c2660..000000000
--- a/src/tests/bugs/sf286.lsp
+++ /dev/null
@@ -1,17 +0,0 @@
-;; miscompilation - assumed that read-from-string returns a fixnum.
-
-(deftest sf286-a
- (assert
- (let ((string ":cl-user"))
- (find-package
- (let ((*package* (find-package :cl)))
- (read-from-string string)))))
- nil)
-
-(deftest sf286-b
- (assert
- (let ((string ":cl-user"))
- (let ((*package* (find-package :cl)))
- (find-package
- (read-from-string string)))))
- nil)
diff --git a/src/tests/config.lsp.in b/src/tests/config.lsp.in
index 4848fe77e..f9f95bf99 100755
--- a/src/tests/config.lsp.in
+++ b/src/tests/config.lsp.in
@@ -45,7 +45,7 @@
(defvar *test-name* (or (ext:getenv "TEST_NAME") "ecl"))
(defvar *output-directory* *here*)
-(defvar *regressions-sources* (merge-pathnames "bugs/" *test-sources*))
+(defvar *regressions-sources* (merge-pathnames "regressions/" *test-sources*))
(defvar *regressions-sandbox* (merge-pathnames "regressions/" *here*))
(defvar *wild-inferiors* (make-pathname :name :wild
:type :wild
diff --git a/src/tests/bugs/ansi-aux.lsp b/src/tests/regressions/ansi-aux.lsp
similarity index 100%
rename from src/tests/bugs/ansi-aux.lsp
rename to src/tests/regressions/ansi-aux.lsp
diff --git a/src/tests/regressions/doit.lsp b/src/tests/regressions/doit.lsp
new file mode 100644
index 000000000..c232d866d
--- /dev/null
+++ b/src/tests/regressions/doit.lsp
@@ -0,0 +1,56 @@
+;;; 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))
+#+(and ecl (not ecl-bytecmp))
+(setq c::*suppress-compiler-warnings* t c::*suppress-compiler-notes* t)
+
+(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")
+
+(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))
diff --git a/src/tests/bugs/eformat-tests/hebrew_latin8_cr.txt b/src/tests/regressions/eformat-tests/hebrew_latin8_cr.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/hebrew_latin8_cr.txt
rename to src/tests/regressions/eformat-tests/hebrew_latin8_cr.txt
diff --git a/src/tests/bugs/eformat-tests/hebrew_latin8_crlf.txt b/src/tests/regressions/eformat-tests/hebrew_latin8_crlf.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/hebrew_latin8_crlf.txt
rename to src/tests/regressions/eformat-tests/hebrew_latin8_crlf.txt
diff --git a/src/tests/bugs/eformat-tests/hebrew_latin8_lf.txt b/src/tests/regressions/eformat-tests/hebrew_latin8_lf.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/hebrew_latin8_lf.txt
rename to src/tests/regressions/eformat-tests/hebrew_latin8_lf.txt
diff --git a/src/tests/bugs/eformat-tests/hebrew_utf8_cr.txt b/src/tests/regressions/eformat-tests/hebrew_utf8_cr.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/hebrew_utf8_cr.txt
rename to src/tests/regressions/eformat-tests/hebrew_utf8_cr.txt
diff --git a/src/tests/bugs/eformat-tests/hebrew_utf8_crlf.txt b/src/tests/regressions/eformat-tests/hebrew_utf8_crlf.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/hebrew_utf8_crlf.txt
rename to src/tests/regressions/eformat-tests/hebrew_utf8_crlf.txt
diff --git a/src/tests/bugs/eformat-tests/hebrew_utf8_lf.txt b/src/tests/regressions/eformat-tests/hebrew_utf8_lf.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/hebrew_utf8_lf.txt
rename to src/tests/regressions/eformat-tests/hebrew_utf8_lf.txt
diff --git a/src/tests/bugs/eformat-tests/kafka_cp1252_cr.txt b/src/tests/regressions/eformat-tests/kafka_cp1252_cr.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/kafka_cp1252_cr.txt
rename to src/tests/regressions/eformat-tests/kafka_cp1252_cr.txt
diff --git a/src/tests/bugs/eformat-tests/kafka_cp1252_crlf.txt b/src/tests/regressions/eformat-tests/kafka_cp1252_crlf.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/kafka_cp1252_crlf.txt
rename to src/tests/regressions/eformat-tests/kafka_cp1252_crlf.txt
diff --git a/src/tests/bugs/eformat-tests/kafka_cp1252_lf.txt b/src/tests/regressions/eformat-tests/kafka_cp1252_lf.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/kafka_cp1252_lf.txt
rename to src/tests/regressions/eformat-tests/kafka_cp1252_lf.txt
diff --git a/src/tests/bugs/eformat-tests/kafka_latin1_cr.txt b/src/tests/regressions/eformat-tests/kafka_latin1_cr.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/kafka_latin1_cr.txt
rename to src/tests/regressions/eformat-tests/kafka_latin1_cr.txt
diff --git a/src/tests/bugs/eformat-tests/kafka_latin1_crlf.txt b/src/tests/regressions/eformat-tests/kafka_latin1_crlf.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/kafka_latin1_crlf.txt
rename to src/tests/regressions/eformat-tests/kafka_latin1_crlf.txt
diff --git a/src/tests/bugs/eformat-tests/kafka_latin1_lf.txt b/src/tests/regressions/eformat-tests/kafka_latin1_lf.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/kafka_latin1_lf.txt
rename to src/tests/regressions/eformat-tests/kafka_latin1_lf.txt
diff --git a/src/tests/bugs/eformat-tests/kafka_utf8_cr.txt b/src/tests/regressions/eformat-tests/kafka_utf8_cr.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/kafka_utf8_cr.txt
rename to src/tests/regressions/eformat-tests/kafka_utf8_cr.txt
diff --git a/src/tests/bugs/eformat-tests/kafka_utf8_crlf.txt b/src/tests/regressions/eformat-tests/kafka_utf8_crlf.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/kafka_utf8_crlf.txt
rename to src/tests/regressions/eformat-tests/kafka_utf8_crlf.txt
diff --git a/src/tests/bugs/eformat-tests/kafka_utf8_lf.txt b/src/tests/regressions/eformat-tests/kafka_utf8_lf.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/kafka_utf8_lf.txt
rename to src/tests/regressions/eformat-tests/kafka_utf8_lf.txt
diff --git a/src/tests/bugs/eformat-tests/russian_koi8r_cr.txt b/src/tests/regressions/eformat-tests/russian_koi8r_cr.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/russian_koi8r_cr.txt
rename to src/tests/regressions/eformat-tests/russian_koi8r_cr.txt
diff --git a/src/tests/bugs/eformat-tests/russian_koi8r_crlf.txt b/src/tests/regressions/eformat-tests/russian_koi8r_crlf.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/russian_koi8r_crlf.txt
rename to src/tests/regressions/eformat-tests/russian_koi8r_crlf.txt
diff --git a/src/tests/bugs/eformat-tests/russian_koi8r_lf.txt b/src/tests/regressions/eformat-tests/russian_koi8r_lf.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/russian_koi8r_lf.txt
rename to src/tests/regressions/eformat-tests/russian_koi8r_lf.txt
diff --git a/src/tests/bugs/eformat-tests/russian_utf8_cr.txt b/src/tests/regressions/eformat-tests/russian_utf8_cr.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/russian_utf8_cr.txt
rename to src/tests/regressions/eformat-tests/russian_utf8_cr.txt
diff --git a/src/tests/bugs/eformat-tests/russian_utf8_crlf.txt b/src/tests/regressions/eformat-tests/russian_utf8_crlf.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/russian_utf8_crlf.txt
rename to src/tests/regressions/eformat-tests/russian_utf8_crlf.txt
diff --git a/src/tests/bugs/eformat-tests/russian_utf8_lf.txt b/src/tests/regressions/eformat-tests/russian_utf8_lf.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/russian_utf8_lf.txt
rename to src/tests/regressions/eformat-tests/russian_utf8_lf.txt
diff --git a/src/tests/bugs/eformat-tests/tilton_ascii_cr.txt b/src/tests/regressions/eformat-tests/tilton_ascii_cr.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/tilton_ascii_cr.txt
rename to src/tests/regressions/eformat-tests/tilton_ascii_cr.txt
diff --git a/src/tests/bugs/eformat-tests/tilton_ascii_crlf.txt b/src/tests/regressions/eformat-tests/tilton_ascii_crlf.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/tilton_ascii_crlf.txt
rename to src/tests/regressions/eformat-tests/tilton_ascii_crlf.txt
diff --git a/src/tests/bugs/eformat-tests/tilton_ascii_lf.txt b/src/tests/regressions/eformat-tests/tilton_ascii_lf.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/tilton_ascii_lf.txt
rename to src/tests/regressions/eformat-tests/tilton_ascii_lf.txt
diff --git a/src/tests/bugs/eformat-tests/tilton_utf8_cr.txt b/src/tests/regressions/eformat-tests/tilton_utf8_cr.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/tilton_utf8_cr.txt
rename to src/tests/regressions/eformat-tests/tilton_utf8_cr.txt
diff --git a/src/tests/bugs/eformat-tests/tilton_utf8_crlf.txt b/src/tests/regressions/eformat-tests/tilton_utf8_crlf.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/tilton_utf8_crlf.txt
rename to src/tests/regressions/eformat-tests/tilton_utf8_crlf.txt
diff --git a/src/tests/bugs/eformat-tests/tilton_utf8_lf.txt b/src/tests/regressions/eformat-tests/tilton_utf8_lf.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/tilton_utf8_lf.txt
rename to src/tests/regressions/eformat-tests/tilton_utf8_lf.txt
diff --git a/src/tests/bugs/eformat-tests/unicode_demo_ucs2_cr_be.txt b/src/tests/regressions/eformat-tests/unicode_demo_ucs2_cr_be.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/unicode_demo_ucs2_cr_be.txt
rename to src/tests/regressions/eformat-tests/unicode_demo_ucs2_cr_be.txt
diff --git a/src/tests/bugs/eformat-tests/unicode_demo_ucs2_cr_le.txt b/src/tests/regressions/eformat-tests/unicode_demo_ucs2_cr_le.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/unicode_demo_ucs2_cr_le.txt
rename to src/tests/regressions/eformat-tests/unicode_demo_ucs2_cr_le.txt
diff --git a/src/tests/bugs/eformat-tests/unicode_demo_ucs2_crlf_be.txt b/src/tests/regressions/eformat-tests/unicode_demo_ucs2_crlf_be.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/unicode_demo_ucs2_crlf_be.txt
rename to src/tests/regressions/eformat-tests/unicode_demo_ucs2_crlf_be.txt
diff --git a/src/tests/bugs/eformat-tests/unicode_demo_ucs2_crlf_le.txt b/src/tests/regressions/eformat-tests/unicode_demo_ucs2_crlf_le.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/unicode_demo_ucs2_crlf_le.txt
rename to src/tests/regressions/eformat-tests/unicode_demo_ucs2_crlf_le.txt
diff --git a/src/tests/bugs/eformat-tests/unicode_demo_ucs2_lf_be.txt b/src/tests/regressions/eformat-tests/unicode_demo_ucs2_lf_be.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/unicode_demo_ucs2_lf_be.txt
rename to src/tests/regressions/eformat-tests/unicode_demo_ucs2_lf_be.txt
diff --git a/src/tests/bugs/eformat-tests/unicode_demo_ucs2_lf_le.txt b/src/tests/regressions/eformat-tests/unicode_demo_ucs2_lf_le.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/unicode_demo_ucs2_lf_le.txt
rename to src/tests/regressions/eformat-tests/unicode_demo_ucs2_lf_le.txt
diff --git a/src/tests/bugs/eformat-tests/unicode_demo_ucs4_cr_be.txt b/src/tests/regressions/eformat-tests/unicode_demo_ucs4_cr_be.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/unicode_demo_ucs4_cr_be.txt
rename to src/tests/regressions/eformat-tests/unicode_demo_ucs4_cr_be.txt
diff --git a/src/tests/bugs/eformat-tests/unicode_demo_ucs4_cr_le.txt b/src/tests/regressions/eformat-tests/unicode_demo_ucs4_cr_le.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/unicode_demo_ucs4_cr_le.txt
rename to src/tests/regressions/eformat-tests/unicode_demo_ucs4_cr_le.txt
diff --git a/src/tests/bugs/eformat-tests/unicode_demo_ucs4_crlf_be.txt b/src/tests/regressions/eformat-tests/unicode_demo_ucs4_crlf_be.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/unicode_demo_ucs4_crlf_be.txt
rename to src/tests/regressions/eformat-tests/unicode_demo_ucs4_crlf_be.txt
diff --git a/src/tests/bugs/eformat-tests/unicode_demo_ucs4_crlf_le.txt b/src/tests/regressions/eformat-tests/unicode_demo_ucs4_crlf_le.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/unicode_demo_ucs4_crlf_le.txt
rename to src/tests/regressions/eformat-tests/unicode_demo_ucs4_crlf_le.txt
diff --git a/src/tests/bugs/eformat-tests/unicode_demo_ucs4_lf_be.txt b/src/tests/regressions/eformat-tests/unicode_demo_ucs4_lf_be.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/unicode_demo_ucs4_lf_be.txt
rename to src/tests/regressions/eformat-tests/unicode_demo_ucs4_lf_be.txt
diff --git a/src/tests/bugs/eformat-tests/unicode_demo_ucs4_lf_le.txt b/src/tests/regressions/eformat-tests/unicode_demo_ucs4_lf_le.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/unicode_demo_ucs4_lf_le.txt
rename to src/tests/regressions/eformat-tests/unicode_demo_ucs4_lf_le.txt
diff --git a/src/tests/bugs/eformat-tests/unicode_demo_utf8_cr.txt b/src/tests/regressions/eformat-tests/unicode_demo_utf8_cr.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/unicode_demo_utf8_cr.txt
rename to src/tests/regressions/eformat-tests/unicode_demo_utf8_cr.txt
diff --git a/src/tests/bugs/eformat-tests/unicode_demo_utf8_crlf.txt b/src/tests/regressions/eformat-tests/unicode_demo_utf8_crlf.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/unicode_demo_utf8_crlf.txt
rename to src/tests/regressions/eformat-tests/unicode_demo_utf8_crlf.txt
diff --git a/src/tests/bugs/eformat-tests/unicode_demo_utf8_lf.txt b/src/tests/regressions/eformat-tests/unicode_demo_utf8_lf.txt
similarity index 100%
rename from src/tests/bugs/eformat-tests/unicode_demo_utf8_lf.txt
rename to src/tests/regressions/eformat-tests/unicode_demo_utf8_lf.txt
diff --git a/src/tests/regressions/tests/compiler.lsp b/src/tests/regressions/tests/compiler.lsp
new file mode 100644
index 000000000..abefdd254
--- /dev/null
+++ b/src/tests/regressions/tests/compiler.lsp
@@ -0,0 +1,1108 @@
+;-*- Mode: Lisp -*-
+;;;; Author: Juan Jose Garcia-Ripoll
+;;;; Created: Fri Apr 14 11:13:17 CEST 2006
+;;;; Contains: Compiler regression tests
+
+(in-package :cl-test)
+
+
+;; cl-001
+
+;;; Date: 09/05/2006
+;;; From: Brian Spilsbury
+;;; Fixed: 20/05/2006 (Brian Spilsbury)
+;;; Description:
+;;;
+;;; (DEFPACKAGE "FOO" (:USE) (:IMPORT-FROM "CL" "NIL" "T"))
+;;; fails to import symbol NIL because IMPORT is invoked as
+;;; (IMPORT NIL (find-package "CL")), which does not import
+;;; any symbol.
+;;;
+
+(deftest compiler.0001.import
+ (progn
+ (defpackage "FOO" (:USE) (:IMPORT-FROM "CL" "NIL" "T"))
+ (prog1 (multiple-value-list (find-symbol "NIL" (find-package "FOO")))
+ (delete-package "FOO")))
+ (NIL :INTERNAL))
+
+;;; Date: 09/05/2006
+;;; From: Brian Spilsbury
+;;; Fixed: 20/05/2006 (Brian Spilsbury)
+;;; Description:
+;;;
+;;; Compiled FLET forms failed to shadow global macro definitions, if not
+;;; for the compiler, at least for MACRO-FUNCTION and MACROEXPAND[-1]
+;;;
+
+(deftest compiler.0002.macro-shadow
+ (progn
+ (with-compiler ("aux-cl-0002.lsp")
+ '(defmacro foo () 2)
+ '(defmacro test (symbol &environment env)
+ (and (macro-function symbol env) t))
+ '(defun doit () (flet ((foo () 1)) (test foo))))
+ (load "aux-cl-0002")
+ (delete-file "aux-cl-0002.lsp")
+ (delete-file (compile-file-pathname "aux-cl-0002" :type :fas))
+ (prog1
+ (doit)
+ (fmakunbound 'doit)
+ (fmakunbound 'test)
+ (fmakunbound 'foo)))
+ NIL)
+
+;;;
+;;; Fixed: 14/06/2006 (juanjo)
+;;; Description:
+;;;
+;;; APROPOS, APROPOS-LIST and HELP* are case sensitive.
+;;;
+
+(deftest compiler.0003.apropos
+ (and (equal (apropos-list "bin")
+ (apropos-list "bin"))
+ t)
+ t)
+
+;;; Date: 08/07/2006 (Dave Roberts)
+;;; Fixed: 02/08/2006 (juanjo)
+;;; Description:
+;;;
+;;; SLIME traps when invoking DESCRIBE. Reason is that STREAMP breaks on
+;;; Gray streams.
+;;;
+
+(deftest compiler.0004.streamp
+ (streamp (make-instance 'gray:fundamental-stream))
+ t)
+
+;;; Date: 02/08/2006 (juanjo)
+;;; Description:
+;;;
+;;; There is a problem with SUBTYPEP and type STREAM
+;;;
+
+(deftest compiler.0005.subtypep-stream
+ (subtypep (find-class 'gray:fundamental-stream) 'stream)
+ t t)
+
+;;; Date: 09/07/2006 (Tim S)
+;;; Fixed: 09/07/2006 (Tim S)
+;;; Description:
+;;;
+;;; ENOUGH-NAMESTRING provided too large pathnames even when the
+;;; pathname was a subdirectory of the default pathname.
+;;;
+;;; Date: 31/12/2006 (Richard M. Kreuter)
+;;; Fixed: 5/1/2007 (Juanjo)
+;;; Description:
+;;; ENOUGH-NAMESTRING does not simplify the pathname when the
+;;; directory matches completely that of the default path.
+;;;
+
+(defvar *enough-namestring_tests*
+ `(("/A/b/C/"
+ ("/A/b/C/drink-up.sot"
+ "/A/b/C/loozer/whiskey.sot"
+ "/A/b/C/loozer/whiskey"
+ "/A/b/whiskey.sot"
+ "/A/"
+ "whiskey.sot"
+ "loozer/whiskey.sot"
+ "C/loozer/whisky.sot"
+ ""))
+ ("A/b/C" ("A/b/C" "A/b/C/loozer" "b/C" "/A/b/C" "/A/" ""))
+ ("/" ("/A/b/C/drink-up.sot" "/A/b/C/" "/A/" ""))
+ ("" ("/A/b/C/drink-up.sot" "/A/b/C/loozer/whiskey.sot"
+ "/A/b/C/loozer/whiskey" "/A/b/whiskey.sot"
+ "/A/" "whiskey.sot" "loozer/whiskey.sot" "C/loozer/whisky.sot"))
+ ("/A/*/C/drink-up.sot"
+ ("/A/*/C/drink-up.sot" "/A/b/C/drink-up.sot" "/A/b/C/loozer/whiskey.*"
+ "/A/b/C/loozer/*.sot" "/A/**/whiskey.sot" ""))
+ ("/A/b/../c/d.sot" ("/A/b/../c/d.sot" "/A/b/../c/D/e.sot"
+ "/A/c/d.sot" "../c/d.sot"
+ "c/e/d.sot"))))
+
+(deftest compiler.0006.enough-namestring
+ (labels ((test-path (path defaults)
+ (let* ((e-ns (enough-namestring path defaults))
+ (d1 (pathname-directory path))
+ (d2 (pathname-directory defaults))
+ (d3 (pathname-directory e-ns)))
+ (and (equalp (merge-pathnames e-ns defaults)
+ (merge-pathnames (parse-namestring path nil defaults)
+ defaults))
+ ;; If directories concide, the "enough-namestring"
+ ;; removes the directory. But only if the pathname is
+ ;; absolute.
+ (not (and (equal (first d1) ':absolute)
+ (equalp d1 d2)
+ d3)))))
+ (test-default+paths (default+paths)
+ (let ((defaults (first default+paths))
+ (paths (second default+paths)))
+ (every (lambda (path)
+ (handler-case (test-path path defaults)
+ (error (error) 'NIL)))
+ paths))))
+ (every #'test-default+paths *enough-namestring_tests*))
+ t)
+
+;;; Date: 10/08/2006 (Lars Brinkhoff)
+;;; Fixed: 1/09/2006 (juanjo)
+;;; Details:
+;;;
+;;; ADJUST-ARRAY must signal a type error when the value of :FILL-POINTER is
+;;; not NIL and the adjustable array does not have a fill pointer
+;;;
+
+(deftest compiler.0007.adjustable-array
+ (loop for fp in '(nil t) collect
+ (loop for i in '(t nil 0 1 2 3) collect
+ (and
+ (handler-case (adjust-array (make-array 3 :adjustable t :fill-pointer fp) 4
+ :fill-pointer i)
+ (type-error (c) nil)
+ (error (c) t))
+ t)))
+ ((nil t nil nil nil nil) (t t t t t t)))
+
+;;; Date: 09/10/2006 (Dustin Long)
+;;; Fixed: 10/10/2006
+;;; Description:
+;;;
+;;; The namestring "." is improperly parsed, getting a file type of ""
+;;; Additionally we found it more convenient to have the _last_ dot mark
+;;; the file type, so that (pathname-type "foo.mpq.txt") => "txt"
+;;;
+
+(deftest compiler.0008.parse-namestring
+ (loop for (namestring name type) in
+ '(("." "." NIL) (".." "." "") (".foo" ".foo" NIL) (".foo.mpq.txt" ".foo.mpq" "txt")
+ ("foo.txt" "foo" "txt") ("foo.mpq.txt" "foo.mpq" "txt"))
+ unless (let ((x (parse-namestring namestring)))
+ (and (equal name (pathname-name x))
+ (equal type (pathname-type x))
+ (equal '() (pathname-directory x))))
+ collect namestring)
+ ())
+
+;;; Date: 28/09/2006
+;;; Fixed: 10/10/2006
+;;; Description:
+;;;
+;;; Nested calls to queue_finalizer trashed the value of cl_core.to_be_finalized
+;;; The following code tests that at least three objects are finalized.
+;;;
+;;; Note: this test fails in multithreaded mode. GC takes too long!
+(deftest compiler.0009.finalization
+ (let ((*all-tags* '()))
+ (declare (special *all-tags*))
+ (flet ((custom-finalizer (tag)
+ #'(lambda (o) (push tag *all-tags*))))
+ (let ((a '()))
+ (dotimes (i 5)
+ (let ((x (cons i i)))
+ (si::set-finalizer x (custom-finalizer i))
+ (push x a))))
+ (dotimes (j 100)
+ (dotimes (i 10000)
+ (cons 1.0 1.0))
+ (si::gc t)))
+ (sort *all-tags* #'<))
+ (0 1 2 3 4))
+
+
+;;; Date: 8/10/2006 (Dustin Long)
+;;; Fixed: 10/10/2006 (Dustin Long)
+;;; Description:
+;;;
+;;; Hash table iterators have to check that their argument is
+;;; really a hash table.
+;;;
+
+(deftest compiler.0010.hash-iterator
+ (loop for i in *mini-universe*
+ when (and (not (hash-table-p i))
+ (handler-case (progn (loop for k being the hash-keys of i) t)
+ (error (c) nil)))
+ collect (type-of i))
+ nil)
+
+;;; Date: 31/12/2006 (Richard M. Kreuter)
+;;; Fixed: 5/1/2007 (Juanjo)
+;;; Description:
+;;;
+;;; The keyword :BACK does not work as expected when creating pathnames
+;;; and causes an error when at the beginning: (:RELATIVE :BACK)
+;;;
+
+(deftest compiler.0011.make-pathname-with-back
+ (loop for i from 0 to 200
+ with l = (random 10)
+ with x = (if (zerop l) 0 (random (1+ l)))
+ with y = (if (= l x) 0 (random (- l x)))
+ nconc (let* ((l (loop for i from 0 below l collect (princ-to-string i)))
+ (l2 (append (subseq l 0 y) '("break" :back) (subseq l y nil)))
+ (d1 (list* :absolute (subseq l2 0 x)))
+ (d2 (list* :relative (subseq l2 x nil)))
+ (d3 (list* :absolute l2))
+ (d4 (list* :relative l2))
+ (p1 (handler-case (make-pathname :directory d1)
+ (error (c) nil)))
+ (p2 (handler-case (make-pathname :directory d2)
+ (error (c) nil)))
+ (p3 (handler-case (make-pathname :directory d3)
+ (error (c) nil)))
+ (p4 (handler-case (make-pathname :directory d4)
+ (error (c) nil))))
+ (if (and p1 p2 p3 p4
+ ;; MERGE-PATHNAMES eliminates :BACK
+ (equalp l (rest (pathname-directory (merge-pathnames p2 p1))))
+ ;; MAKE-PATHNAME does not eliminate :BACK
+ (not (equalp l (rest (pathname-directory (make-pathname :directory d3)))))
+ (not (equalp l (rest (pathname-directory (make-pathname :directory d4))))))
+ nil
+ (list (list l d1 d2 d3 d4 l2 x y)))))
+ nil)
+
+;;; Date: 11/03/2007 (Fare)
+;;; Fixed: 23/03/2007 (Juanjo)
+;;; Description:
+;;;
+;;; COPY-READTABLE did not copy the entries of the "from" table
+;;; when a second argument, i.e. a "destination" table was supplied.
+;;;
+
+(deftest compiler.0012.copy-readtable
+ (let ((from-readtable (copy-readtable))
+ (to-readtable (copy-readtable))
+ (char-list '()))
+ (dotimes (i 20)
+ (let* ((code (+ 32 (random 70)))
+ (c (code-char code)))
+ (push c char-list)
+ (set-macro-character c
+ (eval `(lambda (str ch) ,code))
+ nil
+ from-readtable)))
+ (copy-readtable from-readtable to-readtable)
+ (loop for c in char-list
+ unless (and (eql (char-code c)
+ (let ((*readtable* from-readtable))
+ (read-from-string (string c))))
+ (eq (get-macro-character c from-readtable)
+ (get-macro-character c to-readtable)))
+ collect c))
+ nil)
+
+;;; Date: 05/01/2008 (Anonymous, SF bug report)
+;;; Fixed: 06/01/2008 (Juanjo)
+;;; Description:
+;;;
+;;; For a file linked as follows "ln -s //usr/ /tmp/foo",
+;;; (truename #p"/tmp/foo") signals an error because //usr is
+;;; parsed as a hostname.
+;;;
+
+#-windows
+(deftest compiler.0013.truename
+ (progn
+ (si:system "rm -rf foo; ln -sf //usr/ foo")
+ (prog1 (namestring (truename "./foo"))
+ (si::system "rm foo")))
+ "/usr/")
+
+;;; Date: 30/08/2008 (Josh Elsasser)
+;;; Fixed: 01/09/2008 (Juanjo)
+;;; Description:
+;;;
+;;; Inside the form read by #., recursive definitions a la #n=
+;;; and #n# were not properly expanded
+;;;
+(deftest compiler.0014.sharp-dot
+ (with-output-to-string (*standard-output*)
+ (let ((*print-circle* t))
+ (read-from-string "'#.(princ (list '#1=(1 2) '#1#))")))
+ "(#1=(1 2) #1#)")
+
+;;; Date: 30/08/2008 (Josh Elsasser)
+;;; Fixed: 30/08/2008 (Josh Elsasser)
+;;; Description:
+;;;
+;;; A setf expansion that produces a form with a macro that also has
+;;; its own setf expansion does not giver rise to the right code.
+;;;
+(deftest compiler.0015-setf-expander
+ (progn
+ (define-setf-expander triple (place &environment env)
+ (multiple-value-bind (dummies vals newval setter getter)
+ (get-setf-expansion place env)
+ (let ((store (gensym)))
+ (values dummies
+ vals
+ `(,store)
+ `(let ((,(car newval) (/ ,store 3)))
+ (triple ,setter))
+ `(progn
+ (triple ,getter))))))
+ (defmacro hidden (val)
+ `(triple ,val))
+ (defmacro triple (val)
+ `(* 3 ,val))
+ (prog1
+ (equalp (eval '(let ((foo 5))
+ (list foo (triple foo) (setf (triple foo) 6) foo (triple foo))))
+ (eval '(let ((foo 5))
+ (list foo (hidden foo) (setf (hidden foo) 6) foo (hidden foo)))))
+ (fmakunbound 'hidden)
+ (fmakunbound 'triple)))
+ T)
+
+;;; Date: 17/2/2009
+;;; Fixed: 17/2/2009
+;;; Description:
+;;;
+;;; The defstruct form fails with an :include field that overwrites
+;;; a slot that is read only.
+;;;
+(deftest compiler.0016.defstruct-include
+ (progn
+ (eval '(progn
+ (defstruct compiler.0016-a (a 1 :read-only t))
+ (defstruct (compiler.0016-b (:include compiler.0016-a (a 2))))
+ (defstruct (compiler.0016-c (:include compiler.0016-a (a 3 :read-only t))))))
+ (values
+ (handler-case (eval '(defstruct (compiler.0016-d (:include compiler.0016-a (a 2 :read-only nil)))))
+ (error (c) t))
+ (compiler.0016-a-a (make-compiler.0016-a))
+ (compiler.0016-b-a (make-compiler.0016-b))
+ (compiler.0016-c-a (make-compiler.0016-c))
+ (handler-case (eval '(setf (compiler.0016-c-a (make-compiler.0016-c)) 3))
+ (error (c) t))))
+ t 1 2 3 t)
+
+;;; Date: 9/11/2009
+;;; Fixed: 9/11/2009
+;;; Description:
+;;;
+;;; LOAD does not work with special files (/dev/null)
+;;;
+(deftest compiler.0017.load-special
+ (handler-case (and (load #+(or windows mingw32) "NULL"
+ #-(or windows mingw32) "/dev/null")
+ t)
+ (serious-condition (c) nil))
+ t)
+
+;;; Date: 16/11/2009 (Gabriel)
+;;; Fixed: 20/11/2009 (Juanjo)
+;;; Description:
+;;;
+;;; #= and ## reader macros do not work well with #.
+;;;
+(deftest compiler.0018.sharp-eq
+ (handler-case (values (read-from-string "(#1=(0 1 2) #.(length '#1#))"))
+ (serious-condition (c) nil))
+ ((0 1 2) 3))
+
+;;; Date: 14/11/2009 (M. Mondor)
+;;; Fixed: 20/11/2009 (Juanjo)
+;;; Description:
+;;;
+;;; FDEFINITION and SYMBOL-FUNCTION cause SIGSEGV when acting on NIL.
+;;;
+(deftest compiler.0019.fdefinition
+ (and (handler-case (fdefinition nil)
+ (undefined-function (c) t)
+ (serious-condition (c) nil))
+ (handler-case (symbol-function nil)
+ (undefined-function (c) t)
+ (serious-condition (c) nil)))
+ t)
+
+
+;;; Date: 29/11/2009 (P. Costanza)
+;;; Fixed: 29/11/2009 (Juanjo)
+;;; Description:
+;;;
+;;; Updating of instances is not triggered by MAKE-INSTANCES-OBSOLETE.
+;;;
+(deftest compiler.0020.make-instances-obsolete
+ (progn
+ (defparameter *update-guard* nil)
+ (defclass compiler.0020-a () ((b :accessor compiler.0020-a-b :initarg :b)))
+ (let ((*a* (make-instance 'compiler.0020-a :b 2)))
+ (defmethod update-instance-for-redefined-class :before
+ ((instance standard-object) added-slots discarded-slots property-list
+ &rest initargs)
+ (setf *update-guard* t))
+ (and (null *update-guard*)
+ (progn (compiler.0020-a-b *a*) (null *update-guard*))
+ (progn (make-instances-obsolete (find-class 'compiler.0020-a))
+ (null *update-guard*))
+ (progn (compiler.0020-a-b *a*) *update-guard*)
+ (progn (setf *update-guard* nil)
+ (defclass compiler.0020-a () ((b :accessor compiler.0020-a-b :initarg :b)))
+ (compiler.0020-a-b *a*)
+ *update-guard*)
+ t)))
+ t)
+
+;;; Date: 25/03/2009 (R. Toy)
+;;; Fixed: 4/12/2009 (Juanjo)
+;;; Description:
+;;;
+;;; Conversion of rationals into floats is done by truncating, not by
+;;; rounding, what implies a loss of accuracy.
+;;;
+(deftest compiler.0021.ratio-to-float
+ ;; The test builds a ratio which is very close to 1 but which is below it
+ ;; If we truncate instead of rounding the output will not be 1 coerced
+ ;; to that floating point type.
+ (loop for type in '(short-float single-float double-float long-float)
+ for bits = (float-precision (coerce 1 type))
+ do (loop for i from (+ bits 7) to (+ bits 13)
+ nconc (loop with value = (ash 1 i)
+ with expected = (coerce 1 type)
+ for j from 0 to 10
+ for x = (- value j)
+ for r = (/ (1- x) x)
+ for f1 = (coerce r type)
+ for f2 = (- (coerce (- r) type))
+ unless (and (= f1 expected) (= f2 expected))
+ collect (list type r))))
+ nil)
+
+;;; Date: 06/04/2010 (M. Kocic)
+;;; Fixed: 4/12/2009
+;;; Description:
+;;;
+;;; Inspection of structs is broken due to undefined inspect-indent
+;;;
+(deftest compiler.0022.inspect-struct
+ (let ((*query-io* (make-string-input-stream "q
+")))
+ (defstruct st1 p1)
+ (let ((v1 (make-st1 :p1 "tttt")))
+ (handler-case (progn (inspect v1) t)
+ (error (c) nil))))
+ t)
+
+
+;; cmp-001
+
+;;; Date: 12/03/2006
+;;; From: Dan Corkill
+;;; Fixed: 14/04/2006 (juanjo)
+;;; Description:
+;;;
+;;; The inner RETURN form should return to the outer block.
+;;; However, the closure (lambda (x) ...) is improperly translated
+;;; by the compiler to (lambda (x) (block nil ...) and thus this
+;;; form outputs '(1 2 3 4).
+;;;
+(deftest compiler.0023.block
+ (funcall (compile nil
+ '(lambda ()
+ (block nil
+ (funcall 'mapcar
+ #'(lambda (x)
+ (when x (return x)))
+ '(1 2 3 4))))
+ ))
+ 1)
+
+;;; Fixed: 12/01/2006 (juanjo)
+;;; Description:
+;;;
+;;; COMPILE-FILE-PATHNAME now accepts both :FAS and :FASL as
+;;; synonyms.
+;;;
+;;;
+(deftest compiler.0024.pathname
+ (and (equalp (compile-file-pathname "foo" :type :fas)
+ (compile-file-pathname "foo" :type :fasl))
+ t)
+ t)
+
+;;; Fixed: 21/12/2005 (juanjo)
+;;; Description:
+;;;
+;;; Compute the path of the intermediate files (*.c, *.h, etc)
+;;; relative to that of the fasl or object file.
+;;;
+
+(deftest compiler.0025.paths
+ (let* ((output (compile-file-pathname "tmp/aux" :type :fasl))
+ (h-file (compile-file-pathname output :type :h))
+ (c-file (compile-file-pathname output :type :c))
+ (data-file (compile-file-pathname output :type :data)))
+ (and
+ (zerop (si::system "rm -rf tmp; mkdir tmp"))
+ (with-compiler ("aux-compiler.0103-paths.lsp" :output-file output :c-file t
+ :h-file t :data-file t)
+ '(defun foo (x) (1+ x)))
+ (probe-file output)
+ (probe-file c-file)
+ (probe-file h-file)
+ (probe-file data-file)
+ (delete-file "aux-compiler.0103-paths.lsp")
+ t))
+ t)
+
+;;; Date: 08/03/2006
+;;; From: Dan Corkill
+;;; Fixed: 09/03/2006 (juanjo)
+;;; Description:
+;;;
+;;; DEFCONSTANT does not declare the symbol as global and thus the
+;;; compiler issues warnings when the symbol is referenced in the
+;;; same file in which it is defined as constant.
+;;;
+
+#-ecl-bytecmp
+(deftest compiler.0026.defconstant-warn
+ (let ((warn nil))
+ (with-dflet ((c::cmpwarn (setf warn t)))
+ (with-compiler ("aux-compiler.0104.lsp")
+ '(defconstant foo (list 1 2 3))
+ '(print foo)))
+ (delete-file "aux-compiler.0104.lsp")
+ (delete-file (compile-file-pathname "aux-compiler.0104.lsp" :type :fas))
+ warn)
+ nil)
+
+;;; Date: 16/04/2006
+;;; From: Juanjo
+;;; Fixed: 16/04/2006 (juanjo)
+;;; Description:
+;;;
+;;; Special declarations should only affect the variable bound and
+;;; not their initialization forms. That, even if the variables are
+;;; the arguments of a function.
+;;;
+
+(deftest compiler.0027.declaration
+ (let ((form '(lambda (y)
+ (flet ((faa (&key (x y))
+ (declare (special y))
+ x))
+ (let ((y 4))
+ (declare (special y))
+ (faa))))))
+ ;; We must test that both the intepreted and the compiled form
+ ;; output the same value.
+ (list (funcall (compile 'nil form) 3)
+ (funcall (coerce form 'function) 3)))
+ (3 3))
+
+;;; Date: 26/04/2006
+;;; From: Michael Goffioul
+;;; Fixed: ----
+;;; Description:
+;;;
+;;; Functions with more than 64 arguments have to be invoked using
+;;; the lisp stack.
+;;;
+
+(deftest compiler.0028.call-arguments-limit
+ (let ((form '(lambda ()
+ (list (list
+ 'a0 'b0 'c0 'd0 'e0 'f0 'g0 'h0 'i0
+ 'j0 'k0 'l0 'm0 'n0 'o0 'p0 'q0
+ 'r0 's0 't0 'u0 'v0 'w0 'x0 'y0 'z0
+ 'a1 'b1 'c1 'd1 'e1 'f1 'g1 'h1 'i1
+ 'j1 'k1 'l1 'm1 'n1 'o1 'p1 'q1
+ 'r1 's1 't1 'u1 'v1 'w1 'x1 'y1 'z1
+ 'a2 'b2 'c2 'd2 'e2 'f2 'g2 'h2 'i2
+ 'j2 'k2 'l2 'm2 'n2 'o2 'p2 'q2
+ 'r2 's2 't2 'u2 'v2 'w2 'x2 'y2 'z2
+ 'a3 'b3 'c3 'd3 'e3 'f3 'g3 'h3 'i3
+ 'j3 'k3 'l3 'm3 'n3 'o3 'p3 'q3
+ 'r3 's3 't3 'u3 'v3 'w3 'x3 'y3 'z3
+ 'a4 'b4 'c4 'd4 'e4 'f4 'g4 'h4 'i4
+ 'j4 'k4 'l4 'm4 'n4 'o4 'p4 'q4
+ 'r4 's4 't4 'u4 'v4 'w4 'x4 'y4 'z4
+ 'a5 'b5 'c5 'd5 'e5 'f5 'g5 'h5 'i5
+ 'j5 'k5 'l5 'm5 'n5 'o5 'p5 'q5
+ 'r5 's5 't5 'u5 'v5 'w5 'x5 'y5 'z5
+ 'a6 'b6 'c6 'd6 'e6 'f6 'g6 'h6 'i6
+ 'j6 'k6 'l6 'm6 'n6 'o6 'p6 'q6
+ 'r6 's6 't6 'u6 'v6 'w6 'x6 'y6 'z6)))))
+ (equal (funcall (compile 'foo form))
+ (funcall (coerce form 'function))))
+ t)
+
+;;; Date: 16/05/2005
+;;; Fixed: 18/05/2006 (juanjo)
+;;; Description:
+;;;
+;;; The detection of when a lisp constant has to be externalized using MAKE-LOAD-FORM
+;;; breaks down with some circular structures
+;;;
+
+(defclass compiler.017-class ()
+ ((parent :accessor compiler.017-parent :initform nil)
+ (children :initarg :children :accessor compiler.017-children :initform nil)))
+
+(defmethod make-load-form ((x compiler.017-class) &optional environment)
+ (declare (ignore environment))
+ (values
+ ;; creation form
+ `(make-instance ',(class-of x) :children ',(slot-value x 'children))
+ ;; initialization form
+ `(setf (compiler.017-parent ',x) ',(slot-value x 'parent))
+ ))
+
+(deftest compiler.0029.circular-load-form
+ (loop for object in
+ (let ((l (list 1 2 3)))
+ (list l
+ (subst 3 l l)
+ (make-instance 'compiler.017-class)
+ (subst (make-instance 'compiler.017-class) 3 l)))
+ collect (clos::need-to-make-load-form-p object nil))
+ (nil nil t t))
+
+;;; Date: 18/05/2005
+;;; Fixed: 17/05/2006 (Brian Spilsbury & juanjo)
+;;; Description:
+;;;
+;;; The compiler is not able to externalize constants that have no printed representation.
+;;; In that case MAKE-LOAD-FORM should be used.
+;;;
+
+(deftest compiler.0030.make-load-form
+ (let ((output (compile-file-pathname "aux-compiler.0108.lsp" :type :fasl)))
+ (with-open-file (s "aux-compiler.0108.lsp" :if-exists :supersede :if-does-not-exist :create :direction :output)
+ (princ "
+(eval-when (:compile-toplevel)
+ (defvar s4 (make-instance 'compiler.017-class))
+ (defvar s5 (make-instance 'compiler.017-class))
+ (setf (compiler.017-parent s5) s4)
+ (setf (compiler.017-children s4) (list s5)))
+
+(defvar a '#.s5)
+(defvar b '#.s4)
+(defvar c '#.s5)
+(defun foo ()
+ (let ((*print-circle* t))
+ (with-output-to-string (s) (princ '#1=(1 2 3 #.s4 #1#) s))))
+" s))
+ (compile-file "aux-compiler.0108.lsp")
+ (load output)
+ (prog1 (foo)
+ (delete-file output)
+ (delete-file "aux-compiler.0108.lsp")))
+ "#1=(1 2 3 # #1#)")
+
+;;; Date: 9/06/2006 (Pascal Costanza)
+;;; Fixed: 13/06/2006 (juanjo)
+;;; Description:
+;;;
+;;; A MACROLET function creates a set of local macro definitions.
+;;; The forms that expand these macros are themselves affected by
+;;; enclosing MACROLET and SYMBOL-MACRO definitions:
+;;; (defun bar ()
+;;; (macrolet ((x () 2))
+;;; (macrolet ((m () (x)))
+;;; (m))))
+;;; (compile 'bar)
+;;; (bar) => 2
+;;;
+(deftest compiler.0031.macrolet
+ (list
+ (progn
+ (defun bar ()
+ (macrolet ((x () 2))
+ (macrolet ((m () (x)))
+ (m))))
+ (compile 'bar)
+ (bar))
+ (progn
+ (defun bar ()
+ (symbol-macrolet ((x 2))
+ (macrolet ((m () x))
+ (m))))
+ (compile 'bar)
+ (bar)))
+ (2 2))
+
+;;; Fixed: 13/06/2006 (juanjo)
+;;; Description:
+;;;
+;;; A MACROLET that references a local variable from the form in
+;;; which it appears can cause corruption in the interpreter. We
+;;; solve this by signalling errors whenever such reference
+;;; happens.
+;;;
+;;; Additionally MACROLET forms should not see the other macro
+;;; definitions on the same form, much like FLET functions cannot
+;;; call their siblings.
+;;;
+(deftest compiler.0032.macrolet
+ (flet ((eval-with-error (form)
+ (handler-case (eval form)
+ (error (c) 'error))))
+ (makunbound 'compiler.0110-foo)
+ (fmakunbound 'compiler.0110-foo)
+ (let ((faa 1))
+ (declare (special faa))
+ (mapcar #'eval-with-error
+ '((let ((faa 2))
+ (macrolet ((m () faa))
+ (m)))
+ (let ((faa 4))
+ (declare (special faa))
+ (macrolet ((m () faa))
+ (m)))
+ (let ((faa 4))
+ (declare (special compiler.0110-foo))
+ (macrolet ((m () compiler.0110-foo))
+ (m)))
+ (let ((faa 5))
+ (macrolet ((m () compiler.0110-foo))
+ (m)))
+ (macrolet ((compiler.0110-foo () 6))
+ (macrolet ((m () (compiler.0110-foo)))
+ (m)))
+ (macrolet ((f1 () 7)
+ (f2 () 8))
+ ;; M should not see the new definitions F1 and F2
+ (macrolet ((f1 () 9)
+ (f2 () 10)
+ (m () (list 'quote (list (f1) (f2)))))
+ (m)))
+ (flet ((compiler.0110-foo () 1))
+ (macrolet ((m () (compiler.0110-foo)))
+ (m)))
+ (labels ((compiler.0110-foo () 1))
+ (macrolet ((m () (compiler.0110-foo)))
+ (m)))))))
+ (error 1 error error 6 (7 8) error error ))
+
+;;; Date: 22/06/2006 (juanjo)
+;;; Fixed: 29/06/2006 (juanjo)
+;;; Description:
+;;;
+;;; ECL only accepted functions with less than 65 required
+;;; arguments. Otherwise it refused to compile the function. The fix must
+;;; respect the limit in the number of arguments passed in the C stack and
+;;; use the lisp stack for the other required arguments.
+;;;
+#-ecl-bytecmp
+(deftest compiler.0033.c-arguments-limit
+ (mapcar #'(lambda (nargs)
+ (let* ((arg-list (loop for i from 0 below nargs
+ collect (intern (format nil "arg~d" i))))
+ (data (loop for i from 0 below nargs collect i))
+ (lambda-form `(lambda ,arg-list
+ (and (equalp (list ,@arg-list) ',data)
+ ,nargs)))
+ (c:*compile-verbose* nil)
+ (c:*compile-print* nil)
+ (function (compile 'foo lambda-form)))
+ (list (apply function (subseq data 0 nargs))
+ (handler-case (apply function (make-list (1+ nargs)))
+ (error (c) :error))
+ (handler-case (apply function (make-list (1- nargs)))
+ (error (c) :error)))))
+ '(10 20 30 40 50 63 64 65 70))
+ ((10 :ERROR :ERROR) (20 :ERROR :ERROR) (30 :ERROR :ERROR) (40 :ERROR :ERROR)
+ (50 :ERROR :ERROR) (63 :ERROR :ERROR) (64 :ERROR :ERROR) (65 :ERROR :ERROR)
+ (70 :ERROR :ERROR)))
+
+(let* ((nargs 10)
+ (arg-list (loop for i from 0 below nargs
+ collect (intern (format nil "arg~d" i))))
+ (arguments (make-list nargs)))
+ (apply (compile 'foo `(lambda ,arg-list
+ (length (list ,@arg-list))))
+ arguments))
+
+;;; Date: 12/07/2008 (Josh Elsasser)
+;;; Fixed: 02/08/2008 (Juanjo)
+;;; Description:
+;;;
+;;; ECL fails to properly compute the closure type of a function that
+;;; returns a lambda that calls the function itself.
+;;;
+(deftest compiler.0034.compute-closure
+ (and (with-compiler ("aux-compiler.0103-paths.lsp" :load t)
+ (defun testfun (outer)
+ (labels ((testlabel (inner)
+ (if inner
+ (testfun-map
+ (lambda (x) (testlabel x))
+ inner))
+ (print outer)))
+ (testlabel outer))))
+ t)
+ t)
+
+;;; Date: 02/09/2008 (Josh Elsasser)
+;;; Fixed: 12/09/2008 (Josh Elsasser)
+;;; Description:
+;;;
+;;; FTYPE proclamations and declarations do not accept user defined
+;;; function types.
+;;;
+(deftest compiler.0035.ftype-user-type
+ (progn
+ (deftype compiler.0113-float-function () '(function (float) float))
+ (deftype compiler.0113-float () 'float)
+ (loop for (type . fails) in
+ '(((function (float) float) . nil)
+ (cons . t)
+ (compiler.0113-float-function . nil)
+ (compiler.0113-float . t))
+ always (let ((form1 `(proclaim '(ftype ,type foo)))
+ (form2 `(compile nil '(lambda ()
+ (declare (ftype ,type foo))
+ (foo)))))
+ (if fails
+ (and (signals-error (eval form1) error)
+ (signals-error (eval form2) error)
+ t)
+ (progn
+ (eval form1)
+ (eval form2)
+ t)))))
+ t)
+
+;;; Date: 01/11/2008 (E. Marsden)
+;;; Fixed: 02/11/2008 (Juanjo)
+;;; Description:
+;;;
+;;; When compiled COERCE with type INTEGER may cause double
+;;; evaluation of a form.
+(deftest compiler.0036.coerce
+ (funcall
+ (compile 'foo '(lambda (x) (coerce (shiftf x 2) 'integer)))
+ 1)
+ 1)
+
+;;; Date: 03/11/2008 (E. Marsden)
+;;; Fixed: 08/11/2008 (Juanjo)
+;;; Description:
+;;;
+;;; TYPEP, with a real type, produces strange results.
+;;;
+(deftest compiler.0037.coerce
+ (funcall
+ (compile 'foo '(lambda (x) (typep (shiftf x 1) '(real 10 20))))
+ 5)
+ NIL)
+
+;;; Date: 20/07/2008 (Juanjo)
+;;; Fixed: 20/07/2008 (Juanjo)
+;;; Description:
+;;;
+;;; In the new compiler, when compiling LET forms with special variables
+;;; the values of the variables are not saved to make the assignments
+;;; really parallel.
+;;;
+(deftest compiler.0038.let-with-specials
+ (progn
+ (defvar *stak-x*)
+ (defvar *stak-y*)
+ (defvar *stak-z*)
+ (funcall
+ (compile
+ nil
+ '(lambda (*stak-x* *stak-y* *stak-z*)
+ (labels
+ ((stak-aux ()
+ (if (not (< (the fixnum *stak-y*) (the fixnum *stak-x*)))
+ *stak-z*
+ (let ((*stak-x* (let ((*stak-x* (the fixnum (1- (the fixnum *stak-x*))))
+ (*stak-y* *stak-y*)
+ (*stak-z* *stak-z*))
+ (stak-aux)))
+ (*stak-y* (let ((*stak-x* (the fixnum (1- (the fixnum *stak-y*))))
+ (*stak-y* *stak-z*)
+ (*stak-z* *stak-x*))
+ (stak-aux)))
+ (*stak-z* (let ((*stak-x* (the fixnum (1- (the fixnum *stak-z*))))
+ (*stak-y* *stak-x*)
+ (*stak-z* *stak-y*))
+ (stak-aux))))
+ (stak-aux)))))
+ (stak-aux)))) 18 12 6))
+ 7)
+
+;;; Date: 06/10/2009 (J. Pellegrini)
+;;; Fixed: 06/10/2009 (Juanjo)
+;;; Description:
+;;; Extended strings were not accepted as documentation by the interpreter.
+;;;
+(deftest compiler.0039.docstrings
+ (handler-case
+ (progn
+ (eval `(defun foo () ,(make-array 10 :initial-element #\Space :element-type 'character) 2))
+ (eval (funcall 'foo)))
+ (serious-condition (c) nil))
+ 2)
+
+;;; Date: 07/11/2009 (A. Hefner)
+;;; Fixed: 07/11/2009 (A. Hefner + Juanjo)
+;;; Description:
+;;; ECL ignores the IGNORABLE declaration
+;;;
+(deftest compiler.0040.ignorable
+ (let ((c::*suppress-compiler-messages* t))
+ (and
+ ;; Issue a warning for unused variables
+ (handler-case (and (compile nil '(lambda (x y) (print x))) nil)
+ (warning (c) t))
+ ;; Do not issue a warning for unused variables declared IGNORE
+ (handler-case (and (compile nil '(lambda (x y) (declare (ignore y))
+ (print x))) t)
+ (warning (c) nil))
+ ;; Do not issue a warning for unused variables declared IGNORABLE
+ (handler-case (and (compile nil '(lambda (x y) (declare (ignorable y))
+ (print x))) t)
+ (warning (c) nil))
+ ;; Do not issue a warning for used variables declared IGNORABLE
+ (handler-case (and (compile nil '(lambda (x y) (declare (ignorable x y))
+ (print x))) t)
+ (warning (c) nil))))
+ t)
+
+;;; Date: 29/11/2009 (P. Costanza)
+;;; Fixed: 29/11/2009 (Juanjo)
+;;; Description:
+;;; When calling a bytecodes (SETF ...) function from a compiled function
+;;; an invalid memory access is produced. This is actually a consequence
+;;; of a mismatch between the position of the fields bytecodes.entry
+;;; and cfun.entry
+;;;
+#-ecl-bytcmp
+(deftest compiler.0041.bytecodes-entry-position
+ (let ((indices (funcall (compile nil
+ '(lambda ()
+ (ffi:c-inline () () list "
+ union cl_lispunion x[0];
+ cl_index bytecodes = (char*)(&(x->bytecodes.entry)) - (char*)x;
+ cl_index bclosure = (char*)(&(x->bclosure.entry)) - (char*)x;
+ cl_index cfun = (char*)(&(x->cfun.entry)) - (char*)x;
+ cl_index cfunfixed = (char*)(&(x->cfunfixed.entry)) - (char*)x;
+ cl_index cclosure = (char*)(&(x->cclosure.entry)) - (char*)x;
+ @(return) = cl_list(5, MAKE_FIXNUM(bytecodes),
+ MAKE_FIXNUM(bclosure),
+ MAKE_FIXNUM(cfun),
+ MAKE_FIXNUM(cfunfixed),
+ MAKE_FIXNUM(cclosure));" :one-liner nil))))))
+ (and (apply #'= indices) t))
+ t)
+
+;;; Date: 07/02/2010 (W. Hebich)
+;;; Fixed: 07/02/2010 (Juanjo)
+;;; Description:
+;;; THE forms do not understand VALUES types
+;;; (the (values t) (funcall sym))
+;;;
+(deftest compiler.0042.the-and-values
+ (handler-case (and (compile 'foo '(lambda () (the (values t) (faa))))
+ t)
+ (warning (c) nil))
+ t)
+
+
+;;; Date: 28/03/2010 (M. Mondor)
+;;; Fixed: 28/03/2010 (Juanjo)
+;;; Description:
+;;; ECL does not compile type declarations of a symbol macro
+;;;
+(deftest compiler.0043.symbol-macro-declaration
+ (handler-case (and (compile 'nil
+ '(lambda (x)
+ (symbol-macrolet ((y x))
+ (declare (fixnum y))
+ (+ y x))))
+ nil)
+ (warning (c) t))
+ nil)
+
+;;; Date: 24/04/2010 (Juanjo)
+;;; Fixed 24/04/2010 (Juanjo)
+;;; Description:
+;;; New special form, WITH-BACKEND.
+;;;
+(deftest compiler.0044.with-backend
+ (progn
+ (defparameter *compiler.0122* nil)
+ (defun compiler.0122a ()
+ (ext:with-backend
+ :bytecodes (setf *compiler.0122* :bytecodes)
+ :c/c++ (setf *compiler.0122* :c/c++)))
+ (list
+ (progn (compiler.0122a) *compiler.0122*)
+ (compiler.0122a)
+ (progn (compile 'compiler.0122a) (compiler.0122a) *compiler.0122*)
+ (compiler.0122a)))
+ (:bytecodes :bytecodes :c/c++ :c/c++))
+
+
+
+;;; Date: 10/08/2008
+;;; From: Juanjo
+;;; Fixed: 10/08/2008
+;;; Description:
+;;;
+;;; COS, SIN and TAN were expanded using a wrong C expression.
+;;;
+
+(deftest compiler.0045.inline-cos
+ (loop with *compile-verbose* = nil
+ with *compile-print* = nil
+ for type in '(short-float single-float double-float long-float)
+ for sample = (coerce 1.0 type)
+ for epsilon in '(#.short-float-epsilon #.single-float-epsilon #.double-float-epsilon #.long-float-epsilon)
+ unless (loop for op in '(sin cos tan sinh cosh tanh)
+ for f = (compile 'nil `(lambda (x)
+ (declare (,type x)
+ (optimize (safety 0)
+ (speed 3)))
+ (+ ,sample (,op x))))
+ always (loop for x from (- pi) below pi by 0.05
+ for xf = (float x sample)
+ for error = (- (funcall f xf) (+ 1 (funcall op xf)))
+ always (< (abs error) epsilon)))
+ collect type)
+ nil)
+
+
+
+;;; Description:
+;;;
+;;; The interpreter selectively complains when assigning a variable
+;;; that has not been declared as special and is not local.
+;;;
+;;; Fixed: 03/2006 (juanjo)
+;;;
+(deftest compiler.0046.global-setq
+ (mapcar
+ (lambda (ext:*action-on-undefined-variable*)
+ (handler-case
+ (progn (eval `(setq ,(gensym) 1)) :no-error)
+ (error (c) :error)))
+ '(nil ERROR))
+ (:no-error :error))
+
+;;; Date: 24/04/2010 (Juanjo)
+;;; Fixed: 24/04/2010 (Juanjo)
+;;; Description:
+;;; The interpreter does not increase the lexical environment depth when
+;;; optimizing certain forms (LIST, LIST*, CONS...) and thus causes some
+;;; of the arguments to be eagerly evaluated.
+;;;
+(deftest compiler.0046.list-optimizer-error
+ (with-output-to-string (*standard-output*)
+ (eval '(list (print 1) (progn (print 2) (print 3)))))
+ "
+1
+2
+3 ")
diff --git a/src/tests/bugs/emb-001.lsp b/src/tests/regressions/tests/embedding.lsp
similarity index 79%
rename from src/tests/bugs/emb-001.lsp
rename to src/tests/regressions/tests/embedding.lsp
index 033bf8ae0..e7706304a 100644
--- a/src/tests/bugs/emb-001.lsp
+++ b/src/tests/regressions/tests/embedding.lsp
@@ -6,11 +6,12 @@
(in-package :cl-test)
(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
:if-does-not-exist :create)
(princ c-code s))
(c::compiler-cc "tmp/aux.c" "tmp/aux.o")
- (c::linker-cc "tmp/aux.exe" "tmp/aux.o")
+ (c::linker-cc "tmp/aux.exe" '("tmp/aux.o"))
(case capture-output
(nil
(return-from test-C-program (zerop (si::system "tmp/aux.exe"))))
@@ -41,9 +42,10 @@
;;;
;;; Fixed: 03/2006 (juanjo)
;;;
-(deftest emb-0001-shutdown
- (let* ((skeleton "
+(deftest embedding.0001.shutdown
+ (let* ((skeleton "
#include
+#include
int main (int argc, char **argv) {
cl_object x;
cl_boot(argc, argv);
@@ -51,9 +53,8 @@ int main (int argc, char **argv) {
cl_shutdown();
exit(0);
}")
- (form '(push (lambda () (print :shutdown)) ext::*exit-hooks*))
- (c-code (format nil skeleton (format nil "~S" form)))
- (data (test-C-program (print 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 (print c-code) :capture-output t)))
+ data)
+ (:shutdown))
diff --git a/src/tests/bugs/eformat-001.lsp b/src/tests/regressions/tests/external-formats.lsp
similarity index 54%
rename from src/tests/bugs/eformat-001.lsp
rename to src/tests/regressions/tests/external-formats.lsp
index 91a7b4787..f20ceded1 100644
--- a/src/tests/bugs/eformat-001.lsp
+++ b/src/tests/regressions/tests/external-formats.lsp
@@ -13,6 +13,9 @@
(in-package :cl-test)
+
+;;; eformat-001
+
(defconstant +buffer-size+ 8192
"Size of buffers for COPY-STREAM* below.")
@@ -166,7 +169,7 @@ 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 eformat-0001-transcode-read-char
+(deftest external-format.0001-transcode-read-char
(do-eformat-test-001 'copy-stream)
nil)
@@ -179,6 +182,161 @@ 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 eformat-0002-transcode-read-char
+(deftest external-format.0002-transcode-read-char
(do-eformat-test-001 'copy-stream*)
nil)
+
+
+;;; 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 "eformat-tmp/iconv-~A.txt" format-name))
+ (decoded-filename (format nil "eformat-tmp/iconv-~A-utf32.txt" format-name))
+ (iconv-filename (format nil "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"))
+ (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
+
+ :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
+ (format t "~%;;; Testing ~A " name)
+ (loop for i from 1 to 10
+ always (test-output name (symbol-name name))))
+ collect name)
+ nil))
+
+
diff --git a/src/tests/bugs/ffi-001.lsp b/src/tests/regressions/tests/foreign-interface.lsp
similarity index 94%
rename from src/tests/bugs/ffi-001.lsp
rename to src/tests/regressions/tests/foreign-interface.lsp
index bac356a54..994905ac8 100644
--- a/src/tests/bugs/ffi-001.lsp
+++ b/src/tests/regressions/tests/foreign-interface.lsp
@@ -19,7 +19,7 @@
;;; Header should be included as
;;;
-(deftest ffi-001-callback
+(deftest foreign-interface.0001.callback
(and
(zerop (si::system "rm -rf tmp; mkdir tmp"))
(with-open-file (s "tmp/a.lsp" :direction :output
@@ -45,7 +45,7 @@
;;; Description:
;;; Callback examples based on the C compiler
;;;
-(deftest ffi-002-callback
+(deftest foreign-interface.0002.callback
(and
(zerop (si::system "rm -rf tmp; mkdir tmp"))
(with-open-file (s "tmp/c.lsp" :direction :output
@@ -74,8 +74,8 @@ int (*foo)(int) = #0;
;;; Callback examples based on the DFFI. Only work if this feature
;;; has been linked in.
;;;
-#+(or)
-(deftest ffi-002b-callback
+#+dffi
+(deftest foreign-interface.0003.callback
(and
(zerop (si::system "rm -rf tmp; mkdir tmp"))
(with-open-file (s "tmp/c.lsp" :direction :output
@@ -100,7 +100,7 @@ int (*foo)(int) = #0;
;;; Description:
;;; Regression test to ensure that two foreign data compare
;;; EQUAL when their addresses are the same.
-(deftest ffi-003-foreign-data-equal
+(deftest foreign-interface.0004.foreign-data-equal
(equal (ffi:make-pointer 1234 :void)
(ffi:make-pointer 1234 :int))
t)
diff --git a/src/tests/regressions/tests/metaobject-protocol.lsp b/src/tests/regressions/tests/metaobject-protocol.lsp
new file mode 100644
index 000000000..7e789d67d
--- /dev/null
+++ b/src/tests/regressions/tests/metaobject-protocol.lsp
@@ -0,0 +1,614 @@
+;-*- Mode: Lisp -*-
+;;;; Author: Juan Jose Garcia-Ripoll
+;;;; 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)
+
+
diff --git a/src/tests/regressions/tests/mixed.lsp b/src/tests/regressions/tests/mixed.lsp
new file mode 100644
index 000000000..9907d1645
--- /dev/null
+++ b/src/tests/regressions/tests/mixed.lsp
@@ -0,0 +1,106 @@
+;-*- Mode: Lisp -*-
+;;;; 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)
+
+
diff --git a/src/tests/regressions/tests/multiprocessing.lsp b/src/tests/regressions/tests/multiprocessing.lsp
new file mode 100644
index 000000000..312fadd98
--- /dev/null
+++ b/src/tests/regressions/tests/multiprocessing.lsp
@@ -0,0 +1,546 @@
+;-*- Mode: Lisp -*-
+;;;; Author: Juan Jose Garcia-Ripoll
+;;;; Created: Fri Apr 14 11:13:17 CEST 2006
+;;;; Contains: Multithreading API regression tests
+
+(in-package :cl-test)
+
+
+;; Auxiliary routines for multithreaded tests
+
+(defun kill-and-wait (process-list &optional original wait)
+ "Kills a list of processes, which may be the difference between two lists,
+waiting for all processes to finish. Currently it has no timeout, meaning
+it may block hard the lisp image."
+ (let ((process-list (set-difference process-list original)))
+ (when (member mp:*current-process* process-list)
+ (error "Found myself in the kill list"))
+ (mapc #'mp:process-kill process-list)
+ (when wait
+ (loop for i in process-list
+ do (mp:process-join i)))
+ process-list))
+
+(defun mp-test-run (closure)
+ (let* ((all-processes (mp:all-processes))
+ (output (multiple-value-list (funcall closure))))
+ (sleep 0.2) ; time to exit some processes
+ (let ((leftovers (kill-and-wait (mp:all-processes) all-processes)))
+ (cond (leftovers
+ (format t "~%;;; Stray processes: ~A" leftovers))
+ (t
+ (values-list output))))))
+
+(defmacro def-mp-test (name body expected-value)
+ "Runs some test code and only returns the output when the code exited without
+creating stray processes."
+ (let ((all-processes (gensym))
+ (output (gensym))
+ (leftover (gensym)))
+ `(deftest ,name
+ (mp-test-run #'(lambda () ,body))
+ ,expected-value)))
+
+
+;; Locks
+
+;;; Date: 04/09/2009
+;;; From: Matthew Mondor
+;;; Fixed: 05/09/2009 (Juanjo)
+;;; Description:
+;;;
+;;; 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
+ (let ((flag t)
+ (lock (mp:make-lock :name "mp-0001-with-lock" :recursive nil)))
+ (mp:with-lock (lock)
+ (let ((background-process
+ (mp:process-run-function
+ "mp-0001-with-lock"
+ #'(lambda ()
+ (handler-case
+ (progn
+ (setf flag 1)
+ (mp:with-lock (lock)
+ (setf flag 2)))
+ (error (c)
+ (princ c)(terpri)
+ (setf flag c)))
+ (setf flag 2)))))
+ ;; The background process should not be able to get
+ ;; the lock, and will simply wait. Now we interrupt it
+ ;; and the process should gracefully quit, without
+ ;; signalling any serious condition
+ (and (progn (sleep 1)
+ (mp:process-kill background-process))
+ (progn (sleep 1)
+ (not (mp:process-active-p background-process)))
+ (eq flag 1)
+ t))))
+ t)
+
+
+;; 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)
+
+;;; 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)
+
+;;; Date: 14/04/2012
+;;; A semaphore with a count of zero blocks a process
+(def-mp-test sem-signal-one-process
+ (let* ((flag nil)
+ (sem (mp:make-semaphore :name "sem-signal-one"))
+ (a-process (mp:process-run-function
+ "sem-signal-one-process"
+ #'(lambda ()
+ (mp:wait-on-semaphore sem)
+ (setf flag t)))))
+ (and (null flag)
+ (mp:process-active-p a-process)
+ (progn (mp:signal-semaphore sem) (sleep 0.2) flag)
+ (= (mp:semaphore-count sem) 0)))
+ t)
+
+;;; 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)
+
+;;; 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)
+
+;;; Date: 14/04/2012
+;;; It is possible to kill processes waiting for a semaphore.
+;;;
+(def-mp-test sem-interruptible
+ (loop with sem = (mp:make-semaphore :name "sem-interruptible")
+ with flag = nil
+ for count from 1 to 10
+ for all-processes = (loop for i from 1 upto count
+ collect (mp:process-run-function
+ "sem-interruptible"
+ #'(lambda ()
+ (mp:wait-on-semaphore sem)
+ (setf flag t))))
+ always (and (progn (sleep 0.2) (null flag))
+ (every #'mp:process-active-p all-processes)
+ (= (mp:semaphore-wait-count sem) count)
+ (mapc #'mp:process-kill all-processes)
+ (progn (sleep 0.2) (notany #'mp:process-active-p all-processes))
+ (null flag)
+ (zerop (mp:semaphore-wait-count sem))
+ t))
+ t)
+
+;;; Date: 14/04/2012
+;;; When we kill a process, it is removed from the wait queue.
+;;;
+(def-mp-test sem-interrupt-updates-queue
+ (let* ((sem (mp:make-semaphore :name "sem-interrupt-updates-queue"))
+ (process (mp:process-run-function
+ "sem-interrupt-updates-queue"
+ #'(lambda () (mp:wait-on-semaphore sem)))))
+ (sleep 0.2)
+ (and (= (mp:semaphore-wait-count sem) 1)
+ (mp:process-active-p process)
+ (progn (mp:process-kill process)
+ (sleep 0.2)
+ (not (mp:process-active-p process)))
+ (zerop (mp:semaphore-wait-count sem))
+ t))
+ t)
+
+;;; Date: 14/04/2012
+;;; When we kill a process, it signals another one. This is tricky,
+;;; because we need the awake signal to arrive _after_ the process is
+;;; 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)
+
+;;; Date: 14/04/2012
+;;; 1 producer and N consumers, non-blocking, because the initial count
+;;; is larger than the consumed data.
+(def-mp-test sem-1-to-n-non-blocking
+ (loop with counter = 0
+ with lock = (mp:make-lock :name "sem-1-to-n-communication")
+ for n from 1 to 10
+ for m = (round 128 n)
+ for length = (* n m)
+ for sem = (mp:make-semaphore :name "sem-1-to-n-communication" :count length)
+ for producers = (progn
+ (setf counter 0)
+ (loop for i from 0 below n
+ collect (mp:process-run-function
+ "sem-1-to-n-consumer"
+ #'(lambda ()
+ (loop for i from 0 below m
+ do (mp:wait-on-semaphore sem)
+ do (mp:with-lock (lock) (incf counter)))))))
+ do (mapc #'mp:process-join producers)
+ always (and (= counter length)
+ (zerop (mp:semaphore-count sem))
+ (zerop (mp:semaphore-wait-count sem))))
+ t)
+
+;;; Date: 14/04/2012
+;;; 1 producer and N consumers, blocking due to a slow producer.
+(def-mp-test sem-1-to-n-blocking
+ (loop with lock = (mp:make-lock :name "sem-1-to-n-communication")
+ for n from 1 to 10
+ for m = (round 10000 n)
+ for length = (* n m)
+ for sem = (mp:make-semaphore :name "sem-1-to-n-communication" :count 0)
+ for counter = 0
+ for producers = (loop for i from 0 below n
+ collect (mp:process-run-function
+ "sem-1-to-n-consumer"
+ #'(lambda ()
+ (loop for i from 0 below m
+ do (mp:wait-on-semaphore sem))
+ (mp:with-lock (lock) (incf counter)))))
+ do (loop for i from 0 below length
+ do (mp:signal-semaphore sem))
+ do (mapc #'mp:process-join producers)
+ always (and (= counter n)
+ (zerop (mp:semaphore-count sem))
+ (zerop (mp:semaphore-wait-count sem))))
+ t)
+
+
+;; Mutexes
+;;; 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)
+
+;;; 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)
+
+
+;;; Date: 12/04/2012
+;;; When multiple threads compete for a mutex, they should
+;;; all get the same chance of accessing the resource
+;;;
+(def-mp-test mutex-003-fairness
+ (let* ((mutex (mp:make-lock :name 'mutex-001-fairness))
+ (nthreads 10)
+ (count 10)
+ (counter (* nthreads count))
+ (array (make-array count :element-type 'fixnum :initial-element 0)))
+ (flet ((slave (n)
+ (loop with continue = t
+ for i from 1 by 1
+ while continue do
+ (mp:get-lock mutex)
+ (cond ((plusp counter)
+ (decf counter)
+ (setf (aref array n) i))
+ (t
+ (setf continue nil)))
+ (mp:giveup-lock mutex))))
+ ;; Launch all agents. They will be locked
+ (let ((all-processes
+ (mp:with-lock (mutex)
+ (loop for n from 0 below nthreads
+ collect (mp:process-run-function n #'slave n)
+ ;; ... and give them some time to block on this mutex
+ finally (sleep 1)))))
+ ;; Now they are released and operate. They should all have
+ ;; the same share of counts.
+ (loop for p in all-processes
+ do (mp:process-join p))
+ (loop for i from 0 below nthreads
+ always (= (aref array i) count)))))
+ t)
+
+;;; Date: 12/04/2012
+;;; It is possible to kill processes waiting for a lock. We launch a lot of
+;;; processes, 50% of which are zombies: they acquire the lock and do not
+;;; do anything. These processes are then killed, resulting in the others
+;;; doing their job.
+;;;
+(def-mp-test mutex-004-interruptible
+ (let* ((mutex (mp:make-lock :name "mutex-003-fairness"))
+ (nprocesses 20)
+ (counter 0))
+ (flet ((normal-thread ()
+ (mp:with-lock (mutex)
+ (incf counter)))
+ (zombie-thread ()
+ (mp:with-lock (mutex)
+ (loop (sleep 10)))))
+ (let* ((all-processes (loop for i from 0 below nprocesses
+ for zombie = (zerop (mod i 2))
+ for fn = (if zombie #'zombie-thread #'normal-thread)
+ collect (cons zombie
+ (mp:process-run-function
+ "mutex-003-fairness"
+ fn))))
+ (zombies (mapcar #'cdr (remove-if-not #'car all-processes))))
+ (and (zerop counter) ; No proces works because the first one is a zombie
+ (kill-and-wait zombies)
+ (progn (sleep 0.2) (= counter (/ nprocesses 2)))
+ (not (mp:lock-owner mutex))
+ t))))
+ t)
+
+
+;; Mailbox
+
+;;; 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)
+
+;;; 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)
+
+;;; Date: 14/04/2012
+;;; The mailbox blocks a process when it saturates the write queue.
+(def-mp-test mbox-blocks-1-to-1
+ (let* ((flag nil)
+ (mbox (mp:make-mailbox :name "mbox-signal-one" :count 32))
+ (size (mp:mailbox-count mbox))
+ (a-process (mp:process-run-function
+ "mbox-signal-one-process"
+ #'(lambda ()
+ ;; This does not block
+ (loop for i from 1 to size
+ do (mp:mailbox-send mbox i))
+ ;; Here we block
+ (setf flag t)
+ (mp:mailbox-send mbox (1+ size))
+ ;; Now we unblock
+ (setf flag nil)))))
+ (sleep 0.2) ; give time for all messages to arrive
+ (and (not (mp:mailbox-empty-p mbox)) ; the queue has messages
+ (mp:process-active-p a-process) ; the process is active
+ flag ; and it is blocked
+ (loop for i from 1 to (1+ size) ; messages arrive in order
+ always (= i (mp:mailbox-read mbox)))
+ (null flag) ; and process unblocked
+ (mp:mailbox-empty-p mbox)
+ t))
+ t)
+
+;;; Date: 14/04/2012
+;;; N producers and 1 consumer
+(def-mp-test mbox-n-to-1-communication
+ (loop with length = 10000
+ with mbox = (mp:make-mailbox :name "mbox-n-to-1-communication" :count 128)
+ for n from 1 to 10
+ for m = (round length n)
+ for messages = (loop for i from 0 below (* n m) collect i)
+ for producers = (loop for i from 0 below n
+ do (mp:process-run-function
+ "mbox-n-to-1-producer"
+ (let ((proc-no i))
+ #'(lambda ()
+ (loop for i from 0 below m
+ for msg = (+ i (* proc-no m))
+ do (mp:mailbox-send mbox msg))))))
+ always (and (equalp
+ (sort (loop for i from 1 to (* n m)
+ collect (mp:mailbox-read mbox))
+ #'<)
+ messages)
+ (mp:mailbox-empty-p mbox)))
+ t)
+
+;;; 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)
+
+;;; 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)
+
+
diff --git a/src/tests/bugs/test-ansi.lsp b/src/tests/regressions/tests/test-ansi.lsp
similarity index 100%
rename from src/tests/bugs/test-ansi.lsp
rename to src/tests/regressions/tests/test-ansi.lsp
diff --git a/src/tests/bugs/tools.lsp b/src/tests/regressions/tools.lsp
similarity index 100%
rename from src/tests/bugs/tools.lsp
rename to src/tests/regressions/tools.lsp
diff --git a/src/tests/bugs/universe.lsp b/src/tests/regressions/universe.lsp
similarity index 100%
rename from src/tests/bugs/universe.lsp
rename to src/tests/regressions/universe.lsp