;;; rt.lisp
;;;
;;; Copyright (C) 2003-2005 Peter Graves
;;; $Id: rt.lisp,v 1.166 2005/06/13 21:42:45 piso Exp $
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

;;; Adapted from rt.lsp and ansi-aux.lsp in the GCL ANSI test suite.

#+abcl (require '#:jvm)

(defpackage :regression-test (:use :cl) (:nicknames #-lispworks :rt))

(in-package :regression-test)

(export '(deftest my-aref))

(defvar *prefix*
  #-(or windows mswindows) "/home/peter/gcl/ansi-tests/"
  #+(or windows mswindows) "C:\\cygwin\\home\\peter\\gcl\\ansi-tests\\")

(defvar *compile-tests* t)

(defvar *passed* 0)
(defvar *failed* 0)

(defun my-aref (a &rest args)
  (apply #'aref a args))

(defun my-row-major-aref (a index)
  (row-major-aref a index))

(defun equalp-with-case (x y)
  (cond
   ((eq x y) t)
   ((consp x)
    (and (consp y)
	 (equalp-with-case (car x) (car y))
	 (equalp-with-case (cdr x) (cdr y))))
   ((and (typep x 'array)
	 (= (array-rank x) 0))
    (equalp-with-case (aref x) (aref y)))
   ((typep x 'vector)
    (and (typep y 'vector)
	 (let ((x-len (length x))
	       (y-len (length y)))
	   (and (eql x-len y-len)
		(loop
		 for e1 across x
		 for e2 across y
		 always (equalp-with-case e1 e2))))))
   ((and (typep x 'array)
	 (typep y 'array)
	 (not (equal (array-dimensions x)
		     (array-dimensions y))))
    nil)
   ((typep x 'array)
    (and (typep y 'array)
	 (let ((size (array-total-size x)))
	   (loop for i from 0 below size
		 always (equalp-with-case (row-major-aref x i)
					  (row-major-aref y i))))))
   ((typep x 'pathname)
    (equal x y))
   (t (eql x y))))

(defmacro deftest (name &rest body)
  (fresh-line)
  (format t "Test ~S~%" `,name)
  (finish-output)
  (let* ((p body)
	 (properties
	  (loop while (keywordp (first p))
            unless (cadr p)
            do (error "Poorly formed deftest: ~S~%"
                      (list* 'deftest name body))
            append (list (pop p) (pop p))))
	 (form (pop p))
	 (values p))
    (declare (ignore properties))
    (let* ((aborted nil)
           (r (handler-case (multiple-value-list
                             (cond (*compile-tests*
                                    (funcall (compile nil `(lambda () ,form))))
                                   (t
                                    (eval `,form))))
                            (error (c) (setf aborted t) (list c))))
           (passed (and (not aborted) (equalp-with-case r `,values))))
      (unless passed
        (let ((*print-pretty* t))
          (format t "Form: ~S~%" `,form)
          (format t "Expected value: ~S~%"
                  (if (= (length `,values) 1)
                      (car `,values)
                      `,values))
          (let ((r (if (= (length r) 1) (car r) r)))
            (format t "Actual value: ~S" r)
            (when (typep r 'condition)
              (format t " [\"~A\"]" r))
            (terpri))
          (finish-output)))
      (if passed (incf *passed*) (incf *failed*)))))

(in-package :cl-user)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (intern "==>" "CL-USER"))

(defvar *compiled-and-loaded-files* nil)

(defun compile-and-load (filename &key force)
  (let* ((pathname (concatenate 'string regression-test::*prefix* filename))
         (former-data (assoc pathname *compiled-and-loaded-files*
			     :test #'equalp))
	 (compile-pathname (compile-file-pathname pathname))
	 (source-write-time (file-write-date pathname))
         (target-write-time (and (probe-file compile-pathname)
                                 (file-write-date compile-pathname))))
    (unless (and (not force)
		 former-data
		 (>= (cadr former-data) source-write-time))
      (when (or (not target-write-time)
		(<= target-write-time source-write-time))
	(compile-file pathname))
      (if former-data
	  (setf (cadr former-data) source-write-time)
          (push (list pathname source-write-time) *compiled-and-loaded-files*))
      (load compile-pathname))))

(defpackage :cl-test
  (:use :cl :regression-test)
  (:nicknames)
  (:shadow #:handler-case #:handler-bind)
  (:import-from "COMMON-LISP-USER" #:compile-and-load "==>")
  (:export #:random-from-seq #:random-case #:coin #:random-permute))

(defun do-tests (&rest args)
  (let ((*compile-print* nil)
        (regression-test::*passed* 0)
        (regression-test::*failed* 0)
        (*default-pathname-defaults* (pathname regression-test::*prefix*))
        (suffix ".lsp")
        (tests (or args '("abs"
                          "acons"
                          "adjoin"
                          "and"
                          "append"
                          "apply"
                          "aref"
                          "array"
                          "array-as-class"
                          "array-dimension"
                          "array-dimensions"
                          "array-displacement"
                          "array-in-bounds-p"
                          "array-misc"
                          "array-rank"
                          "array-row-major-index"
                          "array-t"
                          "array-total-size"
                          "arrayp"
                          "ash"
                          "assoc"
                          "assoc-if"
                          "assoc-if-not"
                          "atom"
                          "bit"
                          "bit-and"
                          "bit-andc1"
                          "bit-andc2"
                          "bit-eqv"
                          "bit-ior"
                          "bit-nand"
                          "bit-nor"
                          "bit-not"
                          "bit-orc1"
                          "bit-orc2"
                          "bit-vector"
                          "bit-vector-p"
                          "bit-xor"
                          "block"
                          "boole"
                          "boundp"
                          "butlast"
                          "byte"
                          "call-arguments-limit"
                          "case"
                          "catch"
                          "ccase"
                          "ceiling"
                          "cell-error-name"
                          "char-compare"
                          "char-schar"
                          "character"
                          "cl-symbols"
                          "coerce"
                          "complement"
                          "complex"
                          "complexp"
                          "concatenate"
                          "cond"
                          "condition"
                          "conjugate"
                          "cons"
                          "cons-test-01"
                          "cons-test-03"
                          "cons-test-05"
                          "consp"
                          "constantly"
                          "constantp"
                          "copy-alist"
                          "copy-list"
                          "copy-seq"
                          "copy-symbol"
                          "copy-tree"
                          "count"
                          "count-if"
                          "count-if-not"
                          "ctypecase"
                          "cxr"
                          "defconstant"
                          "define-modify-macro"
                          "defmacro"
                          "defparameter"
                          "defun"
                          "defvar"
                          "destructuring-bind"
                          "divide"
                          "dpb"
                          "ecase"
                          "elt"
                          "endp"
                          "epsilons"
                          "eql"
                          "equal"
                          "equalp"
                          "error"
                          "etypecase"
                          "eval"
                          "evenp"
                          "every"
                          "expt"
                          "fboundp"
                          "fceiling"
                          "fdefinition"
                          "ffloor"
                          "fill"
                          "fill-pointer"
                          "fill-strings"
                          "find"
                          "find-if"
                          "find-if-not"
                          "flet"
                          "float"
                          "floatp"
                          "floor"
                          "fmakunbound"
                          "fround"
                          "ftruncate"
                          "funcall"
                          "function"
                          "function-lambda-expression"
                          "functionp"
                          "gcd"
                          "gensym"
                          "get-properties"
                          "getf"
                          "handler-bind"
                          "handler-case"
                          "hash-table"
                          "identity"
                          "if"
                          "ignore-errors"
                          "imagpart"
                          "integer-length"
                          "integerp"
                          "intersection"
                          "invoke-debugger"
                          "isqrt"
                          "iteration"
                          "keywordp"
                          "labels"
                          "lambda"
                          "lambda-list-keywords"
                          "lambda-parameters-limit"
                          "last"
                          "lcm"
                          "ldb"
                          "ldiff"
                          "length"
                          "let"
                          "list"
                          "list-length"
                          "listp"
                          "load-structures"
                          "logand"
                          "logandc1"
                          "logandc2"
                          "logbitp"
                          "logeqv"
                          "logior"
                          "lognor"
                          "lognot"
                          "logorc1"
                          "logorc2"
                          "logxor"
                          "loop"
                          "loop1"
                          "loop2"
                          "loop3"
                          "loop4"
                          "loop5"
                          "loop6"
                          "loop7"
                          "loop8"
                          "loop9"
                          "loop10"
                          "loop11"
                          "loop12"
                          "loop13"
                          "loop14"
                          "loop15"
                          "loop16"
                          "loop17"
                          "make-array"
                          "make-list"
                          "make-sequence"
                          "make-string"
                          "make-symbol"
                          "map"
                          "map-into"
                          "mapc"
                          "mapcan"
                          "mapcar"
                          "mapcon"
                          "mapl"
                          "maplist"
                          "max"
                          "member"
                          "member-if"
                          "member-if-not"
                          "merge"
                          "min"
                          "minus"
                          "minusp"
                          "mismatch"
                          "multiple-value-bind"
                          "multiple-value-call"
                          "multiple-value-list"
                          "multiple-value-prog1"
                          "multiple-value-setq"
                          "nbutlast"
                          "nconc"
                          "nil"
                          "nintersection"
                          "not-and-null"
                          "notany"
                          "notevery"
                          "nreconc"
                          "nreverse"
                          "nset-difference"
                          "nset-exclusive-or"
                          "nstring-capitalize"
                          "nstring-downcase"
                          "nstring-upcase"
                          "nsublis"
                          "nsubst"
                          "nsubst-if"
                          "nsubst-if-not"
                          "nsubstitute"
                          "nsubstitute-if"
                          "nsubstitute-if-not"
                          "nth"
                          "nth-value"
                          "nthcdr"
                          "number-comparison"
                          "numerator-denominator"
                          "nunion"
                          "oddp"
                          "oneminus"
                          "oneplus"
                          "or"
                          "load-packages"
                          "pairlis"
                          "parse-integer"
                          "phase"
                          "places"
                          "plus"
                          "plusp"
                          "pop"
                          "position"
                          "position-if"
                          "position-if-not"
                          "prog"
                          "prog1"
                          "prog2"
                          "progn"
                          "progv"
                          "psetf"
                          "psetq"
                          "push"
                          "pushnew"
                          "random"
                          "rassoc"
                          "rassoc-if"
                          "rassoc-if-not"
                          "rational"
                          "rationalize"
                          "rationalp"
                          "realp"
                          "realpart"
                          "reduce"
                          "remf"
                          "remove"
                          "remove-duplicates"
                          "replace"
                          "rest"
                          "return"
                          "revappend"
                          "reverse"
                          "rotatef"
                          "round"
                          "row-major-aref"
                          "rplaca"
                          "rplacd"
                          "sbit"
                          "search-bitvector"
                          "search-list"
                          "search-string"
                          "search-vector"
                          "set-difference"
                          "set-exclusive-or"
                          "shiftf"
                          "signum"
                          "simple-array"
                          "simple-array-t"
                          "simple-bit-vector"
                          "simple-bit-vector-p"
                          "simple-vector-p"
                          "some"
                          "sort"
                          "special-operator-p"
                          "string"
                          "string-capitalize"
                          "string-comparisons"
                          "string-downcase"
                          "string-left-trim"
                          "string-right-trim"
                          "string-trim"
                          "string-upcase"
                          "sublis"
                          "subseq"
                          "subsetp"
                          "subst"
                          "subst-if"
                          "subst-if-not"
                          "substitute"
                          "substitute-if"
                          "substitute-if-not"
                          "subtypep"
                          "subtypep-cons"
                          "subtypep-eql"
                          "subtypep-float"
                          "subtypep-integer"
                          "subtypep-member"
                          "subtypep-rational"
                          "subtypep-real"
                          "svref"
                          "symbol-name"
                          "t"
                          "tagbody"
                          "tailp"
                          "times"
                          "tree-equal"
                          "truncate"
                          "typecase"
                          "union"
                          "unless"
                          "unwind-protect"
                          "values"
                          "values-list"
                          "vector"
                          "vector-pop"
                          "vector-push"
                          "vector-push-extend"
                          "vectorp"
                          "when"
                          "zerop"))))
    (dolist (test tests)
      (load (concatenate 'string regression-test::*prefix* test suffix)))
    (format t "~A tests: ~A passed, ~A failed~%"
            (+ regression-test::*passed* regression-test::*failed*)
            regression-test::*passed*
            regression-test::*failed*)
    (format t "*compile-tests* was ~A~%" regression-test::*compile-tests*))
  (values))

(defun do-all-tests (&optional (compile-tests t))
  (let ((regression-test::*compile-tests* compile-tests))
    (time (do-tests))))

(compile-and-load "ansi-aux-macros.lsp")
(load (concatenate 'string regression-test::*prefix* "universe.lsp"))
(compile-and-load "random-aux.lsp")
(compile-and-load "ansi-aux.lsp")

(compile-and-load "char-aux.lsp")
(load (concatenate 'string regression-test::*prefix* "cl-symbols-aux.lsp"))
(load (concatenate 'string regression-test::*prefix* "cl-symbol-names.lsp"))
(load (concatenate 'string regression-test::*prefix* "array-aux.lsp"))
(load (concatenate 'string regression-test::*prefix* "subseq-aux.lsp"))
(load (concatenate 'string regression-test::*prefix* "cons-aux.lsp"))
(load (concatenate 'string regression-test::*prefix* "numbers-aux.lsp"))
(load (concatenate 'string regression-test::*prefix* "string-aux.lsp"))
(load (concatenate 'string regression-test::*prefix* "remove-aux.lsp"))
(load (concatenate 'string regression-test::*prefix* "remove-duplicates-aux.lsp"))

#+armedbear
(when (and (fboundp 'jvm::jvm-compile) (not (autoloadp 'jvm::jvm-compile)))
  (mapcar #'jvm::jvm-compile '(regression-test::equalp-with-case
                               cl-test::make-scaffold-copy
                               cl-test::check-scaffold-copy
                               cl-test::is-intersection)))
