;;;-*- Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987 Xerox Corporation.  All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted.  Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;; 
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;; 
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;;   CommonLoops Coordinator
;;;   Xerox Artifical Intelligence Systems
;;;   2400 Hanover St.
;;;   Palo Alto, CA 94303
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;; 
;;; Testing code.
;;;

(in-package 'pcl)

;;; Because CommonLoops runs in itself so much, the notion of a test file for
;;; it is kind of weird.
;;;
;;; If all of PCL loads then many of the tests in this file (particularly
;;; those at the beginning) are sure to work.  Those tests exists primarily
;;; to help debug things when low-level changes are made to PCL, or when a
;;; particular port customizes low-level code.
;;;
;;; Some of the other tests are "real" in the sense that they test things
;;; that PCL itself does not use, so might be broken.
;;; 
;;; NOTE:
;;;   The tests in this file do not appear in random order!  They
;;;   depend on state  which has already been set up in order to run.
;;;

(defmacro do-test (name cleanups &body body)
  `(let ((do-test-failed nil))
     (catch 'do-test
       (format t "~&Testing ~A..." ,name)
       (cleanup-do-test ',cleanups)
       (block do-test ,@body)
       (if do-test-failed
	   (format t "~&FAILED!")
	   (format t "OK")))))
  
(defmacro do-test-error (fatal string &rest args)
  `(progn (terpri)
	  (setq do-test-failed t)
	  (format t ,string ,@args)
	  (when ,fatal (return-from do-test nil))))

(defun cleanup-do-test (cleanups)
  (dolist (cleanup cleanups)
    (ecase (car cleanup)
      (:classes
	(dolist (c (cdr cleanup))
	  (let ((class (class-named c 't)))
	    (when class
	      (dolist (super (class-local-supers class))
		(setf (class-direct-subclasses super)
		      (remove class (class-direct-subclasses super))))
	      (setf (class-named c) nil)))))
      (:functions
	(dolist (f (cdr cleanup))
	  (fmakunbound f)))
      (:setf-generic-functions
	(dolist (f (cdr cleanup))
	  (fmakunbound (get-setf-generic-function-name f)))))))

  ;;   
;;;;;; 
  ;;   

(do-test "Memory Block Primitives"
	 ()
  (let ((block (make-memory-block 10))
        (tests (iterate ((i from 0 below 10)) (collect (make-list 1)))))
    (and (numberp (memory-block-size block))
         (= (memory-block-size block) 10)
         (progn (iterate ((i from 0) (test in tests))
                  (setf (memory-block-ref block i) test))
                (iterate ((i from 0) (test in tests))
                  (unless (eq (memory-block-ref block i) test)
		    (do-test-error nil "failed at position ~D" i)))))))

(do-test "Class Wrapper Caching"
	 ()
  (let* ((wrapper (make-class-wrapper 'test))
         (offset (class-wrapper-slot-value-offset wrapper 'foo))
         (value (list ())))
    
    (or (eq 'foo  (setf (class-wrapper-cached-key wrapper offset) 'foo))
	(do-test-error t "setting key didn't return key"))
    (or (eq value (setf (class-wrapper-cached-val wrapper offset) value))
	(do-test-error t "setting value didn't return value"))
    (or (eq 'foo  (class-wrapper-cached-key wrapper offset))
	(do-test-error t "didn't get key back"))
    (or (eq value (class-wrapper-cached-val wrapper offset))
	(do-test-error t "didn't get value-back"))))

(do-test "Flushing Class-Wrapper caches"
	 ()
  (let* ((wrapper (make-class-wrapper 'test))
         (offset (class-wrapper-slot-value-offset wrapper 'foo)))
    (setf (class-wrapper-cached-key wrapper offset) 'foo)
    (flush-class-wrapper-cache wrapper)
    (or (neq 'foo  (class-wrapper-cached-key wrapper offset))
	(do-test-error t "didn't clear value"))))


(do-test "Class Wrapper Caching"
	 ()
  (let ((slots ())
	(wrapper (make-class-wrapper 'test))
	(hits 0)
	(misses 0)
	(offset nil))
    (iterate ((class in '(class standard-slotd generic-function method)))
      (setq class (class-named 'class))
      (dolist (slotd (class-instance-slots class))
	(setq offset (class-wrapper-slot-value-offset nil (slotd-name slotd)))
	(setf (class-wrapper-cached-key wrapper offset) slotd))
      (dolist (slotd (class-instance-slots class))
	(setq offset (class-wrapper-slot-value-offset nil (slotd-name slotd)))
	(if (eq (class-wrapper-cached-key wrapper offset) slotd)
	    (incf hits)
	    (incf misses))))
    (format t
	    " (~D% hit) "
	    (round (* 100.0 (/ hits (float (+ hits misses))))))))


(do-test "types for early classes"
	 ()
  (dolist (x '(object class standard-slotd))
    (or (typep (make-instance x) x)
	(do-test-error () "instance of ~S not of type ~S??" x x))))

; doesn't win because generic-function are really typep compiled functions
; so the deftype for them doesn't really have any effect.
;
;(do-test "types for late classes"
;	 ()
;  (dolist (x '(method generic-function standard-generic-function))
;    (or (typep (make-instance x) x)
;	(do-test-error () "~&instance of ~S not of type ~S??" x x))))

(defvar *built-in-class-tests*
	'((ARRAY (MAKE-ARRAY '(10 10)))
	  (BIT-VECTOR (MAKE-ARRAY 10 :ELEMENT-TYPE 'BIT))
	  (CHARACTER #\a)
	  (COMPLEX #C(1 2))
	  (CONS (LIST 1 2 3))
	  (FLOAT 1.3)
	  (INTEGER 1)
	 ;LIST                   abstract super of cons, null
	  (NULL NIL)
	 ;NUMBER                 abstract super of complex, float, rational
	  (RATIO 1/2)
	 ;RATIONAL               abstract super of ratio, integer
	 ;SEQUENCE               abstract super of list, vector
	  (STRING "foo")
	  (SYMBOL 'FOO)
	  (VECTOR (VECTOR 1 2 3))))

(do-test "built-in-class-of"
	 ()
  (let ((lostp nil))
    (dolist (tst *built-in-class-tests*)
      (unless (eq (class-named (car tst))
		  (class-of (eval (cadr tst))))
	(do-test-error ()
		       "~&class-of ~S was ~A not ~A~%"
		       (cadr tst)
		       (class-name (class-of (eval (cadr tst))))
		       (car tst))
	(setq lostp t)))
    (not lostp)))

(do-test "existence of generic-functions for accessors of early classes"
	 ()
  ;; Because accessors are done with add-method, and this has to be done
  ;; specially for early classes it is worth testing to make sure that
  ;; the generic-functions got created for the accessor of early classes.
  ;;
  ;; Of course PCL wouldn't have loaded if most of these didn't exist,
  ;; but what the hell.
  (dolist (class '(essential-class class
		   generic-function standard-generic-function
		   method
		   standard-slotd))
    (dolist (slotd (class-slots (class-named class)))
      (dolist (acc (slotd-accessors slotd))
	(unless (and (fboundp acc)
		     (generic-function-p (symbol-function acc)))
	  (do-test-error () "~S isn't a generic function" acc))
	(setq acc (get-setf-generic-function-name acc))
	(unless (and (fboundp acc)
		     (generic-function-p (symbol-function acc)))
	  (do-test-error () "~S isn't a generic function" acc)))
      (dolist (rea (slotd-readers slotd))
	(unless (and (fboundp rea)
		     (generic-function-p (symbol-function rea)))
	  (do-test-error () "~S isn't a generic function" rea))))))

(do-test "early reader/writer methods are appropriate class"
	 ()
  ;; Because accessors are done with add-method, and this has to be done
  ;; specially for early classes it is worth testing to make sure that
  ;; the generic-functions got created for the accessor of early classes.
  ;;
  ;; Of course PCL wouldn't have loaded if most of these didn't exist,
  ;; but what the hell.
  (dolist (class '(essential-class class
		   generic-function standard-generic-function
		   method
		   standard-slotd))
    (let ((class (class-named 'class)))
      (flet ((check-reader (gf)
	       (let ((reader (get-method (symbol-function gf)
					 ()
					 (list class))))
		 (unless (typep reader 'standard-reader-method)
		   (do-test-error () "~S isn't a READER method" reader))))
	     (check-writer (gf)
	       (let ((writer (get-method (get-setf-generic-function gf)
					 ()
					 (list t class))))
		 (unless (typep writer 'standard-writer-method)
		   (do-test-error () "~S isn't a WRITER method" writer)))))
	(dolist (slotd (class-local-slots class))
	  (dolist (acc (slotd-accessors slotd))
	    (check-reader acc)
	    (check-writer acc))	  
	  (dolist (rea (slotd-readers slotd))
	    (check-reader rea)))))))

(do-test "typep works for standard-classes"
	 ((:classes foo1 foo2 bar))

  (defclass foo1 () ())
  (defclass foo2 (foo1) ())
  (defclass bar () ())

  (let ((f1 (make-instance 'foo1))
	(f2 (make-instance 'foo2)))
    (or (typep f1 'foo1)
	(do-test-error
	  () "an instance of foo1 isn't subtypep of foo1"))
    (or (not (typep f1 'foo2))
	(do-test-error
	  () "an instance of foo1 is suptypep of a subclass of foo1"))
    (or (not (typep f1 'bar))
	(do-test-error
	  () "an instance of foo1 is subtypep of an unrelated class"))
    (or (typep f2 'foo1)
	(do-test-error
	  () "an instance of foo2 is not subtypep of a super-class of foo2"))
    ))

(do-test "accessors and readers should NOT be inherited"
	 ((:classes foo bar)
	  (:functions foo-x foo-y))

  (defclass foo ()
       ((x :accessor foo-x)
	(y :reader foo-y)))

  (fmakunbound 'foo-x)
  (fmakunbound 'foo-y)

  (defclass bar (foo)
       (x y))

  (and (fboundp 'foo-x) (do-test-error () "foo-x got inherited?"))
  (and (fboundp 'foo-y) (do-test-error () "foo-x got inherited?")))

(do-test ":accessor and :reader methods go away"
	 ((:classes foo)
	  (:functions foo-x foo-y)
	  (:setf-generic-functions foo-x foo-y))  

  (defclass foo () ((x :accessor foo-x) (y :reader foo-y)))

  (unless (and (fboundp 'foo-x)
	       (fboundp 'foo-y))
    (do-test-error t "accessors didn't even get generated?"))

  (defclass foo () (x y))

  (flet ((methods (x)
	   (generic-function-methods (symbol-function 'foo-y))))
    
    (and (methods 'foo-x)
	 (do-test-error () "~&reader method for foo-x not removed"))
    (and (methods 'foo-y)
	 (do-test-error () "~&reader method for foo-y not removed"))
    (and (methods (get-setf-generic-function-name 'foo-y))
	 (do-test-error () "~&writer method for foo-y not removed"))
    t))

(do-test ":accessor-prefix methods go away"
	 ((:classes foo)
	  (:functions foo-x foo-y)
	  (:setf-generic-functions foo-x foo-y))  

  (defclass foo () (x y) (:accessor-prefix foo-))

  (unless (and (fboundp 'foo-x)
	       (fboundp 'foo-y))
    (do-test-error t "accessors didn't even get generated?"))

  (defclass foo () (x y))

  (flet ((methods (x)
	   (generic-function-methods (symbol-function 'foo-y))))
    
    (and (methods 'foo-x)
	 (do-test-error () "~&reader method for foo-x not removed"))
    (and (methods 'foo-y)
	 (do-test-error () "~&reader method for foo-y not removed"))
    (and (methods (get-setf-generic-function-name 'foo-x))
	 (do-test-error () "~&writer method for foo-y not removed"))
    (and (methods (get-setf-generic-function-name 'foo-y))
	 (do-test-error () "~&writer method for foo-y not removed"))
    t))

(do-test "constructors go away"
	 ((:classes foo)
	  (:functions make-foo-1 make-foo-2))

  (defclass foo ()
       (x y)
    (:constructor make-foo-1)
    (:constructor make-foo-2 (x y)))

  (or (and (fboundp 'make-foo-1) (fboundp 'make-foo-2))	   
      (do-test-error t "constructors didn't even get generated."))

  (defclass foo ()
       (x y))

  (and (fboundp 'make-foo-1)
       (do-test-error () "make-foo-1 didn't go away."))
  (and (fboundp 'make-foo-2)
       (do-test-error () "make-foo-2 didn't go away."))
  t)

(defclass test-class-1 () (x y) (:accessor-prefix test-class-1-))

(do-test "Simple with-slots test -- does not really exercise the walker."
	 ((:functions foo bar))

  (defmethod foo ((obj test-class-1))
    (with-slots (obj)
      (list x y)))

  (defmethod bar ((obj test-class-1))
    (with-slots ((obj :prefix obj-))
      (setq obj-x 1
            obj-y 2)))

  (or (and (equal '(nil nil) (foo (make-instance 'test-class-1)))
	   (equal '(1 2) (foo (make-instance 'test-class-1 :x 1 :y 2))))
      (do-test-error () "FOO (the one that reads) failed"))

  (or (let ((foo (make-instance 'test-class-1)))
	(bar foo)
	(or (and (equal (slot-value foo 'x) 1)
		 (equal (slot-value foo 'y) 2))
	    (do-test-error () "BAR (the one that writes) failed")))))

(do-test "Simple with-slots test (:use-accessors nil)."
	 ((:functions foo bar))
  
  (defmethod foo ((obj test-class-1))
    (with-slots ((obj :use-accessors nil))
      (list x y)))

  (defmethod bar ((obj test-class-1))
    (with-slots ((obj :prefix obj- :use-accessors nil))
      (setq obj-x 1
            obj-y 2)))

  (or (and (equal '(nil nil) (foo (make-instance 'test-class-1)))
	   (equal '(1 2) (foo (make-instance 'test-class-1 :x 1 :y 2))))
      (do-test-error () "FOO (the one that reads) failed"))

  (or (let ((foo (make-instance 'test-class-1)))
	(bar foo)
	(or (and (equal (slot-value foo 'x) 1)
		 (equal (slot-value foo 'y) 2))
	    (do-test-error () "BAR (the one that writes) failed")))))

  ;;   
;;;;;; things that bug fixes prompted.
  ;;   


(do-test "with-slots inside of lexical closures"
	 ((:functions foo bar))
  ;; 6/20/86
  ;; The walker was confused about what (FUNCTION (LAMBDA ..)) meant.  It
  ;; didn't walk inside there.  Its sort of surprising this didn't get
  ;; caught sooner.

  (defun foo (fn foos)
    (and foos (cons (funcall fn (car foos)) (foo fn (cdr foos)))))

  (defun bar ()
    (let ((the-test-class (make-instance 'test-class-1 :x 0 :y 3)))
      (with-slots ((the-test-class :class test-class-1))
	(foo #'(lambda (foo) (incf x) (decf y))
	     (make-list 3)))))

  (or (equal (bar) '(2 1 0))
      (do-test-error t "lost")))

(do-test "redefinition of default method has proper effect"
	 ((:functions foo))
  ;; 5/26/86
  ;; This was caused because the hair for trying to avoid making a
  ;; new discriminating function didn't know that changing the default
  ;; method was a reason to make a new discriminating function.  Fixed
  ;; by always making a new discriminating function when a method is
  ;; added or removed.  The template stuff should keep this from being
  ;; expensive.

  (defmethod foo ((x class)) 'class)
  (defmethod foo (x) 'default)
  (defmethod foo (x) 'new-default)

  (or (eq (foo nil) 'new-default)
      (do-test-error t "lost")))

(defmethod foo ((x class)) (call-next-method))