mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-13 12:52:08 -08:00
tests: remove unused/outdated/unrelated tests
Signed-off-by: Daniel Kochmański <daniel@turtleware.eu>
This commit is contained in:
Daniel Kochmański
parent
31561c9d1d
commit
2e6596ae25
5 changed files with 1734 additions and 311 deletions
|
|
@ -2,62 +2,38 @@ ECL=@prefix@/@bindir@/ecl@EXEEXT@
|
|||
|
||||
all: show-fails
|
||||
|
||||
.PHONY: do-ansi do-regressions do-quicklisp cleanup clean-sources update
|
||||
.PHONY: do-regressions cleanup clean-sources update
|
||||
|
||||
BUGS_FILES := $(shell find ../../src/tests/bugs/ -type f)
|
||||
output.ecl/ansi.log: config.lsp
|
||||
$(MAKE) do-ansi
|
||||
|
||||
output.ecl/regressions.log: config.lsp
|
||||
regressions.log: config.lsp
|
||||
$(MAKE) do-regressions
|
||||
|
||||
do-ansi: ansi-tests config.lsp
|
||||
$(ECL) -norc -load config.lsp -eval '(ecl-tests::run-ansi-tests)' -eval '(ext:quit)' < /dev/null
|
||||
do-regressions: regressions config.lsp
|
||||
$(ECL) -norc -load config.lsp -eval '(ecl-tests::run-regressions-tests)' -eval '(ext:quit)' < /dev/null
|
||||
do-quicklisp: quicklisp config.lsp
|
||||
$(ECL) -norc -load config.lsp -eval '(ecl-tests::run-quicklisp-tests)' -eval '(ext:quit)' < /dev/null
|
||||
do-mop-tests: mop-features config.lsp
|
||||
$(ECL) -norc -load config.lsp -eval '(ecl-tests::run-mop-tests)' -eval '(ext:quit)' < /dev/null
|
||||
|
||||
show-fails: output.ecl/ansi.log output.ecl/regressions.log
|
||||
grep "^Test .* failed" output.ecl/ansi.log output.ecl/regressions.log
|
||||
show-fails: regressions.log
|
||||
grep "^Test .* failed" regressions.log
|
||||
|
||||
#
|
||||
# Create directories
|
||||
#
|
||||
ansi-tests: config.lsp
|
||||
wget "http://common-lisp.net/project/ecl/tests/ansi-tests.tar.gz" -P cache
|
||||
$(ECL) -norc -load config.lsp -eval '(ecl-tests::ensure-ansi-tests)' -eval '(ext:quit)' < /dev/null
|
||||
mop-features: config.lsp
|
||||
wget "http://common-lisp.net/project/ecl/tests/mop-features.tar.gz" -P cache
|
||||
$(ECL) -norc -load config.lsp -eval '(ecl-tests::ensure-mop-tests)' -eval '(ext:quit)' < /dev/null
|
||||
regressions: config.lsp ansi-tests $(BUGS_FILES)
|
||||
regressions: config.lsp $(BUGS_FILES)
|
||||
$(ECL) -norc -load config.lsp -eval '(ecl-tests::ensure-regressions)' -eval '(ext:quit)' < /dev/null
|
||||
quicklisp: config.lsp
|
||||
$(ECL) -norc -load config.lsp -eval '(ecl-tests::ensure-quicklisp)' -eval '(ext:quit)' < /dev/null
|
||||
|
||||
#
|
||||
# Test other implementations
|
||||
#
|
||||
test-sbcl:
|
||||
TEST_NAME=sbcl TEST_IMAGE=sbcl $(MAKE) do-ansi
|
||||
test-clisp:
|
||||
TEST_NAME=clisp TEST_IMAGE=clisp $(MAKE) do-ansi
|
||||
test-dx86cl64:
|
||||
TEST_NAME=dx86cl64 TEST_IMAGE=ccl $(MAKE) do-ansi
|
||||
|
||||
#
|
||||
# Cleanup
|
||||
#
|
||||
clean:
|
||||
rm -rf output*
|
||||
rm -rf regressions.log
|
||||
|
||||
clean-sources:
|
||||
test -f config.lsp.in || rm -rf bugs
|
||||
rm -rf ansi-tests quicklisp mop-features regressions
|
||||
rm -rf regressions
|
||||
|
||||
distclean: clean-sources clean
|
||||
rm -rf cache
|
||||
|
||||
update: clean-sources
|
||||
$(MAKE) ansi-tests regressions quicklisp mop-features
|
||||
$(MAKE) regressions
|
||||
|
||||
|
|
|
|||
1187
src/tests/bugs/ansi-aux.lsp
Normal file
1187
src/tests/bugs/ansi-aux.lsp
Normal file
File diff suppressed because it is too large
Load diff
|
|
@ -26,8 +26,8 @@
|
|||
(use-package :sb-rt)
|
||||
|
||||
(load "tools.lsp")
|
||||
(load "../ansi-tests/universe.lsp")
|
||||
(load "../ansi-tests/ansi-aux.lsp")
|
||||
(load "universe.lsp")
|
||||
(load "ansi-aux.lsp")
|
||||
|
||||
(load "sf262--declaim-type-foo-setf-foo.lsp")
|
||||
(load "sf272--style-warning-argument-order.lsp")
|
||||
|
|
|
|||
534
src/tests/bugs/universe.lsp
Normal file
534
src/tests/bugs/universe.lsp
Normal file
|
|
@ -0,0 +1,534 @@
|
|||
;-*- Mode: Lisp -*-
|
||||
;;;; Author: Paul Dietz
|
||||
;;;; Created: Thu Apr 9 19:32:56 1998
|
||||
;;;; Contains: A global variable containing a list of
|
||||
;;;; as many kinds of CL objects as we can think of
|
||||
;;;; This list is used to test many other CL functions
|
||||
|
||||
(in-package :cl-test)
|
||||
|
||||
(defparameter *condition-types*
|
||||
'(arithmetic-error
|
||||
cell-error
|
||||
condition
|
||||
control-error
|
||||
division-by-zero
|
||||
end-of-file
|
||||
error
|
||||
file-error
|
||||
floating-point-inexact
|
||||
floating-point-invalid-operation
|
||||
floating-point-underflow
|
||||
floating-point-overflow
|
||||
package-error
|
||||
parse-error
|
||||
print-not-readable
|
||||
program-error
|
||||
reader-error
|
||||
serious-condition
|
||||
simple-condition
|
||||
simple-error
|
||||
simple-type-error
|
||||
simple-warning
|
||||
storage-condition
|
||||
stream-error
|
||||
style-warning
|
||||
type-error
|
||||
unbound-slot
|
||||
unbound-variable
|
||||
undefined-function
|
||||
warning))
|
||||
|
||||
(defparameter *condition-objects*
|
||||
(locally (declare (optimize safety))
|
||||
(loop for tp in *condition-types* append
|
||||
(handler-case (list (make-condition tp))
|
||||
(error () nil)))))
|
||||
|
||||
(defparameter *standard-package-names*
|
||||
'("COMMON-LISP" "COMMON-LISP-USER" "KEYWORD"))
|
||||
|
||||
(defparameter *package-objects*
|
||||
(locally (declare (optimize safety))
|
||||
(loop for pname in *standard-package-names* append
|
||||
(handler-case (let ((pkg (find-package pname)))
|
||||
(and pkg (list pkg)))
|
||||
(error () nil)))))
|
||||
|
||||
(defparameter *integers*
|
||||
(remove-duplicates
|
||||
`(
|
||||
0
|
||||
;; Integers near the fixnum/bignum boundaries
|
||||
,@(loop for i from -5 to 5 collect (+ i most-positive-fixnum))
|
||||
,@(loop for i from -5 to 5 collect (+ i most-negative-fixnum))
|
||||
;; Powers of two, negatives, and off by one.
|
||||
,@(loop for i from 1 to 64 collect (ash 1 i))
|
||||
,@(loop for i from 1 to 64 collect (1- (ash 1 i)))
|
||||
,@(loop for i from 1 to 64 collect (ash -1 i))
|
||||
,@(loop for i from 1 to 64 collect (1+ (ash -1 i)))
|
||||
;; A big integer
|
||||
,(expt 17 50)
|
||||
;; Some arbitrarily chosen integers
|
||||
12387131 1272314 231 -131 -561823 23713 -1234611312123 444121 991)))
|
||||
|
||||
(defparameter *floats*
|
||||
(append
|
||||
(loop for sym in '(pi
|
||||
most-positive-short-float
|
||||
least-positive-short-float
|
||||
least-positive-normalized-short-float
|
||||
most-positive-double-float
|
||||
least-positive-double-float
|
||||
least-positive-normalized-double-float
|
||||
most-positive-long-float
|
||||
least-positive-long-float
|
||||
least-positive-normalized-long-float
|
||||
most-positive-single-float
|
||||
least-positive-single-float
|
||||
least-positive-normalized-single-float
|
||||
most-negative-short-float
|
||||
least-negative-short-float
|
||||
least-negative-normalized-short-float
|
||||
most-negative-single-float
|
||||
least-negative-single-float
|
||||
least-negative-normalized-single-float
|
||||
most-negative-double-float
|
||||
least-negative-double-float
|
||||
least-negative-normalized-double-float
|
||||
most-negative-long-float
|
||||
least-negative-long-float
|
||||
least-negative-normalized-long-float
|
||||
short-float-epsilon
|
||||
short-float-negative-epsilon
|
||||
single-float-epsilon
|
||||
single-float-negative-epsilon
|
||||
double-float-epsilon
|
||||
double-float-negative-epsilon
|
||||
long-float-epsilon
|
||||
long-float-negative-epsilon)
|
||||
when (boundp sym) collect (symbol-value sym))
|
||||
(list
|
||||
0.0 1.0 -1.0 313123.13 283143.231 -314781.9
|
||||
1.31283d2 834.13812D-45
|
||||
8131238.1E14 -4618926.231e-2
|
||||
-37818.131F3 81.318231f-19
|
||||
1.31273s3 12361.12S-7
|
||||
6124.124l0 13123.1L-23)))
|
||||
|
||||
(defparameter *ratios*
|
||||
'(1/3 1/1000 1/1000000000000000 -10/3 -1000/7 -987129387912381/13612986912361
|
||||
189729874978126783786123/1234678123487612347896123467851234671234))
|
||||
|
||||
(defparameter *complexes*
|
||||
'(#C(0.0 0.0)
|
||||
#C(1.0 0.0)
|
||||
#C(0.0 1.0)
|
||||
#C(1.0 1.0)
|
||||
#C(-1.0 -1.0)
|
||||
#C(1289713.12312 -9.12681271)
|
||||
#C(1.0D100 1.0D100)
|
||||
#C(-1.0D-100 -1.0D-100)
|
||||
#C(10.0s0 20.0s0)
|
||||
#C(100.0l0 200.0l0)
|
||||
#C(1.0s0 2.0f0)
|
||||
#C(1.0s0 3.0d0)
|
||||
#C(1.0s0 4.0l0)
|
||||
#C(1.0f0 5.0d0)
|
||||
#C(1.0f0 6.0l0)
|
||||
#C(1.0d0 7.0l0)
|
||||
#C(1.0f0 2.0s0)
|
||||
#C(1.0d0 3.0s0)
|
||||
#C(1.0l0 4.0s0)
|
||||
#C(1.0d0 5.0f0)
|
||||
#C(1.0l0 6.0f0)
|
||||
#C(1.0l0 7.0d0)
|
||||
#C(1/2 1/3)
|
||||
))
|
||||
|
||||
(defparameter *numbers*
|
||||
(append *integers*
|
||||
*floats*
|
||||
*ratios*
|
||||
*complexes*))
|
||||
|
||||
(defparameter *reals* (append *integers* *floats* *ratios*))
|
||||
|
||||
(defparameter *rationals* (append *integers* *ratios*))
|
||||
|
||||
(defun try-to-read-chars (&rest namelist)
|
||||
(declare (optimize safety))
|
||||
(loop
|
||||
for name in namelist append
|
||||
(handler-case
|
||||
(list (read-from-string
|
||||
(concatenate 'string "\#\\" name)))
|
||||
(error () nil))))
|
||||
|
||||
(defparameter *characters*
|
||||
(remove-duplicates
|
||||
`(#\Newline
|
||||
#\Space
|
||||
,@(try-to-read-chars "Rubout"
|
||||
"Page"
|
||||
"Tab"
|
||||
"Backspace"
|
||||
"Return"
|
||||
"Linefeed"
|
||||
"Null")
|
||||
#\a #\A #\0 #\9 #\. #\( #\) #\[ #\]
|
||||
)))
|
||||
|
||||
|
||||
(defparameter *strings*
|
||||
(append
|
||||
(and (code-char 0)
|
||||
(list
|
||||
(make-string 1 :initial-element (code-char 0))
|
||||
(make-string 10 :initial-element (code-char 0))))
|
||||
(list
|
||||
"" "A" "a" "0" "abcdef"
|
||||
"~!@#$%^&*()_+`1234567890-=<,>.?/:;\"'{[}]|\\ abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWYXZ"
|
||||
(make-string 100000 :initial-element #\g)
|
||||
(let ((s (make-string 256)))
|
||||
(loop
|
||||
for i from 0 to 255
|
||||
do (let ((c (code-char i)))
|
||||
(when c
|
||||
(setf (elt s i) c))))
|
||||
s)
|
||||
;; Specialized strings
|
||||
(make-array 3
|
||||
:element-type 'character
|
||||
:displaced-to (make-array 5 :element-type 'character
|
||||
:initial-contents "abcde")
|
||||
:displaced-index-offset 1)
|
||||
(make-array 10 :initial-element #\x
|
||||
:fill-pointer 5
|
||||
:element-type 'character)
|
||||
(make-array 10 :initial-element #\x
|
||||
:element-type 'base-char)
|
||||
(make-array 3 :initial-element #\y
|
||||
:adjustable t
|
||||
:element-type 'base-char)
|
||||
)))
|
||||
|
||||
(defparameter *conses*
|
||||
(list
|
||||
(list 'a 'b)
|
||||
(list nil)
|
||||
(list 1 2 3 4 5 6)))
|
||||
|
||||
(defparameter *circular-conses*
|
||||
(list
|
||||
(let ((s (copy-list '(a b c d))))
|
||||
(nconc s s)
|
||||
s)
|
||||
(let ((s (list nil)))
|
||||
(setf (car s) s)
|
||||
s)
|
||||
(let ((s (list nil)))
|
||||
(setf (car s) s)
|
||||
(setf (cdr s) s))))
|
||||
|
||||
(defparameter *booleans* '(nil t))
|
||||
(defparameter *keywords* '(:a :b :|| :|a| :|1234|))
|
||||
(defparameter *uninterned-symbols*
|
||||
(list '#:nil '#:t '#:foo '#:||))
|
||||
(defparameter *cl-test-symbols*
|
||||
`(,(intern "a" :cl-test)
|
||||
,(intern "" :cl-test)
|
||||
,@(and (code-char 0)
|
||||
(list (intern (make-string 1 :initial-element (code-char 0)) :cl-test)))
|
||||
,@(and (code-char 0)
|
||||
(let* ((s (make-string 10 :initial-element (code-char 0)))
|
||||
(s2 (copy-seq s))
|
||||
(s3 (copy-seq s)))
|
||||
(setf (subseq s 3 4) "a")
|
||||
(setf (subseq s2 4 5) "a")
|
||||
(setf (subseq s3 4 5) "a")
|
||||
(setf (subseq s3 7 8) "b")
|
||||
(list (intern s :cl-test)
|
||||
(intern s2 :cl-test)
|
||||
(intern s3 :cl-test))))
|
||||
))
|
||||
|
||||
(defparameter *cl-user-symbols*
|
||||
'(cl-user::foo
|
||||
cl-user::x
|
||||
cl-user::cons
|
||||
cl-user::lambda
|
||||
cl-user::*print-readably*
|
||||
cl-user::push))
|
||||
|
||||
(defparameter *symbols*
|
||||
(append *booleans* *keywords* *uninterned-symbols*
|
||||
*cl-test-symbols*
|
||||
*cl-user-symbols*))
|
||||
|
||||
(defparameter *array-dimensions*
|
||||
(loop
|
||||
for i from 0 to 8 collect
|
||||
(loop for j from 1 to i collect 2)))
|
||||
|
||||
(defparameter *default-array-target* (make-array '(300)))
|
||||
|
||||
(defparameter *arrays*
|
||||
(append
|
||||
(list (make-array '10))
|
||||
(mapcar #'make-array *array-dimensions*)
|
||||
|
||||
;; typed arrays
|
||||
(loop for tp in '(fixnum float bit character base-char
|
||||
(signed-byte 8) (unsigned-byte 8))
|
||||
for element in '(18 16.0f0 0 #\x #\y 127 200)
|
||||
append
|
||||
(loop
|
||||
for d in *array-dimensions*
|
||||
collect (make-array d :element-type tp
|
||||
:initial-element element)))
|
||||
|
||||
;; More typed arrays
|
||||
(loop for i from 1 to 64
|
||||
append
|
||||
(list (make-array 10 :element-type `(unsigned-byte ,i)
|
||||
:initial-element 1)
|
||||
(make-array 10 :element-type `(signed-byte ,i)
|
||||
:initial-element 0)))
|
||||
|
||||
;; adjustable arrays
|
||||
(loop
|
||||
for d in *array-dimensions*
|
||||
collect (make-array d :adjustable t))
|
||||
|
||||
;; Displaced arrays
|
||||
(loop
|
||||
for d in *array-dimensions*
|
||||
for i from 1
|
||||
collect (make-array d :displaced-to *default-array-target*
|
||||
:displaced-index-offset i))
|
||||
|
||||
(list
|
||||
#()
|
||||
#*
|
||||
#*00000
|
||||
#*1010101010101101
|
||||
(make-array 10 :element-type 'bit
|
||||
:initial-contents '(0 1 1 0 1 1 1 1 0 1)
|
||||
:fill-pointer 8)
|
||||
(make-array 5 :element-type 'bit
|
||||
:displaced-to #*0111000110
|
||||
:displaced-index-offset 3)
|
||||
(make-array 10 :element-type 'bit
|
||||
:initial-contents '(1 1 0 0 1 1 1 0 1 1)
|
||||
:adjustable t)
|
||||
)
|
||||
|
||||
;; Integer arrays
|
||||
(list
|
||||
(make-array '(10) :element-type '(integer 0 (256))
|
||||
:initial-contents '(8 9 10 11 12 1 2 3 4 5))
|
||||
(make-array '(10) :element-type '(integer -128 (128))
|
||||
:initial-contents '(8 9 -10 11 -12 1 -2 -3 4 5))
|
||||
(make-array '(6) :element-type '(integer 0 (#.(ash 1 16)))
|
||||
:initial-contents '(5 9 100 1312 23432 87))
|
||||
(make-array '(4) :element-type '(integer 0 (#.(ash 1 28)))
|
||||
:initial-contents '(100000 231213 8123712 19))
|
||||
(make-array '(4) :element-type '(integer 0 (#.(ash 1 32)))
|
||||
:initial-contents '(#.(1- (ash 1 32)) 0 872312 10000000))
|
||||
|
||||
(make-array nil :element-type '(integer 0 (256))
|
||||
:initial-element 14)
|
||||
(make-array '(2 2) :element-type '(integer 0 (256))
|
||||
:initial-contents '((34 98)(14 119)))
|
||||
)
|
||||
|
||||
;; Float arrays
|
||||
(list
|
||||
(make-array '(5) :element-type 'short-float
|
||||
:initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0))
|
||||
(make-array '(5) :element-type 'single-float
|
||||
:initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0))
|
||||
(make-array '(5) :element-type 'double-float
|
||||
:initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0))
|
||||
(make-array '(5) :element-type 'long-float
|
||||
:initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0))
|
||||
)
|
||||
|
||||
;; The ever-popular NIL array
|
||||
(locally (declare (optimize safety))
|
||||
(handler-case
|
||||
(list (make-array '(0) :element-type nil))
|
||||
(error () nil)))
|
||||
|
||||
;; more kinds of arrays here later?
|
||||
))
|
||||
|
||||
(defparameter *hash-tables*
|
||||
(list
|
||||
(make-hash-table)
|
||||
(make-hash-table :test #'eq)
|
||||
(make-hash-table :test #'eql)
|
||||
(make-hash-table :test #'equal)
|
||||
#-(or CMU ECL) (make-hash-table :test #'equalp)
|
||||
))
|
||||
|
||||
(defparameter *pathnames*
|
||||
(locally
|
||||
(declare (optimize safety))
|
||||
(loop for form in '((make-pathname :name "foo")
|
||||
(make-pathname :name "FOO" :case :common)
|
||||
(make-pathname :name "bar")
|
||||
(make-pathname :name "foo" :type "txt")
|
||||
(make-pathname :name "bar" :type "txt")
|
||||
(make-pathname :name "XYZ" :type "TXT" :case :common)
|
||||
(make-pathname :name nil)
|
||||
(make-pathname :name :wild)
|
||||
(make-pathname :name nil :type "txt")
|
||||
(make-pathname :name :wild :type "txt")
|
||||
(make-pathname :name :wild :type "TXT" :case :common)
|
||||
(make-pathname :name :wild :type "abc" :case :common)
|
||||
(make-pathname :directory :wild)
|
||||
(make-pathname :type :wild)
|
||||
(make-pathname :version :wild)
|
||||
(make-pathname :version :newest))
|
||||
append (ignore-errors (eval `(list ,form))))))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(locally
|
||||
(declare (optimize safety))
|
||||
(ignore-errors
|
||||
(setf (logical-pathname-translations "CLTESTROOT")
|
||||
`(("**;*.*.*" ,(make-pathname :directory '(:absolute :wild-inferiors)
|
||||
:name :wild :type :wild)))))
|
||||
(ignore-errors
|
||||
(setf (logical-pathname-translations "CLTEST")
|
||||
`(("**;*.*.*" ,(make-pathname
|
||||
:directory (append
|
||||
(pathname-directory
|
||||
(truename (make-pathname)))
|
||||
'(:wild-inferiors))
|
||||
:name :wild :type :wild)))))
|
||||
))
|
||||
|
||||
(defparameter *logical-pathnames*
|
||||
(locally
|
||||
(declare (optimize safety))
|
||||
(append
|
||||
(ignore-errors (list (logical-pathname "CLTESTROOT:")))
|
||||
)))
|
||||
|
||||
(defparameter *streams*
|
||||
(remove-duplicates
|
||||
(remove-if
|
||||
#'null
|
||||
(list
|
||||
*debug-io*
|
||||
*error-output*
|
||||
*query-io*
|
||||
*standard-input*
|
||||
*standard-output*
|
||||
*terminal-io*
|
||||
*trace-output*))))
|
||||
|
||||
(defparameter *readtables*
|
||||
(list *readtable*
|
||||
(copy-readtable)))
|
||||
|
||||
(defstruct foo-structure
|
||||
x y z)
|
||||
|
||||
(defstruct bar-structure
|
||||
x y z)
|
||||
|
||||
(defparameter *structures*
|
||||
(list
|
||||
(make-foo-structure :x 1 :y 'a :z nil)
|
||||
(make-foo-structure :x 1 :y 'a :z nil)
|
||||
(make-bar-structure :x 1 :y 'a :z nil)
|
||||
))
|
||||
|
||||
(defun meaningless-user-function-for-universe (x y z)
|
||||
(list (+ x 1) (+ y 2) (+ z 3)))
|
||||
|
||||
(defgeneric meaningless-user-generic-function-for-universe (x y z)
|
||||
#+(or (not :gcl) :ansi-cl) (:method ((x integer) (y integer) (z integer)) (+ x y z)))
|
||||
|
||||
(eval-when (:load-toplevel :execute)
|
||||
(compile 'meaningless-user-function-for-universe)
|
||||
;; Conditionalize to avoid a cmucl bug
|
||||
#-(or cmu gcl ecl) (compile 'meaningless-user-generic-function-for-universe)
|
||||
)
|
||||
|
||||
(defparameter *functions*
|
||||
(list #'cons #'car #'append #'values
|
||||
(macro-function 'cond)
|
||||
#'meaningless-user-function-for-universe
|
||||
#'meaningless-user-generic-function-for-universe
|
||||
#'(lambda (x) x)
|
||||
(compile nil '(lambda (x) x))))
|
||||
|
||||
(defparameter *methods*
|
||||
(list
|
||||
#+(or (not :gcl) :ansi-cl )
|
||||
(find-method #'meaningless-user-generic-function-for-universe nil
|
||||
(mapcar #'find-class '(integer integer integer)))
|
||||
;; Add more methods here
|
||||
))
|
||||
|
||||
|
||||
(defparameter *random-states*
|
||||
(list (make-random-state)))
|
||||
|
||||
(defparameter *universe*
|
||||
(remove-duplicates
|
||||
(append
|
||||
*symbols*
|
||||
*numbers*
|
||||
*characters*
|
||||
(mapcar #'copy-seq *strings*)
|
||||
*conses*
|
||||
*condition-objects*
|
||||
*package-objects*
|
||||
*arrays*
|
||||
*hash-tables*
|
||||
*pathnames*
|
||||
*logical-pathnames*
|
||||
*streams*
|
||||
*readtables*
|
||||
*structures*
|
||||
*functions*
|
||||
*random-states*
|
||||
*methods*
|
||||
nil)))
|
||||
|
||||
(defparameter *mini-universe*
|
||||
(remove-duplicates
|
||||
(append
|
||||
(mapcar #'first
|
||||
(list *symbols*
|
||||
*numbers*
|
||||
*characters*
|
||||
(list (copy-seq (first *strings*)))
|
||||
*conses*
|
||||
*condition-objects*
|
||||
*package-objects*
|
||||
*arrays*
|
||||
*hash-tables*
|
||||
*pathnames*
|
||||
*logical-pathnames*
|
||||
*streams*
|
||||
*readtables*
|
||||
*structures*
|
||||
*functions*
|
||||
*random-states*
|
||||
*methods*))
|
||||
'(;;; Others to fill in gaps
|
||||
1.2s0 1.3f0 1.5d0 1.8l0 3/5 10000000000000000000000))))
|
||||
|
||||
(defparameter *classes*
|
||||
(remove-duplicates (mapcar #'class-of *universe*)))
|
||||
|
||||
(defparameter *built-in-classes*
|
||||
(remove-if-not #'(lambda (x) (typep x 'built-in-class))
|
||||
*classes*))
|
||||
|
|
@ -44,43 +44,13 @@
|
|||
(ext:setenv "ECLDIR" (namestring (truename "SYS:")))
|
||||
|
||||
(defvar *test-name* (or (ext:getenv "TEST_NAME") "ecl"))
|
||||
|
||||
(defvar *output-directory*
|
||||
(merge-pathnames (concatenate 'string "output." *test-name* "/") *here*))
|
||||
|
||||
(defvar *quicklisp-sandbox* (merge-pathnames "quicklisp/" *here*))
|
||||
|
||||
(defvar *quicklisp-install-file* (merge-pathnames "quicklisp.lsp" *cache*))
|
||||
|
||||
(defvar *quicklisp-setup-file* (merge-pathnames "setup.lisp" *quicklisp-sandbox*))
|
||||
|
||||
(defvar *output-directory* *here*)
|
||||
(defvar *regressions-sources* (merge-pathnames "bugs/" *test-sources*))
|
||||
|
||||
(defvar *regressions-sandbox* (merge-pathnames "regressions/" *here*))
|
||||
|
||||
(defvar *ansi-tests-mirror* "http://common-lisp.net/project/ecl/tests/ansi-tests.tar.gz")
|
||||
|
||||
(defvar *ansi-tests-sandbox* (merge-pathnames "ansi-tests/" *here*))
|
||||
|
||||
(defvar *ansi-tests-tarball* "ansi-tests.tar.gz")
|
||||
|
||||
(defvar *mop-tests-mirror* "http://common-lisp.net/project/ecl/tests/mop-features.tar.gz")
|
||||
|
||||
(defvar *mop-tests-sandbox* (merge-pathnames "mop-features/" *here*))
|
||||
|
||||
(defvar *mop-tests-tarball* "mop-features.tar.gz")
|
||||
|
||||
(defvar *fricas-mirror* "http://common-lisp.net/project/ecl/tests/fricas.tar.gz")
|
||||
|
||||
(defvar *fricas-sandbox* (merge-pathnames "fricas/" *here*))
|
||||
|
||||
(defvar *fricas-tarball* "fricas.tar.gz")
|
||||
|
||||
(defvar *wild-inferiors* (make-pathname :name :wild
|
||||
:type :wild
|
||||
:version :wild
|
||||
:directory '(:relative :wild-inferiors)))
|
||||
|
||||
(defvar *cleanup-extensions* '("fasl" "fasb" "c" "h" "obj" "o" "a" "lib" "dll" "dylib" "data"))
|
||||
|
||||
(defun lisp-system-directory ()
|
||||
|
|
@ -97,9 +67,6 @@
|
|||
(lisp-system-directory)))))
|
||||
|
||||
(require :cmp)
|
||||
(require :ecl-curl)
|
||||
(require :deflate)
|
||||
(require :ql-minitar)
|
||||
|
||||
;;;
|
||||
;;; PREPARATION OF DIRECTORIES AND FILES
|
||||
|
|
@ -131,39 +98,6 @@
|
|||
(and (probe-file path)
|
||||
(recursive-deletion path))))
|
||||
|
||||
(defun safe-download (url filename)
|
||||
(ensure-directories-exist filename)
|
||||
(handler-case
|
||||
(ecl-curl:download-url-to-file url filename)
|
||||
(ecl-curl:download-error (c)
|
||||
(format t "~&;;;~%;;; Unable to download quicklisp. Aborting. ~%;;;")
|
||||
(ext:quit 1)))
|
||||
filename)
|
||||
|
||||
(defun download-quicklisp-install ()
|
||||
(safe-download "http://beta.quicklisp.org/quicklisp.lisp"
|
||||
*quicklisp-install-file*))
|
||||
|
||||
(defun download-and-setup-quicklisp ()
|
||||
(when (probe-file *quicklisp-sandbox*)
|
||||
(delete-everything *quicklisp-sandbox*))
|
||||
(handler-case
|
||||
(progn
|
||||
(load (download-quicklisp-install))
|
||||
(let ((function (read-from-string "quicklisp-quickstart:install")))
|
||||
(eval (list function :path *quicklisp-sandbox*))))
|
||||
(error (c)
|
||||
(format t "~&;;;~%;;; Unable to setup quicklisp. Aborting.~%;;;")
|
||||
(delete-everything *quicklisp-sandbox*))))
|
||||
|
||||
(defun ensure-quicklisp ()
|
||||
(unless (find-package "QL")
|
||||
(unless (probe-file *quicklisp-sandbox*)
|
||||
(setup-asdf)
|
||||
(download-and-setup-quicklisp))
|
||||
(load *quicklisp-setup-file*))
|
||||
t)
|
||||
|
||||
(defun copy-directory (orig dest)
|
||||
(setf orig (truename orig))
|
||||
(print dest)
|
||||
|
|
@ -176,49 +110,10 @@
|
|||
do (ensure-directories-exist f3)
|
||||
do (ext:copy-file f f3)))
|
||||
|
||||
(defun extract-tarball (filename)
|
||||
(format t "~&;;;~%;;; Extracting ~a~%;;;" filename)
|
||||
(if (string-equal (pathname-type filename) "gz")
|
||||
(let ((temp-filename (ext:mkstemp "fooXXXXXXX")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(deflate:gunzip filename temp-filename)
|
||||
(extract-tarball temp-filename))
|
||||
(delete-file temp-filename)))
|
||||
(ql-minitar:unpack-tarball filename)))
|
||||
|
||||
(defun extract-distribution (filename url)
|
||||
(let ((distribution (loop for base in (list *cache*
|
||||
*here*
|
||||
*test-sources*)
|
||||
for file = (merge-pathnames filename base)
|
||||
when (probe-file file)
|
||||
do (return file)
|
||||
finally (let ((tmp (merge-pathnames filename *cache*)))
|
||||
(return (safe-download url tmp))))))
|
||||
(extract-tarball distribution)))
|
||||
|
||||
(defun ensure-regressions ()
|
||||
(unless (probe-file *regressions-sandbox*)
|
||||
(copy-directory *regressions-sources* *regressions-sandbox*)))
|
||||
|
||||
(defun ensure-ansi-tests ()
|
||||
(unless (probe-file *ansi-tests-sandbox*)
|
||||
(extract-distribution *ansi-tests-tarball* *ansi-tests-mirror*))
|
||||
t)
|
||||
|
||||
(defun ensure-mop-tests ()
|
||||
(unless (probe-file *mop-tests-sandbox*)
|
||||
(extract-distribution *mop-tests-tarball* *mop-tests-mirror*))
|
||||
t)
|
||||
|
||||
(defun ensure-fricas ()
|
||||
(unless (probe-file *fricas-sandbox*)
|
||||
(extract-distribution *fricas-tarball* *fricas-url*)))
|
||||
|
||||
(defun ensure-maxima ()
|
||||
(unless (probe-file *fricas-sandbox*)
|
||||
(extract-distribution *fricas-tarball* *fricas-url*)))
|
||||
|
||||
(defun cleanup-directory (path)
|
||||
(loop for i in (directory (merge-pathnames *wild-inferiors*
|
||||
|
|
@ -230,38 +125,6 @@
|
|||
;;; RUNNING TESTS
|
||||
;;;
|
||||
|
||||
(defun run-ansi-tests (&optional (output (merge-pathnames "ansi.log"
|
||||
*output-directory*)))
|
||||
(ensure-ansi-tests)
|
||||
;; Cleanup stray files
|
||||
(cleanup-directory *ansi-tests-sandbox*)
|
||||
(delete-everything (merge-pathnames "scratch/" *ansi-tests-sandbox*))
|
||||
;; Run with given image
|
||||
(ensure-directories-exist output)
|
||||
(let* ((input (merge-pathnames "doit.lsp" *ansi-tests-sandbox*))
|
||||
(tmp (merge-pathnames "ecl-tmp-doit.lsp" *ansi-tests-sandbox*)))
|
||||
(with-open-file (s tmp :direction :output
|
||||
:if-exists :supersede
|
||||
:if-does-not-exist :create)
|
||||
(format s "(require :cmp)
|
||||
#+ecl(setf c::*suppress-compiler-messages* '(or c::compiler-note c::style-warning))
|
||||
(pprint (ext:getcwd))
|
||||
(load ~S)
|
||||
#+ecl(quit)"
|
||||
(namestring input)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(ext:chdir *ansi-tests-sandbox*)
|
||||
(ext:run-program *test-image*
|
||||
*test-image-args*
|
||||
:input tmp
|
||||
:output output
|
||||
:error :output
|
||||
:wait t))
|
||||
(when (probe-file tmp)
|
||||
(ignore-errors (delete-file tmp)))
|
||||
(ext:chdir *here*))))
|
||||
|
||||
(defun run-regressions-tests (&optional (output (merge-pathnames "regressions.log"
|
||||
*output-directory*)))
|
||||
(ensure-regressions)
|
||||
|
|
@ -278,140 +141,3 @@
|
|||
:output output
|
||||
:error :output))
|
||||
(ext:chdir *here*)))
|
||||
|
||||
(defun run-mop-tests (&optional (output (merge-pathnames "mop-features.log"
|
||||
*output-directory*)))
|
||||
(ensure-mop-tests)
|
||||
;; Cleanup stray files
|
||||
(cleanup-directory *mop-tests-sandbox*)
|
||||
;; Create the script we are going to run
|
||||
(let ((mop-script (merge-pathnames "./run-mop-tests.lisp" *mop-tests-sandbox*)))
|
||||
(with-open-file (s mop-script :direction :output
|
||||
:if-exists :supersede
|
||||
:if-does-not-exist :create)
|
||||
(pprint '(progn
|
||||
(require :asdf)
|
||||
(load "lw-compat-package")
|
||||
(load "lw-compat")
|
||||
(load "mop-features-packages.lisp")
|
||||
(load "mop-feature-tests.lisp")
|
||||
(handler-case
|
||||
(progn
|
||||
(funcall (read-from-string "mop-feature-tests::run-feature-tests"))
|
||||
(format t "~%~%~%MOP-FEATURE-TESTS: OK"))
|
||||
(error (error)
|
||||
(format t "~%~%~%MOP-FEATURE-TESTS: Failed"))))
|
||||
s))
|
||||
;; Run with given image
|
||||
(ensure-directories-exist output)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(ext:chdir *mop-tests-sandbox*)
|
||||
(ext:run-program *test-image*
|
||||
*test-image-args*
|
||||
:input mop-script
|
||||
:output output
|
||||
:error :output))
|
||||
(ext:chdir *here*))))
|
||||
|
||||
|
||||
(defvar *quicklisp-library-list*
|
||||
'(trivial-features
|
||||
alexandria
|
||||
babel
|
||||
cffi
|
||||
cl-ppcre
|
||||
cl-unicode
|
||||
iterate
|
||||
trivial-gray-streams
|
||||
trivial-garbage
|
||||
flexi-streams
|
||||
lift
|
||||
metabang-bind
|
||||
swank
|
||||
stefil
|
||||
sqlite
|
||||
chunga
|
||||
cl+ssl
|
||||
cl-base64
|
||||
cl-fad
|
||||
cl-python
|
||||
md5
|
||||
rfc2388
|
||||
trivial-backtrace
|
||||
trivial-gray-streams
|
||||
usocket
|
||||
hunchentoot))
|
||||
|
||||
(defconstant +quicklisp-build-template+ "
|
||||
(require 'asdf)
|
||||
(setf (symbol-value (read-from-string \"asdf::*user-cache*\"))
|
||||
(list ~s :implementation))
|
||||
(load ~s)
|
||||
(ql:use-only-quicklisp-systems)
|
||||
(handler-case
|
||||
(progn
|
||||
(ql:quickload ~s)
|
||||
(princ \"ECL-BUILD-OK\"))
|
||||
(serious-condition (c) (princ c)))
|
||||
#+ecl
|
||||
(ext:quit)
|
||||
#+sbcl
|
||||
(sb-ext:quit)
|
||||
")
|
||||
|
||||
(defconstant +quicklisp-test-template+ "
|
||||
(require 'asdf)
|
||||
(setf (symbol-value (read-from-string \"asdf::*user-cache*\"))
|
||||
(list ~s :implementation))
|
||||
(load ~s)
|
||||
(ql:use-only-quicklisp-systems)
|
||||
(handler-case
|
||||
(progn
|
||||
(ql:quickload ~s)
|
||||
(princ \"ECL-BUILD-OK\")
|
||||
(asdf:oos 'asdf:test-op ~:*~s)
|
||||
(princ \"ECL-TEST-OK\"))
|
||||
(serious-condition (c) (princ c)))
|
||||
#+ecl
|
||||
(ext:quit)
|
||||
#+sbcl
|
||||
(sb-ext:quit)
|
||||
")
|
||||
|
||||
(defun run-quicklisp-tests (&optional (output (merge-pathnames "quicklisp.log"
|
||||
*output-directory*)))
|
||||
(mapcar #'delete-everything (directory (merge-pathnames "*/" *cache*)))
|
||||
(let ((quicklisp-logs (merge-pathnames "quicklisp.logs/" *output-directory*)))
|
||||
(labels ((build-or-test-job (name suffix template)
|
||||
(let* ((name (string-downcase name))
|
||||
(log-name (concatenate 'string name suffix))
|
||||
(build-log (ensure-directories-exist
|
||||
(merge-pathnames log-name quicklisp-logs))))
|
||||
(multiple-value-bind (stream status process)
|
||||
(ext:run-program *test-image*
|
||||
*test-image-args*
|
||||
:input :stream
|
||||
:output build-log
|
||||
:error :output
|
||||
:wait nil)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(format stream template
|
||||
(namestring *cache*)
|
||||
(namestring *quicklisp-setup-file*)
|
||||
name)
|
||||
(format t template
|
||||
(namestring *cache*)
|
||||
(namestring *quicklisp-setup-file*)
|
||||
name)
|
||||
(force-output stream))
|
||||
(close stream)
|
||||
(ext:external-process-wait process t)
|
||||
))))
|
||||
(build-job (name)
|
||||
(build-or-test-job name "-build.log" +quicklisp-build-template+))
|
||||
(test-job (name)
|
||||
(build-or-test-job name "-test.log" +quicklisp-test-template+)))
|
||||
(mapc #'build-job *quicklisp-library-list*)
|
||||
(mapc #'test-job *quicklisp-library-list*))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue