1 | (in-package :abcl.test.ansi) |
---|
2 | |
---|
3 | (defparameter *ansi-tests-master-source-location* |
---|
4 | "<git+https://gitlab.common-lisp.net/ansi-test/ansi-test.git>") |
---|
5 | |
---|
6 | (defparameter *ansi-tests-directory* |
---|
7 | (asdf:system-relative-pathname :ansi-compiled "../ansi-test/")) |
---|
8 | |
---|
9 | (defun run (&key (compile-tests nil)) |
---|
10 | "Run the ANSI-TESTS suite, to be found in *ANSI-TESTS-DIRECTORY*. |
---|
11 | Possibly running the compiled version of the tests if COMPILE-TESTS is non-NIL." |
---|
12 | (verify-ansi-tests) |
---|
13 | (mapcar (lambda (result) |
---|
14 | (when (second result) |
---|
15 | (format t "Removed ~A.~&" (first result)))) |
---|
16 | (clean-tests)) |
---|
17 | (let* ((ansi-tests-directory |
---|
18 | *ansi-tests-directory*) |
---|
19 | (boot-file |
---|
20 | (if compile-tests "compileit.lsp" "doit.lsp")) |
---|
21 | (message |
---|
22 | (format nil "Invocation of '~A' in ~A" |
---|
23 | boot-file ansi-tests-directory))) |
---|
24 | (progv |
---|
25 | '(*default-pathname-defaults*) |
---|
26 | `(,(merge-pathnames *ansi-tests-directory* |
---|
27 | *default-pathname-defaults*)) |
---|
28 | (format t "---> ~A begins.~%" message) |
---|
29 | (format t "Invoking ABCL hosted on ~A ~A.~%" |
---|
30 | (software-type) (software-version)) |
---|
31 | (time (load boot-file)) |
---|
32 | (format t "<--- ~A ends.~%" message)))) |
---|
33 | |
---|
34 | (defun verify-ansi-tests () |
---|
35 | (unless |
---|
36 | (probe-file *ansi-tests-directory*) |
---|
37 | (error 'file-error |
---|
38 | "Failed to find the GCL ANSI tests in '~A'. Please |
---|
39 | locally obtain ~A, and place it in a sibling directory to the ABCL source named '../ansi-tests/'" |
---|
40 | *ansi-tests-directory* |
---|
41 | *ansi-tests-master-source-location*))) |
---|
42 | |
---|
43 | (defvar *ansi-tests-loaded-p* nil) |
---|
44 | (defun load-tests () |
---|
45 | "Load the ANSI tests but do not execute them." |
---|
46 | (verify-ansi-tests) |
---|
47 | (let ((*default-pathname-defaults* *ansi-tests-directory*) |
---|
48 | (package *package*)) |
---|
49 | (setf *package* (find-package :cl-user)) |
---|
50 | (load "gclload1.lsp") |
---|
51 | (load "gclload2.lsp") |
---|
52 | (setf *package* package)) |
---|
53 | (setf *ansi-tests-loaded-p* t)) |
---|
54 | |
---|
55 | (defun clean-tests () |
---|
56 | "Do what 'make clean' would do from the GCL ANSI tests," |
---|
57 | ;; so we don't have to hunt for 'make' in the PATH on win32. |
---|
58 | (verify-ansi-tests) |
---|
59 | |
---|
60 | (mapcar (lambda (p) |
---|
61 | (when (probe-file p) |
---|
62 | (list p (delete-file p)))) |
---|
63 | (append (directory (format nil "~A/*.cls" *ansi-tests-directory*)) |
---|
64 | (directory (format nil "~A/*.abcl" *ansi-tests-directory*)) |
---|
65 | (directory (format nil "~A/scratch/*" *ansi-tests-directory*)) |
---|
66 | (mapcar (lambda(x) |
---|
67 | (format nil "~A/~A" *ansi-tests-directory* x)) |
---|
68 | '("scratch/" |
---|
69 | "scratch.txt" "foo.txt" "foo.lsp" |
---|
70 | "foo.dat" |
---|
71 | "tmp.txt" "tmp.dat" "tmp2.dat" |
---|
72 | "temp.dat" "out.class" |
---|
73 | "file-that-was-renamed.txt" |
---|
74 | "compile-file-test-lp.lsp" |
---|
75 | "compile-file-test-lp.out" |
---|
76 | "ldtest.lsp"))))) |
---|
77 | |
---|
78 | ;;; XXX move this into test-utilities.lisp? |
---|
79 | (defvar *last-run-matching* "bit-vector") |
---|
80 | |
---|
81 | (defun do-tests-matching (&optional (match *last-run-matching*)) |
---|
82 | "Run all tests in suite whose symbol contains MATCH in a case-insensitive manner." |
---|
83 | (setf *last-run-matching* match) |
---|
84 | (let* ((matching (string-upcase match)) |
---|
85 | (count 0) |
---|
86 | (*default-pathname-defaults* *ansi-tests-directory*)) |
---|
87 | (mapcar (lambda (entry) |
---|
88 | (if (search matching (symbol-name (rt::name entry))) |
---|
89 | (setf (rt::pend entry) t |
---|
90 | count (1+ count)) |
---|
91 | (setf (rt::pend entry) nil))) |
---|
92 | (rest rt::*entries*)) |
---|
93 | (format t "Performing ~A tests matching '~A'.~%" count matching) |
---|
94 | (rt::do-entries t))) |
---|