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

Last change on this file since 8179 was 8179, checked in by piso, 17 years ago

Work in progress.

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