From 2e6596ae25f9b00e765edbdfcfd07e6cc6df6821 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 10 Aug 2015 21:41:58 +0200 Subject: [PATCH] tests: remove unused/outdated/unrelated tests MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Daniel Kochmański --- src/tests/Makefile.in | 44 +- src/tests/bugs/ansi-aux.lsp | 1187 +++++++++++++++++++++++++++++++++++ src/tests/bugs/doit.lsp | 4 +- src/tests/bugs/universe.lsp | 534 ++++++++++++++++ src/tests/config.lsp.in | 276 +------- 5 files changed, 1734 insertions(+), 311 deletions(-) create mode 100644 src/tests/bugs/ansi-aux.lsp create mode 100644 src/tests/bugs/universe.lsp diff --git a/src/tests/Makefile.in b/src/tests/Makefile.in index 03bd1e070..1546bbcff 100755 --- a/src/tests/Makefile.in +++ b/src/tests/Makefile.in @@ -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 diff --git a/src/tests/bugs/ansi-aux.lsp b/src/tests/bugs/ansi-aux.lsp new file mode 100644 index 000000000..b59839bbb --- /dev/null +++ b/src/tests/bugs/ansi-aux.lsp @@ -0,0 +1,1187 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 17:10:18 1998 +;;;; Contains: Aux. functions for CL-TEST + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +;;; A function for coercing truth values to BOOLEAN + +(defun notnot (x) (not (not x))) + +(defmacro notnot-mv (form) + `(notnot-mv-fn (multiple-value-list ,form))) + +(defun notnot-mv-fn (results) + (if (null results) + (values) + (apply #'values + (not (not (first results))) + (rest results)))) + +(defmacro not-mv (form) + `(not-mv-fn (multiple-value-list ,form))) + +(defun not-mv-fn (results) + (if (null results) + (values) + (apply #'values + (not (first results)) + (rest results)))) + +(declaim (ftype (function (t) function) to-function)) + +(defun to-function (fn) + (etypecase fn + (function fn) + (symbol (symbol-function fn)) + ((cons (eql setf) (cons symbol null)) (fdefinition fn)))) + +;;; Macro to check that a function is returning a specified number of values +;;; (defaults to 1) +(defmacro check-values (form &optional (num 1)) + (let ((v (gensym)) + (n (gensym))) + `(let ((,v (multiple-value-list ,form)) + (,n ,num)) + (check-values-length ,v ,n ',form) + (car ,v)))) + +(defun check-values-length (results expected-number form) + (declare (type fixnum expected-number)) + (let ((n expected-number)) + (declare (type fixnum n)) + (dolist (e results) + (declare (ignore e)) + (decf n)) + (unless (= n 0) + (error "Expected ~A results from ~A, got ~A results instead.~%~ +Results: ~A~%" expected-number form n results)))) + +;;; Do multiple-value-bind, but check # of arguments +(defmacro multiple-value-bind* ((&rest vars) form &body body) + (let ((len (length vars)) + (v (gensym))) + `(let ((,v (multiple-value-list ,form))) + (check-values-length ,v ,len ',form) + (destructuring-bind ,vars ,v ,@body)))) + +;;; Comparison functions that are like various builtins, +;;; but are guaranteed to return T for true. + +(defun eqt (x y) + "Like EQ, but guaranteed to return T for true." + (apply #'values (mapcar #'notnot (multiple-value-list (eq x y))))) + +(defun eqlt (x y) + "Like EQL, but guaranteed to return T for true." + (apply #'values (mapcar #'notnot (multiple-value-list (eql x y))))) + +(defun equalt (x y) + "Like EQUAL, but guaranteed to return T for true." + (apply #'values (mapcar #'notnot (multiple-value-list (equal x y))))) + +(defun equalpt (x y) + "Like EQUALP, but guaranteed to return T for true." + (apply #'values (mapcar #'notnot (multiple-value-list (equalp x y))))) + +(defun equalpt-or-report (x y) + "Like EQUALPT, but return either T or a list of the arguments." + (or (equalpt x y) (list x y))) + +(defun string=t (x y) + (notnot-mv (string= x y))) + +(defun =t (x &rest args) + "Like =, but guaranteed to return T for true." + (apply #'values (mapcar #'notnot (multiple-value-list (apply #'= x args))))) + +(defun <=t (x &rest args) + "Like <=, but guaranteed to return T for true." + (apply #'values (mapcar #'notnot (multiple-value-list (apply #'<= x args))))) + +(defun make-int-list (n) + (loop for i from 0 below n collect i)) + +(defun make-int-array (n &optional (fn #'make-array)) + (when (symbolp fn) + (assert (fboundp fn)) + (setf fn (symbol-function (the symbol fn)))) + (let ((a (funcall (the function fn) n))) + (declare (type (array * *) a)) + (loop for i from 0 below n do (setf (aref a i) i)) + a)) + +;;; Return true if A1 and A2 are arrays with the same rank +;;; and dimensions whose elements are EQUAL + +(defun equal-array (a1 a2) + (and (typep a1 'array) + (typep a2 'array) + (= (array-rank a1) (array-rank a2)) + (if (= (array-rank a1) 0) + (equal (regression-test::my-aref a1) (regression-test::my-aref a2)) + (let ((ad (array-dimensions a1))) + (and (equal ad (array-dimensions a2)) + (locally + (declare (type (array * *) a1 a2)) + (if (= (array-rank a1) 1) + (let ((as (first ad))) + (loop + for i from 0 below as + always (equal (regression-test::my-aref a1 i) + (regression-test::my-aref a2 i)))) + (let ((as (array-total-size a1))) + (and (= as (array-total-size a2)) + (loop + for i from 0 below as + always + (equal + (regression-test::my-row-major-aref a1 i) + (regression-test::my-row-major-aref a2 i)) + )))))))))) + +;;; *universe* is defined elsewhere -- it is a list of various +;;; lisp objects used when stimulating things in various tests. +(declaim (special *universe*)) + +;;; The function EMPIRICAL-SUBTYPEP checks two types +;;; for subtypeness, first using SUBTYPEP*, then (if that +;;; fails) empirically against all the elements of *universe*, +;;; checking if all that are in the first are also in the second. +;;; Return T if this is the case, NIL otherwise. This will +;;; always return T if type1 is truly a subtype of type2, +;;; but may return T even if this is not the case. + +(defun empirical-subtypep (type1 type2) + (multiple-value-bind (sub good) + (subtypep* type1 type2) + (if good + sub + (loop for e in *universe* + always (or (not (typep e type1)) (typep e type2)))))) + +(defun check-type-predicate (P TYPE) + "Check that a predicate P is the same as #'(lambda (x) (typep x TYPE)) + by applying both to all elements of *UNIVERSE*. Print message + when a mismatch is found, and return number of mistakes." + + (when (symbolp p) + (assert (fboundp p)) + (setf p (symbol-function p))) + (assert (typep p 'function)) + + (loop + for x in *universe* + when + (block failed + (let ((p1 (handler-case + (normally (funcall (the function p) x)) + (error () (format t "(FUNCALL ~S ~S) failed~%" + P x) + (return-from failed t)))) + (p2 (handler-case + (normally (typep x TYPE)) + (error () (format t "(TYPEP ~S '~S) failed~%" + x TYPE) + (return-from failed t))))) + (when (or (and p1 (not p2)) + (and (not p1) p2)) + (format t "(FUNCALL ~S ~S) = ~S, (TYPEP ~S '~S) = ~S~%" + P x p1 x TYPE p2) + t))) + collect x)) + +;;; We have a common idiom where a guarded predicate should be +;;; true everywhere + +(defun check-predicate (predicate &optional guard (universe *universe*)) + "Return all elements of UNIVERSE for which the guard (if present) is false + and for which PREDICATE is false." + (remove-if #'(lambda (e) (or (and guard (funcall guard e)) + (funcall predicate e))) + universe)) + +(declaim (special *catch-error-type*)) + +(defun catch-continue-debugger-hook (condition dbh) + "Function that when used as *debugger-hook*, causes + continuable errors to be continued without user intervention." + (declare (ignore dbh)) + (let ((r (find-restart 'continue condition))) + (cond + ((and *catch-error-type* + (not (typep condition *catch-error-type*))) + (format t "Condition ~S is not a ~A~%" condition *catch-error-type*) + (cond (r (format t "Its continue restart is ~S~%" r)) + (t (format t "It has no continue restart~%"))) + (throw 'continue-failed nil)) + (r (invoke-restart r)) + (t (throw 'continue-failed nil))))) + +#| +(defun safe (fn &rest args) + "Apply fn to args, trapping errors. Convert type-errors to the + symbol type-error." + (declare (optimize (safety 3))) + (handler-case + (apply fn args) + (type-error () 'type-error) + (error (c) c))) +|# + +;;; Use the next macro in place of SAFE + +(defmacro catch-type-error (form) +"Evaluate form in safe mode, returning its value if there is no error. +If an error does occur, return type-error on TYPE-ERRORs, or the error +condition itself on other errors." +`(locally (declare (optimize (safety 3))) + (handler-case (normally ,form) + (type-error () 'type-error) + (error (c) c)))) + +(defmacro classify-error* (form) +"Evaluate form in safe mode, returning its value if there is no error. +If an error does occur, return a symbol classify the error, or allow +the condition to go uncaught if it cannot be classified." +`(locally (declare (optimize (safety 3))) + (handler-case (normally ,form) + (undefined-function () 'undefined-function) + (program-error () 'program-error) + (package-error () 'package-error) + (type-error () 'type-error) + (control-error () 'control-error) + (parse-error () 'parse-error) + (stream-error () 'stream-error) + (reader-error () 'reader-error) + (file-error () 'file-error) + (cell-error () 'cell-error) + (division-by-zero () 'division-by-zero) + (floating-point-overflow () 'floating-point-overflow) + (floating-point-underflow () 'floating-point-underflow) + (arithmetic-error () 'arithmetic-error) + (error () 'error) + ))) + +(defun classify-error** (form) + (handler-bind ((warning #'(lambda (c) (declare (ignore c)) + (muffle-warning)))) + (proclaim '(optimize (safety 3))) + (classify-error* + (if regression-test::*compile-tests* + (funcall (compile nil `(lambda () + (declare (optimize (safety 3))) + ,form))) + (eval form)) + ))) + +(defmacro classify-error (form) + `(classify-error** ',form)) + +;;; The above is badly designed, since it fails when some signals +;;; may be in more than one class/ + +(defmacro signals-error (form error-name &key (safety 3) (name nil name-p) (inline nil)) + `(handler-bind + ((warning #'(lambda (c) (declare (ignore c)) + (muffle-warning)))) + (proclaim '(optimize (safety 3))) + (handler-case + (apply #'values + nil + (multiple-value-list + ,(cond + (inline form) + (regression-test::*compile-tests* + `(funcall (compile nil '(lambda () + (declare (optimize (safety ,safety))) + ,form)))) + (t `(eval ',form))))) + (,error-name (c) + (cond + ,@(case error-name + (type-error + `(((typep (type-error-datum c) + (type-error-expected-type c)) + (values + nil + (list (list 'typep (list 'quote + (type-error-datum c)) + (list 'quote + (type-error-expected-type c))) + "==> true"))))) + ((undefined-function unbound-variable) + (and name-p + `(((not (eq (cell-error-name c) ',name)) + (values + nil + (list 'cell-error-name "==>" + (cell-error-name c))))))) + ((stream-error end-of-file reader-error) + `(((not (streamp (stream-error-stream c))) + (values + nil + (list 'stream-error-stream "==>" + (stream-error-stream c)))))) + (file-error + `(((not (pathnamep (pathname (file-error-pathname c)))) + (values + nil + (list 'file-error-pathname "==>" + (file-error-pathname c)))))) + (t nil)) + (t (printable-p c))))))) + +(defmacro signals-error-always (form error-name) + `(values + (signals-error ,form ,error-name) + (signals-error ,form ,error-name :safety 0))) + +(defmacro signals-type-error (var datum-form form &key (safety 3) (inline nil)) + (let ((lambda-form + `(lambda (,var) + (declare (optimize (safety ,safety))) + ,form))) + `(let ((,var ,datum-form)) + (declare (optimize safety)) + (handler-bind + ((warning #'(lambda (c) (declare (ignore c)) + (muffle-warning)))) + ; (proclaim '(optimize (safety 3))) + (handler-case + (apply #'values + nil + (multiple-value-list + (funcall + ,(cond + (inline `(function ,lambda-form)) + (regression-test::*compile-tests* + `(compile nil ',lambda-form)) + (t `(eval ',lambda-form))) + ,var))) + (type-error + (c) + (let ((datum (type-error-datum c)) + (expected-type (type-error-expected-type c))) + (cond + ((not (eql ,var datum)) + (list :datum-mismatch ,var datum)) + ((typep datum expected-type) + (list :is-typep datum expected-type)) + (t (printable-p c)))))))))) + +(declaim (special *mini-universe*)) + +(defun check-type-error* (pred-fn guard-fn &optional (universe *mini-universe*)) + "Check that for all elements in some set, either guard-fn is true or + pred-fn signals a type error." + (let (val) + (loop for e in universe + unless (or (funcall guard-fn e) + (equal + (setf val (multiple-value-list + (signals-type-error x e (funcall pred-fn x) :inline t))) + '(t))) + collect (list e val)))) + +(defmacro check-type-error (&body args) + `(locally (declare (optimize safety)) (check-type-error* ,@args))) + +(defun printable-p (obj) + "Returns T iff obj can be printed to a string." + (with-standard-io-syntax + (let ((*print-readably* nil) + (*print-escape* nil)) + (declare (optimize safety)) + (handler-case (and (stringp (write-to-string obj)) t) + (condition (c) (declare (ignore c)) nil))))) + +;;; +;;; The function SUBTYPEP should return two generalized booleans. +;;; This auxiliary function returns booleans instead +;;; (which makes it easier to write tests). +;;; +(defun subtypep* (type1 type2) + (apply #'values + (mapcar #'notnot + (multiple-value-list (subtypep type1 type2))))) + +(defun subtypep*-or-fail (type1 type2) + (let ((results (multiple-value-list (subtypep type1 type2)))) + (and (= (length results) 2) + (or (not (second results)) + (notnot (first results)))))) + +(defun subtypep*-not-or-fail (type1 type2) + (let ((results (multiple-value-list (subtypep type1 type2)))) + (and (= (length results) 2) + (or (not (second results)) + (not (first results)))))) + +;; (declaim (ftype (function (&rest function) (values function &optional)) +;; compose)) + +(defun compose (&rest fns) + (let ((rfns (reverse fns))) + #'(lambda (x) (loop for f + in rfns do (setf x (funcall (the function f) x))) x))) + +(defun evendigitp (c) + (notnot (find c "02468"))) + +(defun odddigitp (c) + (notnot (find c "13579"))) + +(defun nextdigit (c) + (cadr (member c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)))) + +(defun is-eq-p (x) #'(lambda (y) (eqt x y))) +(defun is-not-eq-p (x) #'(lambda (y) (not (eqt x y)))) + +(defun is-eql-p (x) #'(lambda (y) (eqlt x y))) +(defun is-not-eql-p (x) #'(lambda (y) (not (eqlt x y)))) + +(defun onep (x) (eql x 1)) + +(defun char-invertcase (c) + (if (upper-case-p c) (char-downcase c) + (char-upcase c))) + +(defun string-invertcase (s) + (map 'string #'char-invertcase s)) + +(defun symbol< (x &rest args) + (apply #'string< (symbol-name x) (mapcar #'symbol-name args))) + + +(defun make-list-expr (args) + "Build an expression for computing (LIST . args), but that evades + CALL-ARGUMENTS-LIMIT." + (if (cddddr args) + (list 'list* + (first args) (second args) (third args) (fourth args) + (make-list-expr (cddddr args))) + (cons 'list args))) + +(defparameter +standard-chars+ + (coerce + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789~!@#$%^&*()_+|\\=-`{}[]:\";'<>?,./ + " 'simple-base-string)) + +(defparameter + +base-chars+ #.(coerce + (concatenate 'string + "abcdefghijklmnopqrstuvwxyz" + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "0123456789" + "<,>.?/\"':;[{]}~`!@#$%^&*()_-+= \\|") + 'simple-base-string)) + + +(declaim (type simple-base-string +base-chars+)) + +(defparameter +num-base-chars+ (length +base-chars+)) + +(defparameter +alpha-chars+ (subseq +standard-chars+ 0 52)) +(defparameter +lower-case-chars+ (subseq +alpha-chars+ 0 26)) +(defparameter +upper-case-chars+ (subseq +alpha-chars+ 26 52)) +(defparameter +alphanumeric-chars+ (subseq +standard-chars+ 0 62)) +(defparameter +digit-chars+ "0123456789") +(defparameter +extended-digit-chars+ (coerce + "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" + 'simple-base-string)) + +(declaim (type simple-base-string +alpha-chars+ +lower-case-chars+ + +upper-case-chars+ +alphanumeric-chars+ +extended-digit-chars+ + +standard-chars+)) + +(defparameter +code-chars+ + (coerce (loop for i from 0 below 256 + for c = (code-char i) + when c collect c) + 'simple-string)) + +(declaim (type simple-string +code-chars+)) + +(defparameter +rev-code-chars+ (reverse +code-chars+)) + +;;; Used in checking for continuable errors + +(defun has-non-abort-restart (c) + (throw 'handled + (if (position 'abort (the list (compute-restarts c)) + :key #'restart-name :test-not #'eq) + 'success + 'fail))) + +(defmacro handle-non-abort-restart (&body body) + `(catch 'handled + (handler-bind ((error #'has-non-abort-restart)) + ,@body))) + +;;; used in elt.lsp +(defun elt-v-6-body () + (let ((x (make-int-list 1000))) + (let ((a (make-array '(1000) :initial-contents x))) + (loop + for i from 0 to 999 do + (unless (eql i (elt a i)) (return nil)) + finally (return t))))) + +(defun make-adj-array (n &key initial-contents) + (if initial-contents + (make-array n :adjustable t :initial-contents initial-contents) + (make-array n :adjustable t))) + +;;; used in elt.lsp +(defun elt-adj-array-6-body () + (let ((x (make-int-list 1000))) + (let ((a (make-adj-array '(1000) :initial-contents x))) + (loop + for i from 0 to 999 do + (unless (eql i (elt a i)) (return nil)) + finally (return t))))) + +(defparameter *displaced* (make-int-array 100000)) + +(defun make-displaced-array (n displacement) + (make-array n :displaced-to *displaced* + + :displaced-index-offset displacement)) + +;;; used in fill.lsp +(defun array-unsigned-byte-fill-test-fn (byte-size &rest fill-args) + (let* ((a (make-array '(5) :element-type (list 'unsigned-byte byte-size) + :initial-contents '(1 2 3 4 5))) + (b (apply #'fill a fill-args))) + (values (eqt a b) + (map 'list #'identity a)))) + +;;; used in fill-strings.lsp +(defun array-string-fill-test-fn (a &rest fill-args) + (setq a (copy-seq a)) + (let ((b (apply #'fill a fill-args))) + (values (eqt a b) b))) + +;;; From types-and-class.lsp + +(defparameter +float-types+ + '(long-float double-float short-float single-float)) + +(defparameter *subtype-table* +(let ((table + '( + (null symbol) + (symbol t) + (boolean symbol) + (standard-object t) + (function t) + (compiled-function function) + (generic-function function) + (standard-generic-function generic-function) + (class standard-object) + (built-in-class class) + (structure-class class) + (standard-class class) + (method standard-object) + (standard-method method) + (structure-object t) + (method-combination t) + (condition t) + (serious-condition condition) + (error serious-condition) + (type-error error) + (simple-type-error type-error) + (simple-condition condition) + (simple-type-error simple-condition) + (parse-error error) + (hash-table t) + (cell-error error) + (unbound-slot cell-error) + (warning condition) + (style-warning warning) + (storage-condition serious-condition) + (simple-warning warning) + (simple-warning simple-condition) + (keyword symbol) + (unbound-variable cell-error) + (control-error error) + (program-error error) + (undefined-function cell-error) + (package t) + (package-error error) + (random-state t) + (number t) + (real number) + (complex number) + (float real) + (short-float float) + (single-float float) + (double-float float) + (long-float float) + (rational real) + (integer rational) + (ratio rational) + (signed-byte integer) + (integer signed-byte) + (unsigned-byte signed-byte) + (bit unsigned-byte) + (fixnum integer) + (bignum integer) + (bit fixnum) + (arithmetic-error error) + (division-by-zero arithmetic-error) + (floating-point-invalid-operation arithmetic-error) + (floating-point-inexact arithmetic-error) + (floating-point-overflow arithmetic-error) + (floating-point-underflow arithmetic-error) + (character t) + (base-char character) + (standard-char base-char) + (extended-char character) + (sequence t) + (list sequence) + (null list) + (null boolean) + (cons list) + (array t) + (simple-array array) + (vector sequence) + (vector array) + (string vector) + (bit-vector vector) + (simple-vector vector) + (simple-vector simple-array) + (simple-bit-vector bit-vector) + (simple-bit-vector simple-array) + (base-string string) + (simple-string string) + (simple-string simple-array) + (simple-base-string base-string) + (simple-base-string simple-string) + (pathname t) + (logical-pathname pathname) + (file-error error) + (stream t) + (broadcast-stream stream) + (concatenated-stream stream) + (echo-stream stream) + (file-stream stream) + (string-stream stream) + (synonym-stream stream) + (two-way-stream stream) + (stream-error error) + (end-of-file stream-error) + (print-not-readable error) + (readtable t) + (reader-error parse-error) + (reader-error stream-error) + ))) + (when (subtypep* 'character 'base-char) + (setq table + (append + '((character base-char) + ;; (string base-string) + ;; (simple-string simple-base-string) + ) + table))) + + table)) + +(defparameter *disjoint-types-list* + '(cons symbol array + number character hash-table function readtable package + pathname stream random-state condition restart)) + +(defparameter *disjoint-types-list2* + `((cons (cons t t) (cons t (cons t t)) (eql (nil))) + (symbol keyword boolean null (eql a) (eql nil) (eql t) (eql *)) + (array vector simple-array simple-vector string simple-string + base-string simple-base-string (eql #())) + (character base-char standard-char (eql #\a) + ,@(if (subtypep 'character 'base-char) nil + (list 'extended-char))) + (function compiled-function generic-function standard-generic-function + (eql ,#'car)) + (package (eql ,(find-package "COMMON-LISP"))) + (pathname logical-pathname (eql #p"")) + (stream broadcast-stream concatenated-stream echo-stream + file-stream string-stream synonym-stream two-way-stream) + (number real complex float integer rational ratio fixnum + bit (integer 0 100) (float 0.0 100.0) (integer 0 *) + (rational 0 *) (mod 10) + (eql 0) + ,@(and (not (subtypep 'bignum nil)) + (list 'bignum))) + (random-state) + ,*condition-types* + (restart) + (readtable))) + +(defparameter *types-list3* + (reduce #'append *disjoint-types-list2* :from-end t)) + +(defun trim-list (list n) + (let ((len (length list))) + (if (<= len n) list + (append (subseq list 0 n) + (format nil "And ~A more omitted." (- len n)))))) + +(defun is-t-or-nil (e) + (or (eqt e t) (eqt e nil))) + +(defun is-builtin-class (type) + (when (symbolp type) (setq type (find-class type nil))) + (typep type 'built-in-class)) + +(defun even-size-p (a) + (some #'evenp (array-dimensions a))) + + +(defun safe-elt (x n) + (classify-error* (elt x n))) + +(defmacro defstruct* (&body args) + `(eval-when (:load-toplevel :compile-toplevel :execute) + (handler-case (eval '(defstruct ,@args)) + (serious-condition () nil)))) + +(defun safely-delete-package (package-designator) + (let ((package (find-package package-designator))) + (when package + (let ((used-by (package-used-by-list package))) + (dolist (using-package used-by) + (unuse-package package using-package))) + (delete-package package)))) + +#-(or allegro openmcl lispworks) +(defun delete-all-versions (pathspec) + "Replace the versions field of the pathname specified by pathspec with + :wild, and delete all the files this refers to." + (let* ((wild-pathname (make-pathname :version :wild :defaults (pathname pathspec))) + (truenames (directory wild-pathname))) + (mapc #'delete-file truenames))) + +;;; This is a hack to get around an ACL bug; OpenMCL also apparently +;;; needs it +#+(or allegro openmcl lispworks) +(defun delete-all-versions (pathspec) + (when (probe-file pathspec) (delete-file pathspec))) + +(defconstant +fail-count-limit+ 20) + +(defun frob-simple-condition (c expected-fmt &rest expected-args) + "Try out the format control and format arguments of a simple-condition C, + but make no assumptions about what they print as, only that they + do print." + (declare (ignore expected-fmt expected-args)) + (and (typep c 'simple-condition) + (let ((fc (simple-condition-format-control c)) + (args (simple-condition-format-arguments c))) + (and + (stringp (apply #'format nil fc args)) + t)))) + +(defun frob-simple-error (c expected-fmt &rest expected-args) + (and (typep c 'simple-error) + (apply #'frob-simple-condition c expected-fmt expected-args))) + +(defun frob-simple-warning (c expected-fmt &rest expected-args) + (and (typep c 'simple-warning) + (apply #'frob-simple-condition c expected-fmt expected-args))) + +(defparameter *array-element-types* + '(t (integer 0 0) + bit (unsigned-byte 8) (unsigned-byte 16) + (unsigned-byte 32) float short-float + single-float double-float long-float + nil character base-char symbol boolean null)) + +(defun collect-properties (plist prop) + "Collect all the properties in plist for a property prop." + (loop for e on plist by #'cddr + when (eql (car e) prop) + collect (cadr e))) + +(defmacro def-macro-test (test-name macro-form) + (let ((macro-name (car macro-form))) + (assert (symbolp macro-name)) + `(deftest ,test-name + (values + (signals-error (funcall (macro-function ',macro-name)) + program-error) + (signals-error (funcall (macro-function ',macro-name) + ',macro-form) + program-error) + (signals-error (funcall (macro-function ',macro-name) + ',macro-form nil nil) + program-error)) + t t t))) + +(defun typep* (element type) + (not (not (typep element type)))) + +(defun applyf (fn &rest args) + (etypecase fn + (symbol + #'(lambda (&rest more-args) (apply (the symbol fn) (append args more-args)))) + (function + #'(lambda (&rest more-args) (apply (the function fn) (append args more-args)))))) + +(defun slot-boundp* (object slot) + (notnot (slot-boundp object slot))) + +(defun slot-exists-p* (object slot) + (notnot (slot-exists-p object slot))) + +(defun map-slot-boundp* (c slots) + (mapcar (applyf #'slot-boundp c) slots)) + +(defun map-slot-exists-p* (c slots) + (mapcar (applyf #'slot-exists-p* c) slots)) + +(defun map-slot-value (c slots) + (mapcar (applyf #'slot-value c) slots)) + +(defun map-typep* (object types) + (mapcar (applyf #'typep* object) types)) + +(defun slot-value-or-nil (object slot-name) + (and (slot-exists-p object slot-name) + (slot-boundp object slot-name) + (slot-value object slot-name))) + +(defun is-noncontiguous-sublist-of (list1 list2) + (loop + for x in list1 + do (loop + when (null list2) do (return-from is-noncontiguous-sublist-of nil) + when (eql x (pop list2)) do (return)) + finally (return t))) + +;;; This defines a new metaclass to allow us to get around +;;; the restriction in section 11.1.2.1.2, bullet 19 in some +;;; object system tests + +;;; (when (typep (find-class 'standard-class) 'standard-class) +;;; (defclass substandard-class (standard-class) ()) +;;; (defparameter *can-define-metaclasses* t)) + +;;; Macro for testing that something is undefined but 'harmless' + +(defmacro defharmless (name form) + `(deftest ,name + (block done + (let ((*debugger-hook* #'(lambda (&rest args) + (declare (ignore args)) + (return-from done :good)))) + (handler-case + (unwind-protect (eval ',form) (return-from done :good)) + (condition () :good)))) + :good)) + +(defun rational-safely (x) + "Rational a floating point number, making sure the rational + number isn't 'too big'. This is important in implementations such + as clisp where the floating bounds can be very large." + (assert (floatp x)) + (multiple-value-bind (significand exponent sign) + (integer-decode-float x) + (let ((limit 1000) + (radix (float-radix x))) + (cond + ((< exponent (- limit)) + (* significand (expt radix (- limit)) sign)) + ((> exponent limit) + (* significand (expt radix limit) sign)) + (t (rational x)))))) + +(declaim (special *similarity-list*)) + +(defun is-similar (x y) + (let ((*similarity-list* nil)) + (is-similar* x y))) + +(defgeneric is-similar* (x y)) + +(defmethod is-similar* ((x number) (y number)) + (and (eq (class-of x) (class-of y)) + (= x y) + t)) + +(defmethod is-similar* ((x character) (y character)) + (and (char= x y) t)) + +(defmethod is-similar* ((x symbol) (y symbol)) + (if (null (symbol-package x)) + (and (null (symbol-package y)) + (is-similar* (symbol-name x) (symbol-name y))) + ;; I think the requirements for interned symbols in + ;; 3.2.4.2.2 boils down to EQ after the symbols are in the lisp + (eq x y)) + t) + +(defmethod is-similar* ((x random-state) (y random-state)) + (let ((copy-of-x (make-random-state x)) + (copy-of-y (make-random-state y)) + (bound (1- (ash 1 24)))) + (and + ;; Try 50 values, and assume the random state are the same + ;; if all the values are the same. Assuming the RNG is not + ;; very pathological, this should be acceptable. + (loop repeat 50 + always (eql (random bound copy-of-x) + (random bound copy-of-y))) + t))) + +(defmethod is-similar* ((x cons) (y cons)) + (or (and (eq x y) t) + (and (loop for (x2 . y2) in *similarity-list* + thereis (and (eq x x2) (eq y y2))) + t) + (let ((*similarity-list* + (cons (cons x y) *similarity-list*))) + (and (is-similar* (car x) (car y)) + ;; If this causes stack problems, + ;; convert to a loop + (is-similar* (cdr x) (cdr y)))))) + +(defmethod is-similar* ((x vector) (y vector)) + (or (and (eq x y) t) + (and + (or (not (typep x 'simple-array)) + (typep x 'simple-array)) + (= (length x) (length y)) + (is-similar* (array-element-type x) + (array-element-type y)) + (loop for i below (length x) + always (is-similar* (aref x i) (aref y i))) + t))) + +(defmethod is-similar* ((x array) (y array)) + (or (and (eq x y) t) + (and + (or (not (typep x 'simple-array)) + (typep x 'simple-array)) + (= (array-rank x) (array-rank y)) + (equal (array-dimensions x) (array-dimensions y)) + (is-similar* (array-element-type x) + (array-element-type y)) + (let ((*similarity-list* + (cons (cons x y) *similarity-list*))) + (loop for i below (array-total-size x) + always (is-similar* (row-major-aref x i) + (row-major-aref y i)))) + t))) + +(defmethod is-similar* ((x hash-table) (y hash-table)) + ;; FIXME Add similarity check for hash tables + (error "Sorry, we're not computing this yet.")) + +(defmethod is-similar* ((x pathname) (y pathname)) + (and + (is-similar* (pathname-host x) (pathname-host y)) + (is-similar* (pathname-device x) (pathname-device y)) + (is-similar* (pathname-directory x) (pathname-directory y)) + (is-similar* (pathname-name x) (pathname-name y)) + (is-similar* (pathname-type x) (pathname-type y)) + (is-similar* (pathname-version x) (pathname-version y)) + t)) + +(defmethod is-similar* ((x t) (y t)) + (and (eql x y) t)) + +(defparameter *initial-print-pprint-dispatch* (if (boundp '*print-pprint-dispatch*) + *print-pprint-dispatch* + nil)) + +(defmacro my-with-standard-io-syntax (&body body) + `(let ((*package* (find-package "COMMON-LISP-USER")) + (*print-array* t) + (*print-base* 10) + (*print-case* :upcase) + (*print-circle* nil) + (*print-escape* t) + (*print-gensym* t) + (*print-length* nil) + (*print-level* nil) + (*print-lines* nil) + (*print-miser-width* nil) + (*print-pprint-dispatch* *initial-print-pprint-dispatch*) + (*print-pretty* nil) + (*print-radix* nil) + (*print-readably* t) + (*print-right-margin* nil) + (*read-base* 10) + (*read-default-float-format* 'single-float) + (*read-eval* t) + (*read-suppress* nil) + (*readtable* (copy-readtable nil))) + ,@body)) + +;;; Function to produce a non-simple string + +(defun make-special-string (string &key fill adjust displace base) + (let* ((len (length string)) + (len2 (if fill (+ len 4) len)) + (etype (if base 'base-char 'character))) + (if displace + (let ((s0 (make-array (+ len2 5) + :initial-contents + (concatenate 'string + (make-string 2 :initial-element #\X) + string + (make-string (if fill 7 3) + :initial-element #\Y)) + :element-type etype))) + (make-array len2 :element-type etype + :adjustable adjust + :fill-pointer (if fill len nil) + :displaced-to s0 + :displaced-index-offset 2)) + (make-array len2 :element-type etype + :initial-contents + (if fill (concatenate 'string string "ZZZZ") string) + :fill-pointer (if fill len nil) + :adjustable adjust)))) + +(defmacro do-special-strings ((var string-form &optional ret-form) &body forms) + (let ((string (gensym)) + (fill (gensym "FILL")) + (adjust (gensym "ADJUST")) + (base (gensym "BASE")) + (displace (gensym "DISPLACE"))) + `(let ((,string ,string-form)) + (dolist (,fill '(nil t) ,ret-form) + (dolist (,adjust '(nil t)) + (dolist (,base '(nil t)) + (dolist (,displace '(nil t)) + (let ((,var (make-special-string + ,string + :fill ,fill :adjust ,adjust + :base ,base :displace ,displace))) + ,@forms)))))))) + +(defun make-special-integer-vector (contents &key fill adjust displace (etype 'integer)) + (let* ((len (length contents)) + (min (reduce #'min contents)) + (max (reduce #'max contents)) + (len2 (if fill (+ len 4) len))) + (unless (and (typep min etype) + (typep max etype)) + (setq etype `(integer ,min ,max))) + (if displace + (let ((s0 (make-array (+ len2 5) + :initial-contents + (concatenate 'list + (make-list 2 :initial-element + (if (typep 0 etype) 0 min)) + contents + (make-list (if fill 7 3) + :initial-element + (if (typep 1 etype) 1 max))) + :element-type etype))) + (make-array len2 :element-type etype + :adjustable adjust + :fill-pointer (if fill len nil) + :displaced-to s0 + :displaced-index-offset 2)) + (make-array len2 :element-type etype + :initial-contents + (if fill (concatenate 'list + contents + (make-list 4 :initial-element + (if (typep 2 etype) 2 (floor (+ min max) 2)))) + contents) + :fill-pointer (if fill len nil) + :adjustable adjust)))) + +(defmacro do-special-integer-vectors ((var vec-form &optional ret-form) &body forms) + (let ((vector (gensym)) + (fill (gensym "FILL")) + (adjust (gensym "ADJUST")) + (etype (gensym "ETYPE")) + (displace (gensym "DISPLACE"))) + `(let ((,vector ,vec-form)) + (dolist (,fill '(nil t) ,ret-form) + (dolist (,adjust '(nil t)) + (dolist (,etype ',(append (loop for i from 1 to 32 collect `(unsigned-byte ,i)) + (loop for i from 2 to 32 collect `(signed-byte ,i)) + '(integer))) + (dolist (,displace '(nil t)) + (let ((,var (make-special-integer-vector + ,vector + :fill ,fill :adjust ,adjust + :etype ,etype :displace ,displace))) + ,@forms)))))))) + +;;; Return T if arg X is a string designator in this implementation + +(defun string-designator-p (x) + (handler-case + (progn (string x) t) + (error nil))) + +;;; Approximate comparison of numbers +#| +(defun approx= (x y) + (let ((eps 1.0d-4)) + (<= (abs (- x y)) + (* eps (max (abs x) (abs y)))))) +|# + +;;; Approximate equality function +(defun approx= (x y &optional (eps (epsilon x))) + (<= (abs (/ (- x y) (max (abs x) 1))) eps)) + +(defun epsilon (number) + (etypecase number + (complex (* 2 (epsilon (realpart number)))) ;; crude + (short-float short-float-epsilon) + (single-float single-float-epsilon) + (double-float double-float-epsilon) + (long-float long-float-epsilon) + (rational 0))) + +(defun negative-epsilon (number) + (etypecase number + (complex (* 2 (negative-epsilon (realpart number)))) ;; crude + (short-float short-float-negative-epsilon) + (single-float single-float-negative-epsilon) + (double-float double-float-negative-epsilon) + (long-float long-float-negative-epsilon) + (rational 0))) + +(defun sequencep (x) (typep x 'sequence)) + +(defun typef (type) #'(lambda (x) (typep x type))) + +(defun package-designator-p (x) + "TRUE if x could be a package designator. The package need not + actually exist." + (or (packagep x) + (handler-case (and (locally (declare (optimize safety)) + (string x)) + t) + (type-error () nil)))) + +(defmacro def-fold-test (name form) + "Create a test that FORM, which should produce a fresh value, + does not improperly introduce sharing during constant folding." + `(deftest ,name + (flet ((%f () (declare (optimize (speed 3) (safety 0) (space 0) + (compilation-speed 0) (debug 0))) + ,form)) + (eq (%f) (%f))) + nil)) + +;;; Macro used in tests of environments in system macros +;;; This was inspired by a bug in ACL 8.0 beta where CONSTANTP +;;; was being called in some system macros without the proper +;;; environment argument + +(defmacro expand-in-current-env (macro-form &environment env) + (macroexpand macro-form env)) diff --git a/src/tests/bugs/doit.lsp b/src/tests/bugs/doit.lsp index 641937092..1e30a8efe 100644 --- a/src/tests/bugs/doit.lsp +++ b/src/tests/bugs/doit.lsp @@ -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") diff --git a/src/tests/bugs/universe.lsp b/src/tests/bugs/universe.lsp new file mode 100644 index 000000000..38a4d10ff --- /dev/null +++ b/src/tests/bugs/universe.lsp @@ -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*)) diff --git a/src/tests/config.lsp.in b/src/tests/config.lsp.in index 9473ad862..f7e14e029 100755 --- a/src/tests/config.lsp.in +++ b/src/tests/config.lsp.in @@ -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*))))