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

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

bit-array-ops.lisp

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