Commit b1170901 authored by pfdietz's avatar pfdietz

Changes to make the test suite be case agnostic, so it can work with the...

Changes to make the test suite be case agnostic, so it can work with the 'modern mode' of Allegro CL.  This mode is not standard, but I'd like the suite to be able to test all the other parts of ACL's mlisp for compliance.
parent 812e8af0
......@@ -1349,7 +1349,7 @@ the condition to go uncaught if it cannot be classified."
(multiple-value-bind (sym2 access2)
(find-symbol (symbol-name sym) pkg)
(unless (or (eqt sym sym2)
(member sym2 (PACKAGE-SHADOWING-SYMBOLS pkg)))
(member sym2 (package-shadowing-symbols pkg)))
(unless (> fail-count +fail-count-limit+)
(format t "Not same symbol: ~S ~S~%" sym sym2))
(when (= fail-count +fail-count-limit+)
......
This diff is collapsed.
......@@ -15,7 +15,7 @@
(defun test-if-not-in-cl-package (str)
(multiple-value-bind (sym status)
(find-symbol (string-upcase str) 'common-lisp)
(find-symbol #+lower-case str #-lower-case (string-upcase str) 'common-lisp)
(or
;; Symbol not present in the common lisp package
(not status)
......
......@@ -1343,7 +1343,7 @@
(let ((*gensym-counter* 1))
(declare (special *gensym-counter*))
(symbol-name (gensym)))
"G1")
#.(string '#:g1))
;;; Gensym uses the string argument instead of the default
(deftest gensym.4
......@@ -1387,7 +1387,7 @@
(let ((*gensym-counter* 1234567890123456789012345678901234567890))
(declare (special *gensym-counter*))
(symbol-name (gensym)))
"G1234567890123456789012345678901234567890")
#.(string '#:g1234567890123456789012345678901234567890))
;;; gensym increments Really Big values of *gensym-counter*
(deftest gensym.11
......@@ -1402,7 +1402,7 @@
(let ((*gensym-counter* 10))
(declare (special *gensym-counter*))
(symbol-name (gensym 123)))
"G123")
#.(string '#:g123))
;;; When given an integer argument, gensym does not increment the
;;; *gensym-counter*
......
......@@ -7,7 +7,7 @@
(:use :cl :regression-test)
;; #+gcl (:use defpackage)
(:nicknames)
(:import-from "COMMON-LISP-USER" "COMPILE-AND-LOAD" "==>")
(:import-from "COMMON-LISP-USER" #:compile-and-load "==>")
(:export))
#+cmu (import 'cl::quit :cl-test)
......
(in-package "COMMON-LISP-USER")
(in-package :common-lisp-user)
#+allegro
(progn
(setq *ignore-package-name-case* t)
(when (eq excl:*current-case-mode* :case-sensitive-lower)
(push :lower-case *features*)))
(eval-when (load eval compile)
(intern "==>" "CL-USER")
......
......@@ -54,7 +54,7 @@
(check-sublis '(f6 10 (f4 (f3 (f1 a b) (f1 a p)) (f2 a b)))
'(((f1 a b) . (f2 a b)) ((f2 a b) . (f1 a b)))
:test #'equal)
(F6 10 (F4 (F3 (F2 A B) (F1 A P)) (F1 A B))))
(f6 10 (f4 (f3 (f2 a b) (f1 a p)) (f1 a b))))
(deftest sublis.3
(check-sublis '(10 ((10 20 (a b c) 30)) (((10 20 30 40))))
......@@ -209,7 +209,7 @@
(check-nsublis '(f6 10 (f4 (f3 (f1 a b) (f1 a p)) (f2 a b)))
'(((f1 a b) . (f2 a b)) ((f2 a b) . (f1 a b)))
:test #'equal)
(F6 10 (F4 (F3 (F2 A B) (F1 A P)) (F1 A B))))
(f6 10 (f4 (f3 (f2 a b) (f1 a p)) (f1 a b))))
(deftest nsublis.3
(check-nsublis '(10 ((10 20 (a b c) 30)) (((10 20 30 40))))
......@@ -381,11 +381,11 @@
(deftest subst.4
(check-subst 'grape 'dick
'(melville wrote (moby dick)))
(MELVILLE WROTE (MOBY GRAPE)))
(melville wrote (moby grape)))
(deftest subst.5
(check-subst 'cha-cha-cha 'nil '(melville wrote (moby dick)))
(MELVILLE WROTE (MOBY DICK . CHA-CHA-CHA) . CHA-CHA-CHA))
(melville wrote (moby dick . cha-cha-cha) . cha-cha-cha))
(deftest subst.6
(check-subst
......@@ -480,15 +480,15 @@
(deftest subst-if.1
(check-subst-if 'a #'consp '((100 1) (2 3) (4 3 2 1) (a b c)))
A)
a)
(deftest subst-if-not.1
(check-subst-if-not '(x) 'consp '(1 (1 2) (1 2 3) (1 2 3 4)))
((X)
((X) (X) X)
((X) (X) (X) X)
((X) (X) (X) (X) X)
X))
((x)
((x) (x) x)
((x) (x) (x) x)
((x) (x) (x) (x) x)
x))
(deftest subst-if.2
(check-subst-if 17 (complement #'listp) '(a (a b) (a c d) (a nil e f g)))
......@@ -498,27 +498,27 @@
(check-subst-if '(z)
(complement #'consp)
'(a (a b) (c d e) (f g h i)))
((Z)
((Z) (Z) Z)
((Z) (Z) (Z) Z)
((Z) (Z) (Z) (Z) Z)
Z))
((z)
((z) (z) z)
((z) (z) (z) z)
((z) (z) (z) (z) z)
z))
(deftest subst-if-not.2
(check-subst-if-not 'a (complement #'listp)
'((100 1) (2 3) (4 3 2 1) (a b c)))
A)
a)
(deftest subst-if.4
(check-subst-if 'b #'identity '((100 1) (2 3) (4 3 2 1) (a b c))
:key #'listp)
B)
b)
(deftest subst-if-not.3
(check-subst-if-not 'c #'identity
'((100 1) (2 3) (4 3 2 1) (a b c))
:key (complement #'listp))
C)
c)
(deftest subst-if.5
(check-subst-if 4 #'(lambda (x) (eql x 1))
......@@ -646,11 +646,11 @@
(deftest nsubst.4
(check-nsubst 'grape 'dick
'(melville wrote (moby dick)))
(MELVILLE WROTE (MOBY GRAPE)))
(melville wrote (moby grape)))
(deftest nsubst.5
(check-nsubst 'cha-cha-cha 'nil '(melville wrote (moby dick)))
(MELVILLE WROTE (MOBY DICK . CHA-CHA-CHA) . CHA-CHA-CHA))
(melville wrote (moby dick . cha-cha-cha) . cha-cha-cha))
(deftest nsubst.6
(check-nsubst
......@@ -742,15 +742,15 @@
(deftest nsubst-if.1
(check-nsubst-if 'a #'consp '((100 1) (2 3) (4 3 2 1) (a b c)))
A)
a)
(deftest nsubst-if-not.1
(check-nsubst-if-not '(x) 'consp '(1 (1 2) (1 2 3) (1 2 3 4)))
((X)
((X) (X) X)
((X) (X) (X) X)
((X) (X) (X) (X) X)
X))
((x)
((x) (x) x)
((x) (x) (x) x)
((x) (x) (x) (x) x)
x))
(deftest nsubst-if.2
(check-nsubst-if 17 (complement #'listp) '(a (a b) (a c d) (a nil e f g)))
......@@ -760,27 +760,27 @@
(check-nsubst-if '(z)
(complement #'consp)
'(a (a b) (c d e) (f g h i)))
((Z)
((Z) (Z) Z)
((Z) (Z) (Z) Z)
((Z) (Z) (Z) (Z) Z)
Z))
((z)
((z) (z) z)
((z) (z) (z) z)
((z) (z) (z) (z) z)
z))
(deftest nsubst-if-not.2
(check-nsubst-if-not 'a (complement #'listp)
'((100 1) (2 3) (4 3 2 1) (a b c)))
A)
a)
(deftest nsubst-if.4
(check-nsubst-if 'b #'identity '((100 1) (2 3) (4 3 2 1) (a b c))
:key #'listp)
B)
b)
(deftest nsubst-if-not.3
(check-nsubst-if-not 'c #'identity
'((100 1) (2 3) (4 3 2 1) (a b c))
:key (complement #'listp))
C)
c)
(deftest nsubst-if.5
(check-nsubst-if 4 #'(lambda (x) (eql x 1))
......
......@@ -202,7 +202,7 @@
:test #'(lambda (x y)
(unless (eqt x 'a) (return-from fail 'fail))
(eqt x y))))
(A . 3))
(a . 3))
;;; Order of argument evaluation
......
......@@ -189,7 +189,7 @@
:test #'(lambda (x y)
(unless (eqt x 'a) (return-from fail 'fail))
(eqt x y))))
(3 . A))
(3 . a))
;;; Order of argument evaluation
......
......@@ -30,27 +30,27 @@
nil nil)
(deftest find-symbol.6
(find-symbol "CAR" "CL")
(find-symbol (string '#:car) "CL")
car :external)
(deftest find-symbol.7
(find-symbol "CAR" "COMMON-LISP")
(find-symbol (string '#:car) "COMMON-LISP")
car :external)
(deftest find-symbol.8
(values (find-symbol "CAR" "COMMON-LISP-USER"))
(values (find-symbol (string '#:car) "COMMON-LISP-USER"))
car #| :inherited |# )
(deftest find-symbol.9
(find-symbol "CAR" "CL-TEST")
(find-symbol (string '#:car) "CL-TEST")
car :inherited)
(deftest find-symbol.10
(find-symbol "TEST" "KEYWORD")
(find-symbol (string '#:test) "KEYWORD")
:test :external)
(deftest find-symbol.11
(find-symbol "FIND-SYMBOL.11" "CL-TEST")
(find-symbol (string '#:find-symbol.11) "CL-TEST")
find-symbol.11 :internal)
(deftest find-symbol.12
......@@ -78,7 +78,7 @@
(deftest find-symbol.order.1
(let ((i 0) x y)
(values
(find-symbol (progn (setf x (incf i)) "CAR")
(find-symbol (progn (setf x (incf i)) (string '#:car))
(progn (setf y (incf i)) "COMMON-LISP"))
i x y))
car 2 1 2)
......
......@@ -81,27 +81,27 @@
(deftest package-name.7
(package-name "CL")
"COMMON-LISP")
#.(string '#:common-lisp))
(deftest package-name.8
(package-name "COMMON-LISP")
"COMMON-LISP")
#.(string '#:common-lisp))
(deftest package-name.9
(package-name "COMMON-LISP-USER")
"COMMON-LISP-USER")
#.(string '#:common-lisp-user))
(deftest package-name.10
(package-name "CL-USER")
"COMMON-LISP-USER")
#.(string '#:common-lisp-user))
(deftest package-name.11
(package-name "KEYWORD")
"KEYWORD")
#.(string '#:keyword))
(deftest package-name.12
(package-name (find-package "CL"))
"COMMON-LISP")
#.(string '#:common-lisp))
(deftest package-name.13
(let* ((p (make-package "TEMP1"))
......@@ -168,7 +168,7 @@
(deftest package-nicknames.7
(ignore-errors
(subsetp '("CL")
(subsetp '(#.(string '#:cl))
(package-nicknames "COMMON-LISP")
:test #'string=))
t)
......@@ -176,7 +176,7 @@
(deftest package-nicknames.8
(ignore-errors
(notnot
(subsetp '("CL-USER")
(subsetp '(#.(string '#:cl-user))
(package-nicknames "COMMON-LISP-USER")
:test #'string=)))
t)
......
......@@ -118,7 +118,7 @@
(push s x)
(go foo)
bar
(push T x)
(push t x)
foo)
(sort-symbols x)))
(error (c) c))
......@@ -134,7 +134,7 @@
(push s x)
(go foo)
bar
(push T x)
(push t x)
foo)
(sort-symbols x)))
(error (c) c))
......
......@@ -10,16 +10,16 @@
(:use :cl)
(:nicknames :rtest #-lispworks :rt)
(:export
"*DO-TESTS-WHEN-DEFINED*"
"*TEST*"
"CONTINUE-TESTING"
"DEFTEST"
"DO-TEST"
"DO-TESTS"
"GET-TEST"
"PENDING-TESTS"
"REM-ALL-TESTS"
"REM-TEST"
#:*do-tests-when-defined*
#:*test*
#:continue-testing
#:deftest
#:do-test
#:do-tests
#:get-test
#:pending-tests
#:rem-all-tests
#:rem-test
)))
(in-package :regression-test)
......@@ -6,9 +6,9 @@
(in-package :cl-test)
(defparameter *searched-list*
'(B B A B B B B B B B A B A B B B A B A B B B A A A A B A A B A A A A A
A B A B B A B A A B A A A B B A A B A A A A B B A B A B A A A B A B
B A B A A B B B B B A A A A A B A B B B B B A B A B B A B A B))
'(b b a b b b b b b b a b a b b b a b a b b b a a a a b a a b a a a a a
a b a b b a b a a b a a a b b a a b a a a a b b a b a b a a a b a b
b a b a a b b b b b a a a a a b a b b b b b a b a b b a b a b))
(defparameter *pattern-sublists*
(remove-duplicates
......
......@@ -22,13 +22,13 @@
(setf structure-name (string structure-name))
(intern (concatenate 'string
structure-name
"-P")))
(string '#:-p))))
(defun make-struct-copy-fn (structure-name)
(assert (typep structure-name '(or string symbol character)))
(setf structure-name (string structure-name))
(intern (concatenate 'string
"COPY-"
(string '#:copy-)
structure-name)))
(defun make-struct-field-fn (conc-name field-name)
......@@ -47,7 +47,7 @@
(assert (typep structure-name '(or string symbol character)))
(setf structure-name (string structure-name))
(intern (concatenate 'string
"MAKE-" structure-name)))
(string '#:make-) structure-name)))
(defun create-instance-of-type (type)
"Return an instance of a type. Signal an error if
......@@ -72,7 +72,7 @@
((and (symbolp type)
(typep type 'structure-class))
(let ((make-fn
(intern (concatenate 'string "MAKE-" (symbol-name type))
(intern (concatenate 'string (string '#:make-) (symbol-name type))
(symbol-package type))))
(eval (list make-fn))))
((eqt type 'character) #\w)
......
......@@ -58,8 +58,8 @@
`(
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))
,@(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)))
......@@ -72,39 +72,39 @@
(defvar *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)
(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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment