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

Merge branch 'develop' of gitlab.com:embeddable-common-lisp/ecl into develop

Browse source
This commit is contained in:
Daniel Kochmański 2015-09-02 15:59:35 +02:00
commit ee2cab9c6e
77 changed files with 2610 additions and 2651 deletions
Download patch file Download diff file Expand all files Collapse all files

2
CHANGELOG
View file

@ -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

4
src/tests/Makefile.in
View file

@ -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

489
src/tests/bugs/cl-001.lsp
View file

@ -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)

557
src/tests/bugs/cmp-001.lsp
View file

@ -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 #<a CL-TEST::CMP-007-CLASS> #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++))

79
src/tests/bugs/doit.lsp
View file

@ -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))

158
src/tests/bugs/eformat-002.lsp
View file

@ -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)

38
src/tests/bugs/int-001.lsp
View file

@ -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 ")

139
src/tests/bugs/mailbox-001.lsp
View file

@ -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)

18
src/tests/bugs/mixed.lsp
View file

@ -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)

290
src/tests/bugs/mop-001.lsp
View file

@ -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)))

159
src/tests/bugs/mop-dependents.lsp
View file

@ -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)

169
src/tests/bugs/mop-dispatch.lsp
View file

@ -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)

44
src/tests/bugs/mp-001.lsp
View file

@ -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)

39
src/tests/bugs/mp-tools.lsp
View file

@ -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)))

109
src/tests/bugs/mutex-001.lsp
View file

@ -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)

33
src/tests/bugs/num-001.lsp
View file

@ -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)

226
src/tests/bugs/sem-001.lsp
View file

@ -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

22
src/tests/bugs/sf262--declaim-type-foo-setf-foo.lsp
View file

@ -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)

21
src/tests/bugs/sf272--style-warning-argument-order.lsp
View file

@ -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)

13
src/tests/bugs/sf276--write-hash-readably.lsp
View file

@ -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)

12
src/tests/bugs/sf282--mvb-not-evaled.lsp
View file

@ -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)

17
src/tests/bugs/sf286.lsp
View file

@ -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)

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

@ -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

0
src/tests/bugs/ansi-aux.lsp → src/tests/regressions/ansi-aux.lsp
View file

56
src/tests/regressions/doit.lsp Normal file
View file

@ -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))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

File diff suppressed because it is too large Load diff

19
src/tests/bugs/emb-001.lsp → src/tests/regressions/tests/embedding.lsp
View file

@ -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 <ecl/ecl.h>
#include <stdlib.h>
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))

162
src/tests/bugs/eformat-001.lsp → src/tests/regressions/tests/external-formats.lsp
View file

@ -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))

10
src/tests/bugs/ffi-001.lsp → src/tests/regressions/tests/foreign-interface.lsp
View file

@ -19,7 +19,7 @@
;;; Header <internal.h> should be included as <ecl/internal.h>
;;;
(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)

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

@ -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)

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

@ -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)

546
src/tests/regressions/tests/multiprocessing.lsp Normal file
View file

@ -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)

0
src/tests/bugs/test-ansi.lsp → src/tests/regressions/tests/test-ansi.lsp
View file

0
src/tests/bugs/tools.lsp → src/tests/regressions/tools.lsp
View file

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