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

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

Work in progress.

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