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

Last change on this file since 5228 was 5228, checked in by piso, 18 years ago

Work in progress.

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