home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume10 / comobj.lisp / part06 / test.l < prev   
Encoding:
Text File  |  1987-08-01  |  21.4 KB  |  660 lines
  1. ;;;-*- Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
  5. ;;;
  6. ;;; Use and copying of this software and preparation of derivative works
  7. ;;; based upon this software are permitted.  Any distribution of this
  8. ;;; software or derivative works must comply with all applicable United
  9. ;;; States export control laws.
  10. ;;; 
  11. ;;; This software is made available AS IS, and Xerox Corporation makes no
  12. ;;; warranty about the software, its performance or its conformity to any
  13. ;;; specification.
  14. ;;; 
  15. ;;; Any person obtaining a copy of this software is requested to send their
  16. ;;; name and post office or electronic mail address to:
  17. ;;;   CommonLoops Coordinator
  18. ;;;   Xerox Artifical Intelligence Systems
  19. ;;;   2400 Hanover St.
  20. ;;;   Palo Alto, CA 94303
  21. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  22. ;;;
  23. ;;; Suggestions, comments and requests for improvements are also welcome.
  24. ;;; *************************************************************************
  25. ;;; 
  26. ;;; Testing code.
  27. ;;;
  28.  
  29. (in-package 'pcl)
  30.  
  31. ;;; Because CommonLoops runs in itself so much, the notion of a test file for
  32. ;;; it is kind of weird.
  33. ;;;
  34. ;;; If all of PCL loads then many of the tests in this file (particularly
  35. ;;; those at the beginning) are sure to work.  Those tests exists primarily
  36. ;;; to help debug things when low-level changes are made to PCL, or when a
  37. ;;; particular port customizes low-level code.
  38. ;;;
  39. ;;; Some of the other tests are "real" in the sense that they test things
  40. ;;; that PCL itself does not use, so might be broken.
  41. ;;; 
  42. ;;; NOTE:
  43. ;;;   The tests in this file do not appear in random order!  They
  44. ;;;   depend on state  which has already been set up in order to run.
  45. ;;;
  46. ;;;   As a convention foo, bar and baz are used for classes and
  47. ;;;   discriminators which are just for the current test.  By
  48. ;;;   default, do-test resets those names before running the current
  49. ;;;   test.  Other names like x, y, z, method-1... are used to name
  50. ;;;   classes and discriminators which last the life of the file.
  51. ;;; 
  52.  
  53. (defvar *without-errors*
  54.     (or #+Symbolics #'(lambda (form)
  55.                 `(multiple-value-bind (.values. .errorp.)
  56.                  (si::errset ,form nil)
  57.                    (declare (ignore .values.))
  58.                    .errorp.))
  59.         #+Xerox     #'(lambda (form)
  60.                 `(xcl:condition-case (progn ,form nil)
  61.                    (error () t)))
  62.         
  63.         nil))
  64.  
  65. (defmacro without-errors (&body body)
  66.   (if *without-errors*
  67.       (funcall *without-errors* `(progn ,@body))
  68.       (error "Calling WITHOUT-ERRORS when *without-errors* is nil.")))
  69.  
  70. #-HP (defmacro do-test (name&options &body body)
  71.   (let ((name (if (listp name&options) (car name&options) name&options))
  72.     (options (if (listp name&options) (cdr name&options) ())))
  73.     (keyword-bind ((clear t)
  74.            (should-error nil))
  75.           options
  76.       (cond ((and should-error (null *without-errors*))
  77.          `(format t
  78.         "~&Skipping testing ~A,~%~
  79.              because can't ignore errors in this Common Lisp."
  80.         ',name))
  81.         (t
  82.          `(progn
  83.         (format t "~&Testing ")
  84.         (format t ,name)
  85.         (format t "... ")
  86.         ,(when clear
  87.            '(progn (dolist (x '(foo bar baz))
  88.                  (setf (discriminator-named x) nil)
  89.                  (fmakunbound x)
  90.                  (setf (class-named x) nil))))
  91.         (if ,(if should-error
  92.              `(without-errors (progn ,@body))
  93.              `(progn ,@body))
  94.             (format t "OK")
  95.             (progn (format t "FAILED")
  96.                (error "Test Failed: ~A" ',name)))))))))
  97.  
  98. #+HP (defmacro do-test (name&options &body body)
  99.   (let ((name (if (listp name&options) (car name&options) name&options))
  100.     (options (if (listp name&options) (cdr name&options) ())))
  101.     (keyword-bind ((clear t)
  102.            (should-error nil))
  103.           options
  104.       (cond ((and should-error (null *without-errors*))
  105.          `(format t
  106.         "~&Skipping testing ~A,~%~
  107.              because can't ignore errors in this Common Lisp."
  108.         ',name))
  109.         (t
  110.          `(progn
  111.         (format t "~&Testing ~A..." ,name)
  112.         ,(when clear
  113.            '(progn (dolist (x '(foo bar baz))
  114.                  (setf (discriminator-named x) nil)
  115.                  (fmakunbound x)
  116.                  (setf (class-named x) nil))))
  117.         
  118.          ,@(butlast body)
  119.          (if ,(if should-error
  120.              `(without-errors (progn ,@body))
  121.              `(progn ,@(last body)))
  122.             (format t "OK")
  123.             (progn (format t "FAILED")
  124.                (error "Test Failed: ~A" ',name)))))))))
  125.  
  126. (defun permutations (elements length)
  127.   (if (= length 1)
  128.       (iterate ((x in elements)) (collect (list x)))
  129.       (let ((sub-permutations (permutations elements (- length 1))))
  130.         (iterate ((x in elements))
  131.           (join (iterate ((y in sub-permutations))
  132.                   (collect (cons x y))))))))
  133.  
  134.   ;;   
  135. ;;;;;; 
  136.   ;;   
  137.  
  138.  
  139. (eval-when (load eval)
  140.   (format t "~&~%~%Testing Extremely low-level stuff..."))
  141.  
  142. (do-test ("Memory Block Primitives" :clear nil)
  143.   (let ((block (make-memory-block 10))
  144.         (tests (iterate ((i from 0 below 10)) (collect (make-list 1)))))
  145.     (and (numberp (memory-block-size block))
  146.          (= (memory-block-size block) 10)
  147.          (progn (iterate ((i from 0) (test in tests))
  148.                   (setf (memory-block-ref block i) test))
  149.                 (iterate ((i from 0) (test in tests))
  150.                   (unless (eq (memory-block-ref block i) test) (return nil))
  151.                   (finally (return t)))))))
  152.  
  153. (do-test ("Class Wrapper Caching" :clear nil)
  154.   (let* ((wrapper (make-class-wrapper 'test))
  155.          (offset (class-wrapper-get-slot-offset wrapper 'foo))
  156.          (value (list ())))
  157.     
  158.     (and (eq 'foo  (setf (class-wrapper-cached-key wrapper offset) 'foo))
  159.          (eq value (setf (class-wrapper-cached-val wrapper offset) value))
  160.          (eq 'foo  (class-wrapper-cached-key wrapper offset))
  161.          (eq value (class-wrapper-cached-val wrapper offset)))))
  162.  
  163. (do-test ("Flushing Class-Wrapper caches" :clear nil)
  164.   (let* ((wrapper (make-class-wrapper 'test))
  165.          (offset (class-wrapper-get-slot-offset wrapper 'foo)))
  166.     (setf (class-wrapper-cached-key wrapper offset) 'foo)
  167.     (flush-class-wrapper-cache wrapper)
  168.     (neq 'foo  (class-wrapper-cached-key wrapper offset))))
  169.  
  170. (do-test "Class Wrapper Caching"
  171.   (let ((slots '(;; Some random important slots.
  172.          name class-wrapper class-precedence-list
  173.          direct-supers direct-subclasses direct-methods
  174.          no-of-instance-slots instance-slots
  175.          local-supers
  176.          non-instance-slots local-slots  prototype))
  177.     (wrapper (make-class-wrapper 'test))
  178.     (hits 0))
  179.     (iterate ((slot in slots))
  180.       (let ((offset (class-wrapper-get-slot-offset wrapper slot)))
  181.     (setf (class-wrapper-cached-key wrapper offset) slot)))
  182.     (iterate ((slot in slots))
  183.       (let ((offset (class-wrapper-get-slot-offset wrapper slot)))
  184.     (and (eq (class-wrapper-cached-key wrapper offset) slot)
  185.          (incf hits))))
  186.     (format t
  187.         " (~D% hit) "
  188.         (* 100.0 (/ hits (float (length slots)))))
  189.     t))
  190.  
  191. ;(do-test "static slot-storage"
  192. ;  (let ((static-slots (%allocate-static-slot-storage--class 5)))
  193. ;    (iterate ((i from 0))
  194. ;      (when (= i 5) (return t))
  195. ;      (let ((cons (list ()))
  196. ;            (index (%convert-slotd-position-to-slot-index i)))
  197. ;        (setf (%static-slot-storage-get-slot--class static-slots index) cons)
  198. ;        (or (eq cons
  199. ;        (%static-slot-storage-get-slot--class static-slots index))
  200. ;            (return nil))))))
  201.  
  202.  
  203. (eval-when (load eval) (format t "~&~%~%Testing High-Level stuff..."))
  204.  
  205.  
  206.  
  207. (defvar *built-in-classes*
  208.         '((T              T)
  209.           (NUMBER         1)
  210.           (RATIO       1/2                          1/2)
  211.           (COMPLEX)
  212.           (INTEGER        1)
  213.           (RATIO)
  214.           (FIXNUM         most-positive-fixnum         most-positive-fixnum)
  215.           (BIGNUM         (+ most-positive-fixnum 1)   (+ most-positive-fixnum 1)) 
  216.           SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT
  217.           (FLOAT          1.1)
  218.           (NULL           ()                           ())
  219.           (STANDARD-CHAR  #\a)
  220.           (STRING-CHAR    #\a)
  221.           (CHARACTER      #\a                          #\a)
  222.           BIT-VECTOR
  223.           (STRING         (make-string 1)              (make-string 1))
  224.           (ARRAY          (make-array 1))
  225.           SIMPLE-ARRAY SIMPLE-VECTOR SIMPLE-STRING SIMPLE-BIT-VECTOR
  226.           (VECTOR         (make-string 1))
  227.           (VECTOR         (make-array 1))
  228.           (LIST           '(1 2 3))
  229.           (SEQUENCE       (make-string 1))
  230.           (SEQUENCE       (make-array 1))
  231.           (SEQUENCE       (make-list 1))                             
  232.           (HASH-TABLE     (make-hash-table :size 1)    (make-hash-table :size 1))
  233.           (READTABLE      *readtable*                  *readtable*)
  234.           (PACKAGE        *package*                    *package*)
  235.           (PATHNAME       (make-pathname :name "foo")  (make-pathname :name "foo"))
  236.           (STREAM         *terminal-io*                *terminal-io*)
  237.           (RANDOM-STATE   (make-random-state)          (make-random-state))
  238.           (CONS           (cons 1 2)                   (cons 1 2))
  239.           (SYMBOL         'foo                         'foo)
  240.           COMMON))
  241.  
  242. (do-test "existence of built-in classes"
  243.   (not (dolist (entry *built-in-classes*)
  244.          (let ((type (if (listp entry) (car entry) entry)))
  245.            (or (class-named type t)
  246.                (progn (format t "Missing the built-in class named: ~S" type)
  247.                       (return t)))))))  
  248.  
  249. ;;; See how CLASS-OF works.
  250. ;(eval-when (load eval)
  251. ;  (format t "~%Check to see how well portable CLASS-OF works... ")
  252. ;  (let ((lost ()))
  253. ;    (dolist (entry *built-in-classes*)
  254. ;      (or (not (listp entry))
  255. ;      (null (cddr entry))
  256. ;      (let* ((thing (eval (caddr entry)))
  257. ;         (class (class-of thing)))
  258. ;        (and class (eq (class-name class) (car entry))))
  259. ;      (progn (setq lost t)
  260. ;         (format t
  261. ;             "~&WARNING: Can't define methods on: ~S."
  262. ;             (car entry)))))
  263. ;    (when lost (terpri) (terpri))
  264. ;    (format t "OK")))
  265.  
  266. (do-test "existence of discriminators for accessors of early classes"
  267.   ;; Because accessors are done with add-method, and this has to be done
  268.   ;; specially for early classes it is worth testing to make sure that
  269.   ;; the discriminators got created for the accessor of early classes.
  270.   (not
  271.     (dolist (class '(t object essential-class class discriminator method))
  272.       (setq class (class-named class))
  273.       (or (not (dolist (slotd (class-instance-slots class))
  274.                  (and (slotd-accessor slotd)
  275.                       (or (discriminator-named (slotd-accessor slotd))
  276.                           (return nil)))))
  277.           (not (dolist (slotd (class-non-instance-slots class))
  278.                  (and (slotd-accessor slotd)
  279.                       (or (discriminator-named (slotd-accessor slotd))
  280.                           (return nil)))))))))
  281.  
  282. (do-test "a simple defstruct"
  283.   (ndefstruct (x (:class class))
  284.     (a 1)
  285.     (b 2))
  286.  
  287.   (and (fboundp 'make-x)
  288.        (fboundp 'x-p)
  289.        (fboundp 'copy-x)
  290.        (fboundp 'x-a)
  291.        (fboundp 'x-b)
  292.        (typep--class (make-x) 'x)
  293.        (x-p (make-x))
  294.        (equal (x-a (make-x)) 1)
  295.        (equal (x-a (make-x :a 3)) 3)
  296.        (x-p (copy-x (make-x)))
  297.        ))
  298.  
  299. (do-test "obsolete-class stuff"
  300.   (and (class-named 'obsolete-class)
  301.        (let ((old-x-class (class-named 'x))
  302.              (old-x-instance (make-x)))
  303.          
  304.          (ndefstruct (x (:class class))
  305.                      (a 3))
  306.          (and (neq (class-of old-x-instance) (class-named 'x))
  307.               (= (x-a old-x-instance) 1)))))
  308.  
  309. (do-test "multiple constructors"
  310.   (ndefstruct (x (:class class)
  311.                  (:constructor make-x)
  312.                  (:constructor make-x-1 (a b)))
  313.     a
  314.     b)
  315.   (and (fboundp 'make-x)
  316.        (fboundp 'make-x-1)
  317.        (equal (get-slot (make-x :a 1 :b 2) 'a) 1)
  318.        (equal (get-slot (make-x :a 1 :b 2) 'b) 2)
  319.        (equal (get-slot (make-x-1 2 1) 'a) 2)
  320.        (equal (get-slot (make-x-1 2 1) 'b) 1)))
  321.  
  322. (do-test "the :print-function defstruct-option"
  323.  
  324.   (ndefstruct (x (:class class)
  325.                  (:print-function x-print-function))
  326.     a
  327.     b)
  328.  
  329.   (defun x-print-function (object stream level)
  330.     (when (and (x-p object)
  331.                (streamp stream)                 ;Don't be breaking my test file
  332.                (numberp level))                 ;because of your problems.
  333.       (throw 'x 'x)))
  334.  
  335.   (eq (catch 'x (prin1 (make 'x))) 'x))
  336.  
  337. ;;; ** need more tests in here,
  338. ;;; test the basic iwmc-class structure
  339. ;;; test class-wrappers some more
  340. ;;; 
  341.  
  342. ;;; OK, now we know that simple defstruct works and that obsolete classes work.
  343. ;;; Now we set up some real simple classes that we can use for the rest of the
  344. ;;; file.
  345. ;;;
  346. (ndefstruct (i (:class class)))                     ;(i ..)
  347. (ndefstruct (j (:class class)))                     ;(j ..)
  348. (ndefstruct (k (:class class)))                     ;(k ..)
  349.  
  350. (ndefstruct (l (:class class) (:include (i))))      ;(l i ..)
  351. (ndefstruct (m (:class class) (:include (i j))))    ;(m i j ..)
  352. (ndefstruct (n (:class class) (:include (k))))      ;(n k ..)
  353.  
  354. (ndefstruct (q (:class class) (:include (i))))      ;(q i ..)
  355. (ndefstruct (r (:class class) (:include (m))))      ;(r m i j ..)
  356. (ndefstruct (s (:class class) (:include (n i k))))  ;(s n i k ..)
  357.  
  358. (do-test "classical methods"
  359.   
  360.   (defmeth foo ((x i)) x 'i)  
  361.   (defmeth foo ((x n)) x 'n)
  362.   (defmeth foo ((x s)) x 's)
  363.  
  364.   (and (eq (foo (make-i)) 'i)
  365.        (eq (foo (make-n)) 'n)
  366.        (eq (foo (make-s)) 's)))
  367.  
  368. (do-test "run-super"
  369.  
  370.   (defmeth foo (o) o ())
  371.   
  372.   (defmeth foo ((o i)) o (cons 'i (run-super)))
  373.   (defmeth foo ((o m)) o (cons 'm (run-super)))
  374.   (defmeth foo ((o n)) o (cons 'n (run-super)))
  375.   (defmeth foo ((o q)) o (cons 'q (run-super)))
  376.   (defmeth foo ((o r)) o (cons 'r (run-super)))
  377.   (defmeth foo ((o s)) o (cons 's (run-super)))
  378.  
  379.   (let ((i (make-i)) (m (make-m)) (q (make-q)) (r (make-r)) (s (make-s)))
  380.     (and (equal (foo i) '(i))
  381.          (equal (foo m) '(m i))
  382.          (equal (foo q) '(q i))
  383.          (equal (foo r) '(r m i))
  384.          (equal (foo s) '(s n i)))))
  385.  
  386. (do-test "multi-methods when first 3 args are discriminated on"
  387.   (let ((permutations (permutations '(i n r) 3)))
  388.     (mapcar #'(lambda (p)
  389.                 (EVAL `(defmeth foo ,(mapcar 'list '(x y z) p) x y z ',p)))
  390.             permutations)
  391.     (every #'(lambda (p)
  392.                (equal (apply 'foo (mapcar 'make p)) p))
  393.            permutations)))
  394.  
  395. (do-test "multi-methods when assorted args are discriminated on"
  396.   (let ((permutations (permutations '(i n r nil) 3)))
  397.     (mapc #'(lambda (p)
  398.           (EVAL `(defmeth foo
  399.                   ,(mapcar #'(lambda (arg type-spec)
  400.                        (if type-spec
  401.                            (list arg type-spec) arg))
  402.                        '(arg1 arg2 arg3)
  403.                        p)
  404.                arg1 arg2 arg3 ',p)))
  405.       permutations)
  406.     (every #'(lambda (p)
  407.                (equal (apply 'foo
  408.                  (mapcar #'(lambda (x) (and x (make x))) p)) p))
  409.            permutations)))
  410.  
  411.  
  412.  
  413. ;(do-test "anonymous discriminators"
  414. ;  
  415. ;  (let ((foo (make 'discriminator))
  416. ;        (proto-method (class-prototype (class-named 'method))))
  417. ;    (add-method-internal  foo proto-method '(thing) (list (class-named 'x)) '(lambda (thing) thing 'x))
  418. ;    (add-method foo '(thing) (list (class-named 'y)) '(lambda (thing) thing 'y))
  419. ;    (add-method foo '(thing) (list (class-named 'z)) '(lambda (thing) thing 'z))
  420. ;
  421. ;    (let ((function (discriminator-discriminating-function foo)))
  422. ;      (and (eq (funcall function (make 'x)) 'x)
  423. ;          (eq (funcall function (make 'y)) 'y)
  424. ;          (eq (funcall function (make 'z)) 'z)))))
  425.  
  426.  
  427.  
  428. (do-test "Simple with test -- does not really exercise the walker."
  429.   
  430.   (ndefstruct (foo (:class class))
  431.     (x 0)
  432.     (y 0))
  433.  
  434.   (defmeth foo ((obj foo))
  435.     (with (obj)
  436.       (list x y)))
  437.  
  438.   (defmeth bar ((obj foo))
  439.     (with ((obj obj-))
  440.       (setq obj-x 1
  441.             obj-y 2)))
  442.  
  443.   (and (equal '(0 0) (foo (make-foo)))
  444.        (equal '(1 2) (foo (make-foo :x 1 :y 2)))
  445.        (let ((foo (make-foo)))
  446.          (bar foo)
  447.          (and (equal (get-slot foo 'x) 1)
  448.               (equal (get-slot foo 'y) 2)))))
  449.  
  450. (do-test "Simple with* test -- does not really exercise the walker."
  451.   
  452.   (ndefstruct (foo (:class class))
  453.     (x 0)
  454.     (y 0))
  455.  
  456.   (defmeth foo ((obj foo))
  457.     (with* (obj)
  458.       (list x y)))
  459.  
  460.   (defmeth bar ((obj foo))
  461.     (with* ((obj obj-))
  462.       (setq obj-x 1
  463.             obj-y 2)))
  464.  
  465.   (and (equal '(0 0) (foo (make-foo)))
  466.        (equal '(1 2) (foo (make-foo :x 1 :y 2)))
  467.        (let ((foo (make-foo)))
  468.          (bar foo)
  469.          (and (equal (get-slot foo 'x) 1)
  470.               (equal (get-slot foo 'y) 2)))))
  471.  
  472. '(
  473.  
  474. ;;; setup for :daemon combination test
  475. ;;;
  476.  
  477. (do-test "setting up for :daemon method combination test"
  478.   
  479.   (ndefstruct (foo (:class class)))
  480.   (ndefstruct (bar (:class class) (:include (foo))))
  481.   (ndefstruct (baz (:class class) (:include (bar)))))
  482.  
  483. (defvar *foo*)
  484.  
  485. (defmeth foo ((x foo)) (push 'foo *foo*) 'foo)
  486. (defmeth (foo :before) ((x foo)) (push '(:before foo) *foo*))
  487. (defmeth (foo :after)  ((x foo)) (push '(:after foo) *foo*))
  488.  
  489. (do-test (":before primary and :after all on same class." :clear nil)
  490.  
  491.   (let ((*foo* ()))
  492.     (and (eq (foo (make 'foo)) 'foo)
  493.      (equal *foo* '((:after foo) foo (:before foo))))))
  494.  
  495. (defmeth foo ((x bar)) (push 'bar *foo*) 'bar)
  496.  
  497. (do-test (":before and :after inherited, primary from this class" :clear nil)
  498.  
  499.   (let ((*foo* ()))
  500.     (and (eq (foo (make 'bar)) 'bar)
  501.      (equal *foo* '((:after foo) bar (:before foo))))))
  502.  
  503. (do-test ("make sure shadowing primary in sub-class has no effect here"
  504.       :clear nil)
  505.   (let ((*foo* ()))
  506.     (and (eq (foo (make 'foo)) 'foo)
  507.      (equal *foo* '((:after foo) foo (:before foo))))))
  508.  
  509. (defmeth (foo :before) ((x bar)) (push '(:before bar) *foo*))
  510. (defmeth (foo :after) ((x bar))  (push '(:after bar) *foo*))
  511.  
  512. (do-test (":before both here and inherited~%~
  513.            :after both here and inherited~%~
  514.            primary from here"
  515.       :clear nil)
  516.   (let ((*foo* ()))
  517.     (and (eq (foo (make 'bar)) 'bar)
  518.      (equal (reverse *foo*)
  519.         '((:before bar) (:before foo) bar (:after foo) (:after bar))))))
  520.  
  521. (defmeth foo ((x baz)) (push 'baz *foo*) 'baz)
  522.  
  523. (do-test ("2 :before and 2 :after inherited, primary from here" :clear nil)
  524.   (let ((*foo* ()))
  525.     (and (eq (foo (make 'baz)) 'baz)
  526.      (equal (reverse *foo*)
  527.         '((:before bar) (:before foo) baz (:after foo) (:after bar))))))
  528.  
  529.  
  530. (do-test "setting up for :list method combination test"
  531.   (make-specializable 'foo :arglist '(x) :method-combination-type :list)
  532.   
  533.   (ndefstruct (foo (:class class)))
  534.   (ndefstruct (bar (:class class) (:include (foo))))
  535.   (ndefstruct (baz (:class class) (:include (bar)))))
  536.  
  537. (defmeth foo ((x foo)) 'foo)
  538.  
  539. (do-test ("single method, :list combined, from here" :clear nil)
  540.   (equal (foo (make 'foo)) '(foo)))
  541.  
  542. (defmeth foo ((x bar)) 'bar)
  543. (do-test ("method from here and one inherited, :list combined" :clear nil)
  544.   (equal (foo (make 'bar)) '(foo bar)))
  545.  
  546. (defmeth foo ((x baz)) 'baz)
  547.  
  548. (do-test ("method from here, two inherited, :list combined" :clear nil)
  549.   (equal (foo (make 'baz)) '(foo bar baz)))
  550.  
  551. (do-test ("make sure that more specific methods aren't in my combined method"
  552.       :clear nil)
  553.   (and (equal (foo (make 'foo)) '(foo))
  554.        (equal (foo (make 'bar)) '(foo bar))
  555.        (equal (foo (make 'baz)) '(foo bar baz))))
  556.  
  557. )
  558.  
  559.   ;;   
  560. ;;;;;; things that bug fixes prompted.
  561.   ;;   
  562.  
  563.  
  564. (do-test "with inside of lexical closures"
  565.   ;; 6/20/86
  566.   ;; The walker was confused about what (FUNCTION (LAMBDA ..)) meant.  It
  567.   ;; didn't walk inside there.  Its sort of surprising this didn't get
  568.   ;; caught sooner.
  569.  
  570.   (ndefstruct (foo (:class class))
  571.     (x 0)
  572.     (y 0))
  573.  
  574.   (defun foo (fn foos)
  575.     (and foos (cons (funcall fn (car foos)) (foo fn (cdr foos)))))
  576.  
  577.   (defun bar ()
  578.     (let ((the-foo (make 'foo :x 0 :y 3)))
  579.       (with ((the-foo () foo))
  580.     (foo #'(lambda (foo) (incf x) (decf y))
  581.          (make-list 3)))))
  582.  
  583.   (equal (bar) '(2 1 0)))
  584.  
  585. (do-test "redefinition of default method has proper effect"
  586.   ;; 5/26/86
  587.   ;; This was caused because the hair for trying to avoid making a
  588.   ;; new discriminating function didn't know that changing the default
  589.   ;; method was a reason to make a new discriminating function.  Fixed
  590.   ;; by always making a new discriminating function when a method is
  591.   ;; added or removed.  The template stuff should keep this from being
  592.   ;; expensive.
  593.  
  594.   (defmeth foo ((x class)) 'class)
  595.   (defmeth foo (x) 'default)
  596.   (defmeth foo (x) 'new-default)
  597.  
  598.   (eq (foo nil) 'new-default))
  599.  
  600.  
  601. (do-test ("extra keywords in init-plist cause an error" :should-error t)
  602.   ;; 5/26/86
  603.   ;; Remember that Common-Lisp defstruct signals errors if there are
  604.   ;; extra keywords in the &rest argument to make-foo.
  605.   
  606.   (ndefstruct (foo (:class class)) a b c)
  607.  
  608.   (make 'foo :d 3))
  609.  
  610. (do-test "run-super with T specifier for first arg"
  611.   ;; 5/29/86
  612.   ;; This was caused because run-super-internal didn't know about the
  613.   ;; type-specifier T being special.  This is yet another reason to
  614.   ;; flush that nonsense about keeping T special.
  615.  
  616.   (defmeth foo (x y) '((t t)))
  617.  
  618.   (defmeth foo (x (y k)) '((t k)))
  619.  
  620.   (defmeth foo (x (y n)) (cons '(t n) (run-super)))
  621.  
  622.   (defmeth foo ((x i) (y k)) '((i k)))
  623.  
  624.   (defmeth foo ((x l) (y n)) (cons '(l n) (run-super)))
  625.  
  626.  
  627.   (and (equal (foo (make 'l) (make 'n)) '((l n) (i k)))
  628.        (equal (foo (make 'i) (make 'k)) '((i k)))
  629.        (equal (foo () (make 'k)) '((t k)))
  630.        (equal (foo () (make 'n)) '((t n) (t k)))))
  631.  
  632. (do-test "with inside of with scopes correctly"
  633.   ;; 7/07/86
  634.  
  635.   (ndefstruct (foo (:class class)
  636.            (:conc-name nil))
  637.     (foo 1))
  638.  
  639.   (ndefstruct (bar (:class class)
  640.            (:conc-name nil))
  641.     (foo 1))
  642.  
  643.  
  644.   (defmeth foo ((bar bar)) bar ())
  645.  
  646.   (defun bar (x)
  647.     (with* ((x "" foo))
  648.       (list foo (with ((x "" bar)) foo))))
  649.  
  650.   (defun baz (x)
  651.     (with ((x "" bar))
  652.       (list foo (with* ((x "" foo)) foo))))
  653.  
  654.   (and (equal (bar (make 'bar)) '(1 nil))
  655.        (equal (baz (make 'bar)) '(nil 1))
  656.  
  657.        (equal (bar (make 'foo)) '(1 1))
  658.        (equal (baz (make 'foo)) '(1 1))))
  659.  
  660.