| 1 | ;;; rt.lisp |
|---|
| 2 | ;;; |
|---|
| 3 | ;;; Copyright (C) 2003 Peter Graves |
|---|
| 4 | ;;; $Id: rt.lisp,v 1.107 2003-09-02 16:16:55 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 | (unless (find-package :cl-test) |
|---|
| 107 | (make-package :cl-test) |
|---|
| 108 | (use-package "COMMON-LISP" :cl-test)) |
|---|
| 109 | |
|---|
| 110 | (in-package :cl-test) |
|---|
| 111 | (use-package :rt) |
|---|
| 112 | |
|---|
| 113 | (defvar *compiled-and-loaded-files* nil) |
|---|
| 114 | |
|---|
| 115 | (defun compile-and-load (filename &key force) |
|---|
| 116 | (let* ((pathname (concatenate 'string rt::*prefix* filename)) |
|---|
| 117 | (former-data (assoc pathname *compiled-and-loaded-files* |
|---|
| 118 | :test #'equal)) |
|---|
| 119 | (source-write-time (file-write-date pathname))) |
|---|
| 120 | (unless (and (not force) |
|---|
| 121 | former-data |
|---|
| 122 | (>= (cadr former-data) source-write-time)) |
|---|
| 123 | (if former-data |
|---|
| 124 | (setf (cadr former-data) source-write-time) |
|---|
| 125 | (push (list pathname source-write-time) *compiled-and-loaded-files*)) |
|---|
| 126 | (load pathname)))) |
|---|
| 127 | |
|---|
| 128 | (in-package :cl-user) |
|---|
| 129 | |
|---|
| 130 | (defun do-tests (&rest args) |
|---|
| 131 | (let ((rt::*passed* 0) (rt::*failed* 0) |
|---|
| 132 | (suffix ".lsp") |
|---|
| 133 | (tests (or args (list "acons" |
|---|
| 134 | "adjoin" |
|---|
| 135 | "and" |
|---|
| 136 | "append" |
|---|
| 137 | "apply" |
|---|
| 138 | "aref" |
|---|
| 139 | "array" |
|---|
| 140 | "array-as-class" |
|---|
| 141 | "array-dimension" |
|---|
| 142 | "array-dimensions" |
|---|
| 143 | "array-displacement" |
|---|
| 144 | "array-in-bounds-p" |
|---|
| 145 | "array-misc" |
|---|
| 146 | "array-rank" |
|---|
| 147 | "array-row-major-index" |
|---|
| 148 | "array-t" |
|---|
| 149 | "array-total-size" |
|---|
| 150 | "arrayp" |
|---|
| 151 | "assoc" |
|---|
| 152 | "assoc-if" |
|---|
| 153 | "assoc-if-not" |
|---|
| 154 | "atom" |
|---|
| 155 | "bit" |
|---|
| 156 | "bit-vector" |
|---|
| 157 | "bit-vector-p" |
|---|
| 158 | "block" |
|---|
| 159 | "boundp" |
|---|
| 160 | "butlast" |
|---|
| 161 | "call-arguments-limit" |
|---|
| 162 | "case" |
|---|
| 163 | "catch" |
|---|
| 164 | "ccase" |
|---|
| 165 | "ceiling" |
|---|
| 166 | "char-compare" |
|---|
| 167 | "char-schar" |
|---|
| 168 | "character" |
|---|
| 169 | "cl-symbols" |
|---|
| 170 | "coerce" |
|---|
| 171 | "complement" |
|---|
| 172 | "concatenate" |
|---|
| 173 | "cond" |
|---|
| 174 | "cons" |
|---|
| 175 | "cons-test-01" |
|---|
| 176 | "cons-test-03" |
|---|
| 177 | "cons-test-05" |
|---|
| 178 | "consp" |
|---|
| 179 | "constantly" |
|---|
| 180 | "constantp" |
|---|
| 181 | "copy-alist" |
|---|
| 182 | "copy-list" |
|---|
| 183 | "copy-seq" |
|---|
| 184 | "copy-symbol" |
|---|
| 185 | "copy-tree" |
|---|
| 186 | "count" |
|---|
| 187 | "count-if" |
|---|
| 188 | "count-if-not" |
|---|
| 189 | "ctypecase" |
|---|
| 190 | "cxr" |
|---|
| 191 | "defconstant" |
|---|
| 192 | "defmacro" |
|---|
| 193 | "defparameter" |
|---|
| 194 | "defun" |
|---|
| 195 | "defvar" |
|---|
| 196 | "destructuring-bind" |
|---|
| 197 | "ecase" |
|---|
| 198 | "elt" |
|---|
| 199 | "endp" |
|---|
| 200 | "eql" |
|---|
| 201 | "equal" |
|---|
| 202 | "equalp" |
|---|
| 203 | "error" |
|---|
| 204 | "etypecase" |
|---|
| 205 | "eval" |
|---|
| 206 | "evenp" |
|---|
| 207 | "every" |
|---|
| 208 | "fboundp" |
|---|
| 209 | "fceiling" |
|---|
| 210 | "fdefinition" |
|---|
| 211 | "ffloor" |
|---|
| 212 | "fill" |
|---|
| 213 | "fill-pointer" |
|---|
| 214 | "fill-strings" |
|---|
| 215 | "find" |
|---|
| 216 | "find-if" |
|---|
| 217 | "find-if-not" |
|---|
| 218 | "flet" |
|---|
| 219 | "floor" |
|---|
| 220 | "fmakunbound" |
|---|
| 221 | "fround" |
|---|
| 222 | "ftruncate" |
|---|
| 223 | "funcall" |
|---|
| 224 | "function" |
|---|
| 225 | "function-lambda-expression" |
|---|
| 226 | "functionp" |
|---|
| 227 | "gensym" |
|---|
| 228 | "get-properties" |
|---|
| 229 | "getf" |
|---|
| 230 | "handler-bind" |
|---|
| 231 | "handler-case" |
|---|
| 232 | "hash-table" |
|---|
| 233 | "identity" |
|---|
| 234 | "if" |
|---|
| 235 | "intersection" |
|---|
| 236 | "iteration" |
|---|
| 237 | "keywordp" |
|---|
| 238 | "labels" |
|---|
| 239 | "lambda" |
|---|
| 240 | "lambda-list-keywords" |
|---|
| 241 | "lambda-parameters-limit" |
|---|
| 242 | "last" |
|---|
| 243 | "ldiff" |
|---|
| 244 | "length" |
|---|
| 245 | "let" |
|---|
| 246 | "list" |
|---|
| 247 | "list-length" |
|---|
| 248 | "listp" |
|---|
| 249 | "loop" |
|---|
| 250 | "loop1" |
|---|
| 251 | "loop2" |
|---|
| 252 | "loop3" |
|---|
| 253 | "loop4" |
|---|
| 254 | "loop5" |
|---|
| 255 | "loop6" |
|---|
| 256 | "loop7" |
|---|
| 257 | "loop8" |
|---|
| 258 | "loop9" |
|---|
| 259 | "loop10" |
|---|
| 260 | "loop11" |
|---|
| 261 | "loop12" |
|---|
| 262 | "loop13" |
|---|
| 263 | "loop14" |
|---|
| 264 | "loop15" |
|---|
| 265 | "loop16" |
|---|
| 266 | "loop17" |
|---|
| 267 | "make-array" |
|---|
| 268 | "make-list" |
|---|
| 269 | "make-sequence" |
|---|
| 270 | "make-string" |
|---|
| 271 | "make-symbol" |
|---|
| 272 | "map" |
|---|
| 273 | "map-into" |
|---|
| 274 | "mapc" |
|---|
| 275 | "mapcan" |
|---|
| 276 | "mapcar" |
|---|
| 277 | "mapcon" |
|---|
| 278 | "mapl" |
|---|
| 279 | "maplist" |
|---|
| 280 | "member" |
|---|
| 281 | "member-if" |
|---|
| 282 | "member-if-not" |
|---|
| 283 | "merge" |
|---|
| 284 | "mismatch" |
|---|
| 285 | "multiple-value-bind" |
|---|
| 286 | "multiple-value-call" |
|---|
| 287 | "multiple-value-list" |
|---|
| 288 | "multiple-value-prog1" |
|---|
| 289 | "multiple-value-setq" |
|---|
| 290 | "nbutlast" |
|---|
| 291 | "nconc" |
|---|
| 292 | "nil" |
|---|
| 293 | "nintersection" |
|---|
| 294 | "not-and-null" |
|---|
| 295 | "notany" |
|---|
| 296 | "notevery" |
|---|
| 297 | "nreconc" |
|---|
| 298 | "nreverse" |
|---|
| 299 | "nset-difference" |
|---|
| 300 | "nset-exclusive-or" |
|---|
| 301 | "nstring-capitalize" |
|---|
| 302 | "nstring-downcase" |
|---|
| 303 | "nstring-upcase" |
|---|
| 304 | "nsublis" |
|---|
| 305 | "nsubst" |
|---|
| 306 | "nsubst-if" |
|---|
| 307 | "nsubst-if-not" |
|---|
| 308 | "nsubstitute" |
|---|
| 309 | "nsubstitute-if" |
|---|
| 310 | "nsubstitute-if-not" |
|---|
| 311 | "nth" |
|---|
| 312 | "nth-value" |
|---|
| 313 | "nthcdr" |
|---|
| 314 | "number-comparison" |
|---|
| 315 | "nunion" |
|---|
| 316 | "oddp" |
|---|
| 317 | "or" |
|---|
| 318 | "packages" |
|---|
| 319 | "pairlis" |
|---|
| 320 | "places" |
|---|
| 321 | "pop" |
|---|
| 322 | "position" |
|---|
| 323 | "position-if" |
|---|
| 324 | "position-if-not" |
|---|
| 325 | "prog" |
|---|
| 326 | "prog1" |
|---|
| 327 | "prog2" |
|---|
| 328 | "progn" |
|---|
| 329 | "progv" |
|---|
| 330 | "psetf" |
|---|
| 331 | "psetq" |
|---|
| 332 | "push" |
|---|
| 333 | "pushnew" |
|---|
| 334 | "rassoc" |
|---|
| 335 | "rassoc-if" |
|---|
| 336 | "rassoc-if-not" |
|---|
| 337 | "reduce" |
|---|
| 338 | "remf" |
|---|
| 339 | "remove" |
|---|
| 340 | "remove-duplicates" |
|---|
| 341 | "replace" |
|---|
| 342 | "rest" |
|---|
| 343 | "return" |
|---|
| 344 | "revappend" |
|---|
| 345 | "reverse" |
|---|
| 346 | "rotatef" |
|---|
| 347 | "round" |
|---|
| 348 | "row-major-aref" |
|---|
| 349 | "rplaca" |
|---|
| 350 | "rplacd" |
|---|
| 351 | "sbit" |
|---|
| 352 | "search-bitvector" |
|---|
| 353 | "search-list" |
|---|
| 354 | "search-string" |
|---|
| 355 | "search-vector" |
|---|
| 356 | "set-difference" |
|---|
| 357 | "set-exclusive-or" |
|---|
| 358 | "shiftf" |
|---|
| 359 | "simple-array" |
|---|
| 360 | "simple-array-t" |
|---|
| 361 | "simple-bit-vector" |
|---|
| 362 | "simple-bit-vector-p" |
|---|
| 363 | "simple-vector-p" |
|---|
| 364 | "some" |
|---|
| 365 | "sort" |
|---|
| 366 | "special-operator-p" |
|---|
| 367 | "string" |
|---|
| 368 | "string-capitalize" |
|---|
| 369 | "string-comparisons" |
|---|
| 370 | "string-downcase" |
|---|
| 371 | "string-left-trim" |
|---|
| 372 | "string-right-trim" |
|---|
| 373 | "string-trim" |
|---|
| 374 | "string-upcase" |
|---|
| 375 | "sublis" |
|---|
| 376 | "subseq" |
|---|
| 377 | "subsetp" |
|---|
| 378 | "subst" |
|---|
| 379 | "subst-if" |
|---|
| 380 | "subst-if-not" |
|---|
| 381 | "substitute" |
|---|
| 382 | "substitute-if" |
|---|
| 383 | "substitute-if-not" |
|---|
| 384 | "subtypep" |
|---|
| 385 | "svref" |
|---|
| 386 | "symbol-name" |
|---|
| 387 | "t" |
|---|
| 388 | "tagbody" |
|---|
| 389 | "tailp" |
|---|
| 390 | "tree-equal" |
|---|
| 391 | "truncate" |
|---|
| 392 | "typecase" |
|---|
| 393 | "union" |
|---|
| 394 | "unless" |
|---|
| 395 | "unwind-protect" |
|---|
| 396 | "values" |
|---|
| 397 | "values-list" |
|---|
| 398 | "vector" |
|---|
| 399 | "vector-pop" |
|---|
| 400 | "vector-push" |
|---|
| 401 | "vector-push-extend" |
|---|
| 402 | "vectorp" |
|---|
| 403 | "when" |
|---|
| 404 | "zerop")))) |
|---|
| 405 | (dolist (test tests) |
|---|
| 406 | (load (concatenate 'string rt::*prefix* test suffix))) |
|---|
| 407 | (format t "~A tests: ~A passed, ~A failed~%" |
|---|
| 408 | (+ rt::*passed* rt::*failed*) |
|---|
| 409 | rt::*passed* |
|---|
| 410 | rt::*failed*) |
|---|
| 411 | (format t "*compile-tests* was ~A~%" rt::*compile-tests*)) |
|---|
| 412 | (values)) |
|---|
| 413 | |
|---|
| 414 | (defun do-all-tests (&optional (compile-tests t)) |
|---|
| 415 | (let ((rt::*compile-tests* compile-tests)) |
|---|
| 416 | (time (do-tests)))) |
|---|
| 417 | |
|---|
| 418 | #+armedbear |
|---|
| 419 | (when (and (find-package "JVM") |
|---|
| 420 | (fboundp 'jvm::jvm-compile)) |
|---|
| 421 | (mapcar #'jvm::jvm-compile '(sys::list-remove-duplicates* |
|---|
| 422 | sys::vector-remove-duplicates* |
|---|
| 423 | remove-duplicates |
|---|
| 424 | union |
|---|
| 425 | nunion |
|---|
| 426 | intersection |
|---|
| 427 | nintersection |
|---|
| 428 | subsetp |
|---|
| 429 | copy-tree))) |
|---|
| 430 | |
|---|
| 431 | (load (concatenate 'string rt::*prefix* "char-aux.lsp")) |
|---|
| 432 | (load (concatenate 'string rt::*prefix* "cl-symbols-aux.lsp")) |
|---|
| 433 | (load (concatenate 'string rt::*prefix* "cl-symbol-names.lsp")) |
|---|
| 434 | (load (concatenate 'string rt::*prefix* "ansi-aux-macros.lsp")) |
|---|
| 435 | (load (concatenate 'string rt::*prefix* "universe.lsp")) |
|---|
| 436 | (load (concatenate 'string rt::*prefix* "ansi-aux.lsp")) |
|---|
| 437 | (load (concatenate 'string rt::*prefix* "array-aux.lsp")) |
|---|
| 438 | (load (concatenate 'string rt::*prefix* "subseq-aux.lsp")) |
|---|
| 439 | (load (concatenate 'string rt::*prefix* "cons-aux.lsp")) |
|---|
| 440 | (load (concatenate 'string rt::*prefix* "numbers-aux.lsp")) |
|---|
| 441 | (load (concatenate 'string rt::*prefix* "string-aux.lsp")) |
|---|
| 442 | |
|---|
| 443 | #+armedbear |
|---|
| 444 | (when (and (find-package "JVM") |
|---|
| 445 | (fboundp 'jvm::jvm-compile)) |
|---|
| 446 | (mapcar #'jvm::jvm-compile '(rt::equalp-with-case |
|---|
| 447 | cl-test::make-scaffold-copy |
|---|
| 448 | cl-test::check-scaffold-copy |
|---|
| 449 | cl-test::is-intersection))) |
|---|
