Changed the license to the AGPL3. Downcased all the lisp sources. Completed the READM...
[com-informatimago:com-informatimago.git] / clext / tests.lisp
1 ;;;; -*- coding:utf-8 -*-
2
3 ;;;
4 ;;; This tests.lisp is taken from clisp-2.38/tests/tests.lisp
5 ;;; and modified to take only the weak-*.tst files we're interested in.
6 ;;;
7
8 ;; run the test suit:
9
10 (defun princ-error (c) (format t "~&[~A]: ~A~%" (type-of c) c))
11
12 #+old-clisp
13 ;; Binding *ERROR-HANDLER* is a hammer technique for catching errors. It also
14 ;; disables CLCS processing and thus breaks tests that rely on the condition
15 ;; system, such as:
16 ;;   - the compile-file on structure literal test in clos.lisp
17 ;;   - all tests that use IGNORE-ERRORS
18 (defmacro with-ignored-errors (&rest forms)
19   (let ((b (gensym)))
20     `(block ,b
21        (let ((*error-handler*
22               #'(lambda (&rest args)
23                   (with-standard-io-syntax
24                     (let* ((*print-readably* nil)
25                            (error-message (apply #'format nil (cdr args))))
26                       (terpri) (princ error-message)
27                       (return-from ,b (values 'error error-message)))))))
28          ,@forms))))
29
30 #+(or (and akcl (not gcl)) ecl)
31 (defmacro with-ignored-errors (&rest forms)
32   (let ((b (gensym))
33         (h (gensym)))
34     `(block ,b
35        (let ((,h (symbol-function 'system:universal-error-handler)))
36          (unwind-protect
37               (progn (setf (symbol-function 'system:universal-error-handler)
38                            #'(lambda (&rest args) (return-from ,b 'error)))
39                      ,@forms)
40            (setf (symbol-function 'system:universal-error-handler) ,h))))))
41
42 #+allegro
43 (defmacro with-ignored-errors (&rest forms)
44   (let ((r (gensym)))
45     `(let ((,r (multiple-value-list (excl:errorset (progn ,@forms)))))
46        (if (car ,r) (values-list (cdr ,r)) 'error))))
47
48 #-(or old-clisp (and akcl (not gcl)) ecl allegro)
49 (defmacro with-ignored-errors (&rest forms)
50   (let ((b (gensym)))
51     `(block ,b
52        (handler-bind
53            ((error #'(lambda (condition)
54                        (princ-error condition)
55                        (return-from ,b (values 'error
56                                                (princ-to-string condition))))))
57          ,@forms))))
58
59 (defun merge-extension (type filename)
60   (make-pathname :type type :defaults filename))
61
62 ;; (lisp-implementation-type) may return something quite long, e.g.,
63 ;; on CMUCL it returns "CMU Common Lisp".
64 (defvar lisp-implementation
65   #+clisp "CLISP" #+(and akcl (not gcl)) "AKCL" #+gcl "GCL" #+ecl "ECL" #+allegro "ALLEGRO" #+cmu "CMUCL"
66   #-(or clisp akcl gcl ecl allegro cmu) (lisp-implementation-type))
67
68 (defvar *eval-method* :eval)
69 (defvar *eval-out* nil)
70 (defvar *eval-err* nil)
71 (defun my-eval (form)
72   (when *eval-out* (get-output-stream-string *eval-out*))
73   (when *eval-err* (get-output-stream-string *eval-err*))
74   (ecase *eval-method*
75     (:eval (eval form))
76     (:compile (funcall (compile nil `(lambda () ,form))))
77     (:both (let ((e-value (eval form))
78                  (c-value (funcall (compile nil `(lambda () ,form)))))
79              (unless (equalp e-value c-value)
80                (error "eval: ~S; compile: ~S" e-value c-value))
81              e-value))))
82
83 (defgeneric pretty-compare (result my-result log)
84   (:documentation "print a pretty comparison of two results")
85   (:method ((result sequence) (my-result sequence) (log stream))
86     (let ((pos (mismatch result my-result :test #'equalp)))
87       (let ((*print-length* 10))
88         (if pos
89             (flet ((pretty-tail-10 (seq)
90                      (if (and (> (length seq) (+ pos 10))
91                               (typep seq 'string))
92                          (concatenate 'string (subseq seq pos (+ pos 10)) "...")
93                          (subseq seq pos))))
94               (format log "~&Differ at position ~:D: ~S vs ~S~%CORRECT: ~S~%~7A: ~S~%"
95                       pos
96                       (if (< pos (length result))
97                           (elt result pos) 'end-of-sequence)
98                       (if (< pos (length my-result))
99                           (elt my-result pos) 'end-of-sequence)
100                       (pretty-tail-10 result)
101                       lisp-implementation
102                       (pretty-tail-10 my-result)))
103             (format log "~&Type mismatch: ~S should be ~S~%"
104                     (type-of my-result) (type-of result))))))
105   (:method ((result pathname) (my-result pathname) (log stream))
106     (dolist (slot '(pathname-host pathname-device pathname-directory
107                     pathname-name pathname-type pathname-version))
108       (let ((s-r (funcall slot result)) (s-m (funcall slot my-result)))
109         (format log "~&~S:~%CORRECT: ~S~%~7A: ~S~%~:[ DIFFERENT!~;same~]~%"
110                 slot s-r lisp-implementation s-m (equal s-r s-m)))))
111   (:method ((result t) (my-result t) (log stream)))) ; do nothing
112
113 (defun show (object &key ((:pretty *print-pretty*) *print-pretty*))
114   "Print the object on its own line and return it. Used in many tests!"
115   (fresh-line) (prin1 object) (terpri) object)
116
117 (defun type-error-handler (err)
118   "Print the condition and THROW.
119 Usage: (handler-bind ((type-error #'type-error-handler)) ...)"
120   (princ-error err)
121   (let ((da (type-error-datum err)) (et (type-error-expected-type err)))
122     (show (list :datum da :expected-type et) :pretty t)
123     (throw 'type-error-handler (typep da et))))
124
125 (defvar *test-ignore-errors* t)
126 (defvar *test-result-in-file* t
127   "T: CLISP-style: evaluation result in the file after the test form.
128 NIL: sacla-style: forms should evaluate to non-NIL.")
129 (defun do-test (stream log)
130   (let ((eof stream) (error-count 0) (total-count 0))
131     (loop
132        (let ((form (read stream nil eof)) out err (result nil))
133          (when (or (eq form eof) (eq result eof)) (return))
134          (if *test-result-in-file*
135              (setq result (read stream))
136              (setq form `(not ,form)))
137          (incf total-count)
138          (show form)
139          (multiple-value-bind (my-result error-message)
140              (if *test-ignore-errors*
141                  (with-ignored-errors (my-eval form)) ; return ERROR on errors
142                  (my-eval form)) ; don't disturb the condition system when testing it!
143            (setq out (and *eval-out* (get-output-stream-string *eval-out*))
144                  err (and *eval-err* (get-output-stream-string *eval-err*)))
145            (cond ((eql result my-result)
146                   (format t "~&EQL-OK: ~S~%" result))
147                  ((equal result my-result)
148                   (format t "~&EQUAL-OK: ~S~%" result))
149                  ((equalp result my-result)
150                   (format t "~&EQUALP-OK: ~S~%" result))
151                  (t
152                   (incf error-count)
153                   (format t "~&ERROR!! ~S should be ~S !~%" my-result result)
154                   (format log "~&Form: ~S~%CORRECT: ~S~%~7A: ~S~%~@[~A~%~]"
155                           form result lisp-implementation
156                           my-result error-message)
157                   (pretty-compare result my-result log)
158                   (format log "~[~*~:;OUT:~%~S~%~]~[~*~:;ERR:~%~S~]~2%"
159                           (length out) out (length err) err))))))
160     (values total-count error-count)))
161
162 (defmacro check-ignore-errors (&body body)
163   `(handler-case (progn ,@body)
164      (type-error (c)
165        (if (ignore-errors
166              (typep (type-error-datum c) (type-error-expected-type c)))
167            (format nil "[~S --> ~A]: ~S is of type ~S" ',body c
168                    (type-error-datum c) (type-error-expected-type c))
169            c))
170      (stream-error (c)
171        (if (streamp (stream-error-stream c)) c
172            (format nil "[~S --> ~A]: ~S is not a ~S" ',body c
173                    (stream-error-stream c) 'stream)))
174      (file-error (c)
175        (let ((path (file-error-pathname c)))
176          (if (or (pathnamep path) (stringp path) (characterp path)) c
177              (format nil "[~S --> ~A]: ~S is not a ~S" ',body c
178                      (file-error-pathname c) 'pathname))))
179      (package-error (c)
180        (let ((pack (package-error-package c)))
181          (if (or (packagep pack) (stringp pack) (characterp pack)) c
182              (format nil "[~S --> ~A]: ~S is not a ~S" ',body c
183                      (package-error-package c) 'package))))
184      (cell-error (c)
185        (if (cell-error-name c) c
186            (format nil "[~S --> ~A]: no cell name" ',body c)))
187      (error (c) c)
188      (:no-error (v) (format t "~&no error, value: ~S~%" v))))
189
190 (defun do-errcheck (stream log)
191   (let ((eof "EOF") (error-count 0) (total-count 0))
192     (loop
193        (let ((form (read stream nil eof))
194              (errtype (read stream nil eof)))
195          (when (or (eq form eof) (eq errtype eof)) (return))
196          (incf total-count)
197          (show form)
198          (let ((my-result (check-ignore-errors (my-eval form)))
199                (out (and *eval-out* (get-output-stream-string *eval-out*)))
200                (err (and *eval-err* (get-output-stream-string *eval-err*))))
201            (multiple-value-bind (typep-result typep-error)
202                (ignore-errors (typep my-result errtype))
203              (cond ((and (not typep-error) typep-result)
204                     (format t "~&OK: ~S~%" errtype))
205                    (t
206                     (incf error-count)
207                     (format t "~&ERROR!! ~S instead of ~S !~%" my-result errtype)
208                     (format log "~&Form: ~S~%CORRECT: ~S~%~7A: ~S~%~
209                                 ~[~*~:;OUT:~%~S~%~]~[~*~:;ERR:~%~S~]~2%"
210                             form errtype lisp-implementation my-result
211                             (length out) out (length err) err)))))))
212     (values total-count error-count)))
213
214 (defvar *run-test-tester* #'do-test)
215 (defvar *run-test-type* "tst")
216 (defvar *run-test-erg* "erg")
217 (defvar *run-test-truename*)
218 (defun run-test (testname
219                  &key ((:tester *run-test-tester*) *run-test-tester*)
220                  ((:ignore-errors *test-ignore-errors*)
221                   *test-ignore-errors*)
222                  ((:eval-method *eval-method*) *eval-method*)
223                  (logname testname)
224                  &aux (logfile (merge-extension *run-test-erg* logname))
225                  error-count total-count *run-test-truename*)
226   (with-open-file (s (merge-extension *run-test-type* testname)
227                      :direction :input)
228     (setq *run-test-truename* (truename s))
229     (format t "~&~s: started ~s~%" 'run-test s)
230     (with-open-file (log logfile :direction :output
231                          #+(or cmu sbcl) :if-exists
232                          #+(or cmu sbcl) :supersede
233                          #+ansi-cl :if-exists #+ansi-cl :new-version)
234       (setq logfile (truename log))
235       (let* ((*package* *package*) (*print-circle* t) (*print-pretty* nil)
236              (*eval-err* (make-string-output-stream))
237              (*error-output* (make-broadcast-stream *error-output* *eval-err*))
238              (*eval-out* (make-string-output-stream))
239              (*standard-output* (make-broadcast-stream *standard-output*
240                                                        *eval-out*)))
241         (setf (values total-count error-count)
242               (funcall *run-test-tester* s log)))))
243   (format t "~&~s: finished ~s (~:d error~:p out of ~:d test~:p)~%"
244           'run-test testname error-count total-count)
245   (if (zerop error-count)
246       (delete-file logfile)
247       (format t "~s: see ~a~%" 'run-test logfile))
248   (list testname total-count error-count))
249
250 (defun report-results (res)
251   "res = list of RUN-TEST return values (testname total-count error-count)"
252   (let ((error-count (reduce #'+ res :key #'third)))
253     (format
254         t "~&finished ~3d file~:p:~31T ~3:d error~:p out of~50T ~5:d test~:p~%"
255         (length res) error-count (reduce #'+ res :key #'second))
256     (loop :with here = (truename "./") :for rec :in res :for count :upfrom 1 :do
257        (format t "~&~3d ~25@a:~31T ~3:d error~:p out of~50T ~5:d test~:p~%"
258                count (enough-namestring (first rec) here)
259                (third rec) (second rec)))
260     error-count))
261
262 (defun run-some-tests (&key (dirlist '("./"))
263                        ((:eval-method *eval-method*) *eval-method*))
264   (let ((files (mapcan (lambda (dir)
265                          (directory (make-pathname :name :wild
266                                                    :type *run-test-type*
267                                                    :defaults dir)))
268                        dirlist)))
269     (if files (report-results (mapcar #'run-test files))
270         (warn "no ~S files in directories ~S" *run-test-type* dirlist))))
271
272 (defun run-all-tests (&key (disable-risky t)
273                       ((:eval-method *eval-method*) *eval-method*))
274   (let ((res ())
275         #+clisp (custom:*load-paths* nil)
276         (*features* (if disable-risky *features*
277                         (cons :enable-risky-tests *features*))))
278     ;; Since weakptr can run on #+cmu, we should run
279     ;; the other too with CLOSER-WEAK.
280     (dolist (ff '(#+(or clisp cmu sbcl)                           "weak-oid"
281                   #+(or clisp cmu sbcl)                           "weak"
282                   #+(or clisp cmu sbcl allegro openmcl lispworks) "weakhash"
283                   #+(or clisp cmu sbcl lispworks)                 "weakhash2"
284                   ))
285       (push (run-test ff) res))
286     #+(or clisp cmu sbcl allegro lispworks)
287     (let ((tmp (list "weakptr" 0 0)))
288       (push tmp res)
289       (dotimes (i 20)
290         (let ((weak-res (run-test "weakptr")))
291           (incf (second tmp) (second weak-res))
292           (incf (third tmp) (third weak-res)))))
293     (report-results (nreverse res))))