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

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

byte
float
floatp
ldb

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