source: trunk/j/src/org/armedbear/lisp/rt.lisp @ 8496

Last change on this file since 8496 was 8496, checked in by piso, 16 years ago

DEFTEST: bind *PRINT-PRETTY* to T when printing the results (as well as the form).

File size: 19.2 KB
Line 
1;;; rt.lisp
2;;;
3;;; Copyright (C) 2003-2004 Peter Graves
4;;; $Id: rt.lisp,v 1.161 2005-02-06 19:59:29 piso Exp $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19
20;;; Adapted from rt.lsp and ansi-aux.lsp in the GCL ANSI test suite.
21
22(defpackage :regression-test (:use :cl) (:nicknames #-lispworks :rt))
23
24(in-package :regression-test)
25
26(export '(deftest my-aref))
27
28(defvar *prefix*
29  #-(or windows mswindows) "/home/peter/gcl/ansi-tests/"
30  #+(or windows mswindows) "C:\\ansi-tests\\")
31
32(defvar *compile-tests* t)
33
34(defvar *passed* 0)
35(defvar *failed* 0)
36
37(defun my-aref (a &rest args)
38  (apply #'aref a args))
39
40(defun my-row-major-aref (a index)
41  (row-major-aref a index))
42
43(defun equalp-with-case (x y)
44  (cond
45   ((eq x y) t)
46   ((consp x)
47    (and (consp y)
48   (equalp-with-case (car x) (car y))
49   (equalp-with-case (cdr x) (cdr y))))
50   ((and (typep x 'array)
51   (= (array-rank x) 0))
52    (equalp-with-case (aref x) (aref y)))
53   ((typep x 'vector)
54    (and (typep y 'vector)
55   (let ((x-len (length x))
56         (y-len (length y)))
57     (and (eql x-len y-len)
58    (loop
59     for e1 across x
60     for e2 across y
61     always (equalp-with-case e1 e2))))))
62   ((and (typep x 'array)
63   (typep y 'array)
64   (not (equal (array-dimensions x)
65         (array-dimensions y))))
66    nil)
67   ((typep x 'array)
68    (and (typep y 'array)
69   (let ((size (array-total-size x)))
70     (loop for i from 0 below size
71     always (equalp-with-case (row-major-aref x i)
72            (row-major-aref y i))))))
73   ((typep x 'pathname)
74    (equal x y))
75   (t (eql x y))))
76
77(defmacro deftest (name &rest body)
78  (fresh-line)
79  (format t "Test ~S~%" `,name)
80  (finish-output)
81  (let* ((p body)
82   (properties
83    (loop while (keywordp (first p))
84            unless (cadr p)
85            do (error "Poorly formed deftest: ~S~%"
86                      (list* 'deftest name body))
87            append (list (pop p) (pop p))))
88   (form (pop p))
89   (values p))
90    (let* ((aborted nil)
91           (r (handler-case (multiple-value-list
92                             (cond (*compile-tests*
93                                    (funcall (compile nil `(lambda () ,form))))
94                                   (t
95                                    (eval `,form))))
96                            (error (c) (setf aborted t) (list c))))
97           (passed (and (not aborted) (equalp-with-case r `,values))))
98      (unless passed
99        (let ((*print-pretty* t))
100          (format t "Form: ~S~%" `,form)
101          (format t "Expected value: ~S~%"
102                  (if (= (length `,values) 1)
103                      (car `,values)
104                      `,values))
105          (let ((r (if (= (length r) 1) (car r) r)))
106            (format t "Actual value: ~S" r)
107            (when (typep r 'condition)
108              (format t " [\"~A\"]" r))
109            (terpri))
110          (finish-output)))
111      (if passed (incf *passed*) (incf *failed*)))))
112
113(in-package :cl-user)
114
115(intern "==>" "CL-USER")
116
117(defvar *compiled-and-loaded-files* nil)
118
119(defun compile-and-load (filename &key force)
120  (let* ((pathname (concatenate 'string regression-test::*prefix* filename))
121         (former-data (assoc pathname *compiled-and-loaded-files*
122           :test #'equalp))
123   (compile-pathname (compile-file-pathname pathname))
124   (source-write-time (file-write-date pathname))
125         (target-write-time (and (probe-file compile-pathname)
126                                 (file-write-date compile-pathname))))
127    (unless (and (not force)
128     former-data
129     (>= (cadr former-data) source-write-time))
130      (when (or (not target-write-time)
131    (<= target-write-time source-write-time))
132  (compile-file pathname))
133      (if former-data
134    (setf (cadr former-data) source-write-time)
135          (push (list pathname source-write-time) *compiled-and-loaded-files*))
136      (load compile-pathname))))
137
138(defpackage :cl-test
139  (:use :cl :regression-test)
140  (:nicknames)
141  (:shadow #:handler-case #:handler-bind)
142  (:import-from "COMMON-LISP-USER" #:compile-and-load "==>")
143  (:export #:random-from-seq #:random-case #:coin #:random-permute))
144
145(defun do-tests (&rest args)
146  (let ((regression-test::*passed* 0)
147        (regression-test::*failed* 0)
148        (*default-pathname-defaults* (pathname regression-test::*prefix*))
149        (suffix ".lsp")
150        (tests (or args '("abs"
151                          "acons"
152                          "adjoin"
153                          "and"
154                          "append"
155                          "apply"
156                          "aref"
157                          "array"
158                          "array-as-class"
159                          "array-dimension"
160                          "array-dimensions"
161                          "array-displacement"
162                          "array-in-bounds-p"
163                          "array-misc"
164                          "array-rank"
165                          "array-row-major-index"
166                          "array-t"
167                          "array-total-size"
168                          "arrayp"
169                          "ash"
170                          "assoc"
171                          "assoc-if"
172                          "assoc-if-not"
173                          "atom"
174                          "bit"
175                          "bit-and"
176                          "bit-andc1"
177                          "bit-andc2"
178                          "bit-eqv"
179                          "bit-ior"
180                          "bit-nand"
181                          "bit-nor"
182                          "bit-not"
183                          "bit-orc1"
184                          "bit-orc2"
185                          "bit-vector"
186                          "bit-vector-p"
187                          "bit-xor"
188                          "block"
189                          "boole"
190                          "boundp"
191                          "butlast"
192                          "byte"
193                          "call-arguments-limit"
194                          "case"
195                          "catch"
196                          "ccase"
197                          "ceiling"
198                          "cell-error-name"
199                          "char-compare"
200                          "char-schar"
201                          "character"
202                          "cl-symbols"
203                          "coerce"
204                          "complement"
205                          "complex"
206                          "complexp"
207                          "concatenate"
208                          "cond"
209                          "condition"
210                          "conjugate"
211                          "cons"
212                          "cons-test-01"
213                          "cons-test-03"
214                          "cons-test-05"
215                          "consp"
216                          "constantly"
217                          "constantp"
218                          "copy-alist"
219                          "copy-list"
220                          "copy-seq"
221                          "copy-symbol"
222                          "copy-tree"
223                          "count"
224                          "count-if"
225                          "count-if-not"
226                          "ctypecase"
227                          "cxr"
228                          "defconstant"
229                          "define-modify-macro"
230                          "defmacro"
231                          "defparameter"
232                          "defun"
233                          "defvar"
234                          "destructuring-bind"
235                          "divide"
236                          "dpb"
237                          "ecase"
238                          "elt"
239                          "endp"
240                          "epsilons"
241                          "eql"
242                          "equal"
243                          "equalp"
244                          "error"
245                          "etypecase"
246                          "eval"
247                          "evenp"
248                          "every"
249                          "expt"
250                          "fboundp"
251                          "fceiling"
252                          "fdefinition"
253                          "ffloor"
254                          "fill"
255                          "fill-pointer"
256                          "fill-strings"
257                          "find"
258                          "find-if"
259                          "find-if-not"
260                          "flet"
261                          "float"
262                          "floatp"
263                          "floor"
264                          "fmakunbound"
265                          "fround"
266                          "ftruncate"
267                          "funcall"
268                          "function"
269                          "function-lambda-expression"
270                          "functionp"
271                          "gcd"
272                          "gensym"
273                          "get-properties"
274                          "getf"
275                          "handler-bind"
276                          "handler-case"
277                          "hash-table"
278                          "identity"
279                          "if"
280                          "ignore-errors"
281                          "imagpart"
282                          "integer-length"
283                          "integerp"
284                          "intersection"
285                          "invoke-debugger"
286                          "isqrt"
287                          "iteration"
288                          "keywordp"
289                          "labels"
290                          "lambda"
291                          "lambda-list-keywords"
292                          "lambda-parameters-limit"
293                          "last"
294                          "lcm"
295                          "ldb"
296                          "ldiff"
297                          "length"
298                          "let"
299                          "list"
300                          "list-length"
301                          "listp"
302                          "load-structures"
303                          "logand"
304                          "logandc1"
305                          "logandc2"
306                          "logbitp"
307                          "logeqv"
308                          "logior"
309                          "lognor"
310                          "lognot"
311                          "logorc1"
312                          "logorc2"
313                          "logxor"
314                          "loop"
315                          "loop1"
316                          "loop2"
317                          "loop3"
318                          "loop4"
319                          "loop5"
320                          "loop6"
321                          "loop7"
322                          "loop8"
323                          "loop9"
324                          "loop10"
325                          "loop11"
326                          "loop12"
327                          "loop13"
328                          "loop14"
329                          "loop15"
330                          "loop16"
331                          "loop17"
332                          "make-array"
333                          "make-list"
334                          "make-sequence"
335                          "make-string"
336                          "make-symbol"
337                          "map"
338                          "map-into"
339                          "mapc"
340                          "mapcan"
341                          "mapcar"
342                          "mapcon"
343                          "mapl"
344                          "maplist"
345                          "max"
346                          "member"
347                          "member-if"
348                          "member-if-not"
349                          "merge"
350                          "min"
351                          "minus"
352                          "minusp"
353                          "mismatch"
354                          "multiple-value-bind"
355                          "multiple-value-call"
356                          "multiple-value-list"
357                          "multiple-value-prog1"
358                          "multiple-value-setq"
359                          "nbutlast"
360                          "nconc"
361                          "nil"
362                          "nintersection"
363                          "not-and-null"
364                          "notany"
365                          "notevery"
366                          "nreconc"
367                          "nreverse"
368                          "nset-difference"
369                          "nset-exclusive-or"
370                          "nstring-capitalize"
371                          "nstring-downcase"
372                          "nstring-upcase"
373                          "nsublis"
374                          "nsubst"
375                          "nsubst-if"
376                          "nsubst-if-not"
377                          "nsubstitute"
378                          "nsubstitute-if"
379                          "nsubstitute-if-not"
380                          "nth"
381                          "nth-value"
382                          "nthcdr"
383                          "number-comparison"
384                          "numerator-denominator"
385                          "nunion"
386                          "oddp"
387                          "oneminus"
388                          "oneplus"
389                          "or"
390                          "load-packages"
391                          "pairlis"
392                          "parse-integer"
393                          "phase"
394                          "places"
395                          "plus"
396                          "plusp"
397                          "pop"
398                          "position"
399                          "position-if"
400                          "position-if-not"
401                          "prog"
402                          "prog1"
403                          "prog2"
404                          "progn"
405                          "progv"
406                          "psetf"
407                          "psetq"
408                          "push"
409                          "pushnew"
410                          "random"
411                          "rassoc"
412                          "rassoc-if"
413                          "rassoc-if-not"
414                          "rational"
415                          "rationalize"
416                          "rationalp"
417                          "realp"
418                          "realpart"
419                          "reduce"
420                          "remf"
421                          "remove"
422                          "remove-duplicates"
423                          "replace"
424                          "rest"
425                          "return"
426                          "revappend"
427                          "reverse"
428                          "rotatef"
429                          "round"
430                          "row-major-aref"
431                          "rplaca"
432                          "rplacd"
433                          "sbit"
434                          "search-bitvector"
435                          "search-list"
436                          "search-string"
437                          "search-vector"
438                          "set-difference"
439                          "set-exclusive-or"
440                          "shiftf"
441                          "signum"
442                          "simple-array"
443                          "simple-array-t"
444                          "simple-bit-vector"
445                          "simple-bit-vector-p"
446                          "simple-vector-p"
447                          "some"
448                          "sort"
449                          "special-operator-p"
450                          "string"
451                          "string-capitalize"
452                          "string-comparisons"
453                          "string-downcase"
454                          "string-left-trim"
455                          "string-right-trim"
456                          "string-trim"
457                          "string-upcase"
458                          "sublis"
459                          "subseq"
460                          "subsetp"
461                          "subst"
462                          "subst-if"
463                          "subst-if-not"
464                          "substitute"
465                          "substitute-if"
466                          "substitute-if-not"
467                          "subtypep"
468                          "subtypep-cons"
469                          "subtypep-eql"
470                          "subtypep-float"
471                          "subtypep-integer"
472                          "subtypep-member"
473                          "subtypep-rational"
474                          "subtypep-real"
475                          "svref"
476                          "symbol-name"
477                          "t"
478                          "tagbody"
479                          "tailp"
480                          "times"
481                          "tree-equal"
482                          "truncate"
483                          "typecase"
484                          "union"
485                          "unless"
486                          "unwind-protect"
487                          "values"
488                          "values-list"
489                          "vector"
490                          "vector-pop"
491                          "vector-push"
492                          "vector-push-extend"
493                          "vectorp"
494                          "when"
495                          "zerop"))))
496    (dolist (test tests)
497      (load (concatenate 'string regression-test::*prefix* test suffix)))
498    (format t "~A tests: ~A passed, ~A failed~%"
499            (+ regression-test::*passed* regression-test::*failed*)
500            regression-test::*passed*
501            regression-test::*failed*)
502    (format t "*compile-tests* was ~A~%" regression-test::*compile-tests*))
503  (values))
504
505(defun do-all-tests (&optional (compile-tests t))
506  (let ((regression-test::*compile-tests* compile-tests))
507    (time (do-tests))))
508
509(compile-and-load "ansi-aux-macros.lsp")
510(load (concatenate 'string regression-test::*prefix* "universe.lsp"))
511(compile-and-load "random-aux.lsp")
512(compile-and-load "ansi-aux.lsp")
513
514(compile-and-load "char-aux.lsp")
515(load (concatenate 'string regression-test::*prefix* "cl-symbols-aux.lsp"))
516(load (concatenate 'string regression-test::*prefix* "cl-symbol-names.lsp"))
517(load (concatenate 'string regression-test::*prefix* "array-aux.lsp"))
518(load (concatenate 'string regression-test::*prefix* "subseq-aux.lsp"))
519(load (concatenate 'string regression-test::*prefix* "cons-aux.lsp"))
520(load (concatenate 'string regression-test::*prefix* "numbers-aux.lsp"))
521(load (concatenate 'string regression-test::*prefix* "string-aux.lsp"))
522(load (concatenate 'string regression-test::*prefix* "remove-aux.lsp"))
523(load (concatenate 'string regression-test::*prefix* "remove-duplicates-aux.lsp"))
524
525#+armedbear
526(when (and (fboundp 'jvm::jvm-compile) (not (autoloadp 'jvm::jvm-compile)))
527  (mapcar #'jvm::jvm-compile '(regression-test::equalp-with-case
528                               cl-test::make-scaffold-copy
529                               cl-test::check-scaffold-copy
530                               cl-test::is-intersection)))
Note: See TracBrowser for help on using the repository browser.