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

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

complex
complexp

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