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

Last change on this file since 3917 was 3917, checked in by piso, 19 years ago

ignore-errors

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