;;;-*- 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))