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

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

phase

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