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

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

load-structures

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