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

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

define-modify-macro

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