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

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

Minor cleanup.

File size: 15.6 KB
Line 
1;;; rt.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: rt.lisp,v 1.96 2003-08-06 19:38:59 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(require 'defstruct)
23(require 'loop)
24
25(unless (find-package :regression-test)
26  (make-package :regression-test :nicknames '(:rt))
27  (use-package :cl :rt))
28
29(in-package :rt)
30
31(export '(deftest))
32
33(defvar *prefix* "/home/peter/gcl/ansi-tests/")
34
35(defvar *compile-tests* nil)
36
37(defvar *passed* 0)
38(defvar *failed* 0)
39
40(defun equalp-with-case (x y)
41  (cond
42   ((eq x y) t)
43   ((consp x)
44    (and (consp y)
45   (equalp-with-case (car x) (car y))
46   (equalp-with-case (cdr x) (cdr y))))
47   ((and (typep x 'array)
48   (= (array-rank x) 0))
49    (equalp-with-case (aref x) (aref y)))
50   ((typep x 'vector)
51    (and (typep y 'vector)
52   (let ((x-len (length x))
53         (y-len (length y)))
54     (and (eql x-len y-len)
55    (loop
56     for e1 across x
57     for e2 across y
58     always (equalp-with-case e1 e2))))))
59   ((and (typep x 'array)
60   (typep y 'array)
61   (not (equal (array-dimensions x)
62         (array-dimensions y))))
63    nil)
64   ((typep x 'array)
65    (and (typep y 'array)
66   (let ((size (array-total-size x)))
67     (loop for i from 0 below size
68     always (equalp-with-case (row-major-aref x i)
69            (row-major-aref y i))))))
70   (t (eql x y))))
71
72
73(defmacro deftest (name form &rest values)
74  (format t "Test ~s~%" `,name)
75  (finish-output)
76  (let* ((aborted nil)
77        (r (handler-case (multiple-value-list
78                          (if *compile-tests*
79                              (funcall (compile nil `(lambda () ,form)))
80                              (eval `,form)))
81                         (error (c) (setf aborted t) (list c))))
82        (passed (and (not aborted) (equalp-with-case r `,values))))
83    (unless passed
84      (format t "  Expected value: ~s~%"
85              (if (= (length `,values) 1)
86                  (car `,values)
87                  `,values))
88      (format t "    Actual value: ~s~%"
89              (if (= (length r) 1)
90                  (car r)
91                  r))
92      (finish-output))
93    (if passed (incf *passed*) (incf *failed*))))
94
95(unless (find-package :cl-test)
96  (make-package :cl-test)
97  (use-package "COMMON-LISP" :cl-test))
98
99(in-package :cl-test)
100(use-package :rt)
101
102(defvar *compiled-and-loaded-files* nil)
103
104(defun compile-and-load (filename &key force)
105  (let* ((pathname (concatenate 'string rt::*prefix* filename))
106         (former-data (assoc pathname *compiled-and-loaded-files*
107           :test #'equal))
108   (source-write-time (file-write-date pathname)))
109    (unless (and (not force)
110     former-data
111     (>= (cadr former-data) source-write-time))
112      (if former-data
113    (setf (cadr former-data) source-write-time)
114          (push (list pathname source-write-time) *compiled-and-loaded-files*))
115      (load pathname))))
116
117(in-package :cl-user)
118
119(defun do-tests (&rest args)
120  (let ((rt::*passed* 0) (rt::*failed* 0)
121        (suffix ".lsp")
122        (tests (or args (list "acons"
123                              "adjoin"
124                              "and"
125                              "append"
126                              "apply"
127                              "aref"
128                              "array"
129                              "array-as-class"
130                              "array-dimension"
131                              "array-dimensions"
132                              "array-displacement"
133                              "array-in-bounds-p"
134                              "array-misc"
135                              "array-rank"
136                              "array-row-major-index"
137                              "array-t"
138                              "array-total-size"
139                              "arrayp"
140                              "assoc"
141                              "assoc-if"
142                              "assoc-if-not"
143                              "atom"
144                              "bit"
145                              "bit-vector"
146                              "bit-vector-p"
147                              "block"
148                              "boundp"
149                              "butlast"
150                              "call-arguments-limit"
151                              "case"
152                              "catch"
153                              "ccase"
154                              "char-compare"
155                              "char-schar"
156                              "character"
157                              "cl-symbols"
158                              "coerce"
159                              "complement"
160                              "concatenate"
161                              "cond"
162                              "cons"
163                              "cons-test-01"
164                              "cons-test-03"
165                              "cons-test-05"
166                              "consp"
167                              "constantly"
168                              "constantp"
169                              "copy-alist"
170                              "copy-list"
171                              "copy-seq"
172                              "copy-symbol"
173                              "copy-tree"
174                              "count"
175                              "count-if"
176                              "count-if-not"
177                              "ctypecase"
178                              "cxr"
179                              "defconstant"
180                              "defmacro"
181                              "defparameter"
182                              "defun"
183                              "defvar"
184                              "destructuring-bind"
185                              "ecase"
186                              "elt"
187                              "endp"
188                              "eql"
189                              "equal"
190                              "equalp"
191                              "error"
192                              "eval"
193                              "every"
194                              "fboundp"
195                              "fdefinition"
196                              "fill"
197                              "fill-pointer"
198                              "fill-strings"
199                              "find"
200                              "find-if"
201                              "find-if-not"
202                              "flet"
203                              "fmakunbound"
204                              "funcall"
205                              "function"
206                              "function-lambda-expression"
207                              "functionp"
208                              "gensym"
209                              "get-properties"
210                              "getf"
211                              "handler-bind"
212                              "handler-case"
213                              "hash-table"
214                              "identity"
215                              "if"
216                              "intersection"
217                              "iteration"
218                              "keywordp"
219                              "labels"
220                              "lambda"
221                              "lambda-list-keywords"
222                              "lambda-parameters-limit"
223                              "last"
224                              "ldiff"
225                              "length"
226                              "let"
227                              "list"
228                              "list-length"
229                              "listp"
230                              "loop"
231                              "loop1"
232                              "loop2"
233                              "loop3"
234                              "loop4"
235                              "loop5"
236                              "loop6"
237                              "loop7"
238                              "loop8"
239                              "loop9"
240                              "loop10"
241                              "loop11"
242                              "loop12"
243                              "loop13"
244                              "loop14"
245                              "loop15"
246                              "loop16"
247                              "loop17"
248                              "make-array"
249                              "make-list"
250                              "make-sequence"
251                              "make-string"
252                              "make-symbol"
253                              "map"
254                              "map-into"
255                              "mapc"
256                              "mapcan"
257                              "mapcar"
258                              "mapcon"
259                              "mapl"
260                              "maplist"
261                              "member"
262                              "member-if"
263                              "member-if-not"
264                              "merge"
265                              "mismatch"
266                              "multiple-value-bind"
267                              "multiple-value-call"
268                              "multiple-value-list"
269                              "multiple-value-prog1"
270                              "multiple-value-setq"
271                              "nbutlast"
272                              "nconc"
273                              "nil"
274                              "nintersection"
275                              "not-and-null"
276                              "notany"
277                              "notevery"
278                              "nreconc"
279                              "nreverse"
280                              "nset-difference"
281                              "nset-exclusive-or"
282                              "nstring-capitalize"
283                              "nstring-downcase"
284                              "nstring-upcase"
285                              "nsublis"
286                              "nsubst"
287                              "nsubst-if"
288                              "nsubst-if-not"
289                              "nsubstitute"
290                              "nsubstitute-if"
291                              "nsubstitute-if-not"
292                              "nth"
293                              "nth-value"
294                              "nthcdr"
295                              "number-comparison"
296                              "nunion"
297                              "or"
298                              "packages"
299                              "pairlis"
300                              "places"
301                              "pop"
302                              "position"
303                              "position-if"
304                              "position-if-not"
305                              "prog"
306                              "prog1"
307                              "prog2"
308                              "progn"
309                              "progv"
310                              "psetf"
311                              "psetq"
312                              "push"
313                              "push-new"
314                              "rassoc"
315                              "rassoc-if"
316                              "rassoc-if-not"
317                              "reduce"
318                              "remf"
319                              "remove"
320                              "remove-duplicates"
321                              "replace"
322                              "rest"
323                              "return"
324                              "revappend"
325                              "reverse"
326                              "rotatef"
327                              "row-major-aref"
328                              "rplaca"
329                              "rplacd"
330                              "sbit"
331                              "search-bitvector"
332                              "search-list"
333                              "search-string"
334                              "search-vector"
335                              "set-difference"
336                              "set-exclusive-or"
337                              "shiftf"
338                              "simple-array"
339                              "simple-array-t"
340                              "simple-bit-vector"
341                              "simple-bit-vector-p"
342                              "simple-vector-p"
343                              "some"
344                              "sort"
345                              "special-operator-p"
346                              "string"
347                              "string-capitalize"
348                              "string-comparisons"
349                              "string-downcase"
350                              "string-left-trim"
351                              "string-right-trim"
352                              "string-trim"
353                              "string-upcase"
354                              "sublis"
355                              "subseq"
356                              "subsetp"
357                              "subst"
358                              "subst-if"
359                              "subst-if-not"
360                              "substitute"
361                              "substitute-if"
362                              "substitute-if-not"
363                              "subtypep"
364                              "svref"
365                              "symbol-name"
366                              "t"
367                              "tagbody"
368                              "tailp"
369                              "tree-equal"
370                              "typecase"
371                              "union"
372                              "unless"
373                              "unwind-protect"
374                              "values"
375                              "values-list"
376                              "vector"
377                              "vector-pop"
378                              "vector-push"
379                              "vector-push-extend"
380                              "vectorp"
381                              "when"))))
382    (dolist (test tests)
383             (load (concatenate 'string rt::*prefix* test suffix)))
384    (format t "~A tests: ~A passed, ~A failed~%"
385            (+ rt::*passed* rt::*failed*)
386            rt::*passed*
387            rt::*failed*)
388    (format t "*compile-tests* was ~A~%" rt::*compile-tests*))
389  (values))
390
391(defun do-all-tests (&optional (compile-tests t))
392  (let ((rt::*compile-tests* compile-tests))
393    (time (do-tests))))
394
395(load (concatenate 'string rt::*prefix* "char-aux.lsp"))
396(load (concatenate 'string rt::*prefix* "cl-symbols-aux.lsp"))
397(load (concatenate 'string rt::*prefix* "cl-symbol-names.lsp"))
398(load (concatenate 'string rt::*prefix* "ansi-aux-macros.lsp"))
399(load (concatenate 'string rt::*prefix* "universe.lsp"))
400(load (concatenate 'string rt::*prefix* "ansi-aux.lsp"))
401(load (concatenate 'string rt::*prefix* "array-aux.lsp"))
402(load (concatenate 'string rt::*prefix* "subseq-aux.lsp"))
403(load (concatenate 'string rt::*prefix* "cons-aux.lsp"))
404(load (concatenate 'string rt::*prefix* "numbers-aux.lsp"))
405(load (concatenate 'string rt::*prefix* "string-aux.lsp"))
406
407(when (and (find-package "JVM")
408           (fboundp 'jvm::jvm-compile))
409  (mapcar #'jvm::jvm-compile '(rt::equalp-with-case
410                               cl-test::make-scaffold-copy
411                               cl-test::check-scaffold-copy
412                               cl-test::is-intersection)))
Note: See TracBrowser for help on using the repository browser.