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

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

We no longer need (REQUIRE 'DEFSTRUCT) or (REQUIRE 'LOOP).

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