LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760032858. :SYSTEM-TYPE :LOGICAL :VERSION 1. :TYPE "LISP" :NAME "TEST" :DIRECTORY ("REL3-PUBLIC" "PUBLIC" "PCL") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-PUBLIC\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2756388236. :AUTHOR "REL3" :LENGTH-IN-BYTES 7728. :LENGTH-IN-BLOCKS 8. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                               ;;;-*- 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.;;;;;;   As a convention foo, bar and baz are used for classes and;;;   generic-functions which are just for the current test.  By;;;   default, do-test resets those names before running the current;;;   test.  Other names like x, y, z, method-1... are used to name;;;   classes and generic-functions which last the life of the file.;;; (defmacro do-test (name &body body)  `(catch 'do-test     (format t "~&Testing ~A..." ,name)     (if (progn ,@body) (format t "OK") (format t "FAILED!"))))  ;;   ;;;;;;   ;;   (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) (return nil))                  (finally (return t)))))))(do-test "Class Wrapper Caching"  (let* ((wrapper (make-class-wrapper 'test))         (offset (class-wrapper-get-slot-offset wrapper 'foo))         (value (list ())))        (and (eq 'foo  (setf (class-wrapper-cached-key wrapper offset) 'foo))         (eq value (setf (class-wrapper-cached-val wrapper offset) value))         (eq 'foo  (class-wrapper-cached-key wrapper offset))         (eq value (class-wrapper-cached-val wrapper offset)))))(do-test "Flushing Class-Wrapper caches"  (let* ((wrapper (make-class-wrapper 'test))         (offset (class-wrapper-get-slot-offset wrapper 'foo)))    (setf (class-wrapper-cached-key wrapper offset) 'foo)    (flush-class-wrapper-cache wrapper)    (neq 'foo  (class-wrapper-cached-key wrapper offset))))(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-get-slot-offset nil (slotd-name slotd)))(setf (class-wrapper-cached-key wrapper offset) slotd))      (dolist (slotd (class-instance-slots class))(setq offset (class-wrapper-get-slot-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))))))    t))(do-test "types for early classes"  (every #'(lambda (x) (typep (make x) x)) '(object class standard-slotd)))(do-test "types for late classes"  (every #'(lambda (x) (typep (make x) x)) '(method generic-function standard-generic-function)))(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.  (every    #'(lambda (class)(setq class (class-named class))(or (not (dolist (slotd (class-slots class))   (unless (and (every #'fboundp (slotd-accessors slotd))(every #'fboundp (slotd-readers slotd)))     (return t))))))    '(t object      essential-class class      generic-function standard-generic-function      method      standard-slotd)))  (defclass test-class-1 () (x y))(do-test "Simple with-slots test -- does not really exercise the walker."    (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)))  (and (equal '(nil nil) (foo (make 'test-class-1)))       (equal '(1 2) (foo (make 'test-class-1 :x 1 :y 2)))       (let ((foo (make 'test-class-1)))         (bar foo)         (and (equal (get-slot foo 'x) 1)              (equal (get-slot foo 'y) 2)))))(do-test "Simple with-slots test (:use-slot-value t)."    (defmethod foo ((obj test-class-1))    (with-slots ((obj :use-slot-value t))      (list x y)))  (defmethod bar ((obj test-class-1))    (with-slots ((obj :prefix obj- :use-slot-value t))      (setq obj-x 1            obj-y 2)))  (and (equal '(nil nil) (foo (make 'test-class-1)))       (equal '(1 2) (foo (make 'test-class-1 :x 1 :y 2)))       (let ((foo (make 'test-class-1)))         (bar foo)         (and (equal (get-slot foo 'x) 1)              (equal (get-slot foo 'y) 2)))))  ;;   ;;;;;; things that bug fixes prompted.  ;;   (do-test "with inside of lexical closures"  ;; 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 '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)))))  (equal (bar) '(2 1 0)))(do-test "redefinition of default method has proper effect"  ;; 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.  (fmakunbound 'foo)  (defmethod foo ((x class)) 'class)  (defmethod foo (x) 'default)  (defmethod foo (x) 'new-default)  (eq (foo nil) 'new-default))d-class essential-class) proto-class name local-supers local-slot-slotds extra)  (declare (ignore local-supers local-slot-slotds extra))  (cond ((not (compatible-meta-class-change-p old-class proto-class)) (error "The class ~A already exists; its class is ~A.~%~ The :class argument in the defstruct is ~A. This is an incompatible meta-class change.~%"name(class-name (class-of old-class))(class-name (class-of proto-cla