tests/clos.impure.lisp

   1 ;;;; miscellaneous side-effectful tests of CLOS
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (defpackage "CLOS-IMPURE"
  15   (:use "CL" "ASSERTOID" "TEST-UTIL"))
  16 (in-package "CLOS-IMPURE")
  17 \f
  18 ;;; It should be possible to do DEFGENERIC and DEFMETHOD referring to
  19 ;;; structure types defined earlier in the file.
  20 (defstruct struct-a x y)
  21 (defstruct struct-b x y z)
  22 (defmethod wiggle ((a struct-a))
  23   (+ (struct-a-x a)
  24      (struct-a-y a)))
  25 (defgeneric jiggle (arg))
  26 (defmethod jiggle ((a struct-a))
  27   (- (struct-a-x a)
  28      (struct-a-y a)))
  29 (defmethod jiggle ((b struct-b))
  30   (- (struct-b-x b)
  31      (struct-b-y b)
  32      (struct-b-z b)))
  33 (assert (= (wiggle (make-struct-a :x 6 :y 5))
  34            (jiggle (make-struct-b :x 19 :y 6 :z 2))))
  35
  36 ;;; Compiling DEFGENERIC should prevent "undefined function" style
  37 ;;; warnings from code within the same file.
  38 (defgeneric gf-defined-in-this-file (x y))
  39 (defun function-using-gf-defined-in-this-file (x y n)
  40   (unless (minusp n)
  41     (gf-defined-in-this-file x y)))
  42
  43 ;;; Until Martin Atzmueller ported Pierre Mai's CMU CL fixes in
  44 ;;; sbcl-0.6.12.25, the implementation of NO-APPLICABLE-METHOD was
  45 ;;; broken in such a way that the code here would signal an error.
  46 (defgeneric zut-n-a-m (a b c))
  47 (defmethod no-applicable-method ((zut-n-a-m (eql #'zut-n-a-m)) &rest args)
  48   (format t "~&No applicable method for ZUT-N-A-M ~S, yet.~%" args))
  49 (zut-n-a-m 1 2 3)
  50
  51 ;;; bug reported and fixed by Alexey Dejneka sbcl-devel 2001-09-10:
  52 ;;; This DEFGENERIC shouldn't cause an error.
  53 (defgeneric ad-gf (a) (:method :around (x) x))
  54
  55 ;;; DEFGENERIC and DEFMETHOD shouldn't accept &REST when it's not
  56 ;;; followed by a variable:
  57 ;;; e.g. (DEFMETHOD FOO ((X T) &REST) NIL) should signal an error.
  58 (eval-when (:load-toplevel :compile-toplevel :execute)
  59   (defmacro expect-error (&body body)
  60     `(multiple-value-bind (res condition)
  61       (ignore-errors (progn ,@body))
  62       (declare (ignore res))
  63       (typep condition 'error))))
  64 (assert (expect-error
  65          (macroexpand-1
  66           '(defmethod foo0 ((x t) &rest) nil))))
  67 (assert (expect-error (defgeneric foo1 (x &rest))))
  68 (assert (expect-error (defgeneric foo2 (x a &rest))))
  69 (defgeneric foo3 (x &rest y))
  70 (defmethod foo3 ((x t) &rest y) nil)
  71 (defmethod foo4 ((x t) &rest z &key y) nil)
  72 (defgeneric foo4 (x &rest z &key y))
  73 (assert (expect-error (defgeneric foo5 (x &rest))))
  74 (assert (expect-error (macroexpand-1 '(defmethod foo6 (x &rest)))))
  75
  76 ;;; more lambda-list checking
  77 ;;;
  78 ;;; DEFGENERIC lambda lists are subject to various limitations, as per
  79 ;;; section 3.4.2 of the ANSI spec. Since Alexey Dejneka's patch for
  80 ;;; bug 191-b ca. sbcl-0.7.22, these limitations should be enforced.
  81 (labels ((coerce-to-boolean (x)
  82            (if x t nil))
  83          (%like-or-dislike (expr expected-failure-p)
  84            (declare (type boolean expected-failure-p))
  85            (format t "~&trying ~S~%" expr)
  86            (multiple-value-bind (fun warnings-p failure-p)
  87              (compile nil
  88                       `(lambda ()
  89                          ,expr))
  90              (declare (ignore fun))
  91              ;; In principle the constraint on WARNINGS-P below seems
  92              ;; reasonable, but in practice we get warnings about
  93              ;; undefined functions from the DEFGENERICs, apparently
  94              ;; because the DECLAIMs which ordinarily prevent such
  95              ;; warnings don't take effect because EVAL-WHEN
  96              ;; (:COMPILE-TOPLEVEL) loses its magic when compiled
  97              ;; within a LAMBDA. So maybe we can't test WARNINGS-P
  98              ;; after all?
  99              ;;(unless expected-failure-p
 100              ;;  (assert (not warnings-p)))
 101              (assert (eq (coerce-to-boolean failure-p) expected-failure-p))))
 102          (like (expr)
 103            (%like-or-dislike expr nil))
 104          (dislike (expr)
 105            (%like-or-dislike expr t)))
 106   ;; basic sanity
 107   (dislike '(defgeneric gf-for-ll-test-0 ("a" #p"b")))
 108   (like    '(defgeneric gf-for-ll-test-1 ()))
 109   (like    '(defgeneric gf-for-ll-test-2 (x)))
 110   ;; forbidden default or supplied-p for &OPTIONAL or &KEY arguments
 111   (dislike '(defgeneric gf-for-ll-test-3 (x &optional (y 0))))
 112   (like    '(defgeneric gf-for-ll-test-4 (x &optional y)))
 113   (dislike '(defgeneric gf-for-ll-test-5 (x y &key (z :z z-p))))
 114   (like    '(defgeneric gf-for-ll-test-6 (x y &key z)))
 115   (dislike '(defgeneric gf-for-ll-test-7 (x &optional (y 0) &key z)))
 116   (like    '(defgeneric gf-for-ll-test-8 (x &optional y &key z)))
 117   (dislike '(defgeneric gf-for-ll-test-9 (x &optional y &key (z :z))))
 118   (like    '(defgeneric gf-for-ll-test-10 (x &optional y &key z)))
 119   (dislike '(defgeneric gf-for-ll-test-11 (&optional &key (k :k k-p))))
 120   (like    '(defgeneric gf-for-ll-test-12 (&optional &key k)))
 121   ;; forbidden &AUX
 122   (dislike '(defgeneric gf-for-ll-test-13 (x y z &optional a &aux g h)))
 123   (like    '(defgeneric gf-for-ll-test-14 (x y z &optional a)))
 124   (dislike '(defgeneric gf-for-ll-test-bare-aux-1 (x &aux)))
 125   (like    '(defgeneric gf-for-ll-test-bare-aux-2 (x)))
 126   ;; also can't use bogoDEFMETHODish type-qualifier-ish decorations
 127   ;; on required arguments
 128   (dislike '(defgeneric gf-for-11-test-15 ((arg t))))
 129   (like '(defgeneric gf-for-11-test-16 (arg))))
 130
 131 ;;; structure-class tests setup
 132 (defclass structure-class-foo1 () () (:metaclass cl:structure-class))
 133 (defclass structure-class-foo2 (structure-class-foo1)
 134   () (:metaclass cl:structure-class))
 135
 136 ;;; standard-class tests setup
 137 (defclass standard-class-foo1 () () (:metaclass cl:standard-class))
 138 (defclass standard-class-foo2 (standard-class-foo1)
 139   () (:metaclass cl:standard-class))
 140
 141 (assert (typep (class-of (make-instance 'structure-class-foo1))
 142                'structure-class))
 143 (assert (typep (make-instance 'structure-class-foo1) 'structure-class-foo1))
 144 (assert (typep (make-instance 'standard-class-foo1) 'standard-class-foo1))
 145
 146 ;;; DEFGENERIC's blow-away-old-methods behavior is specified to have
 147 ;;; special hacks to distinguish between defined-with-DEFGENERIC-:METHOD
 148 ;;; methods and defined-with-DEFMETHOD methods, so that reLOADing
 149 ;;; DEFGENERIC-containing files does the right thing instead of
 150 ;;; randomly slicing your generic functions. (APD made this work
 151 ;;; in sbcl-0.7.0.2.)
 152 (defgeneric born-to-be-redefined (x)
 153   (:method ((x integer))
 154     'integer))
 155 (defmethod born-to-be-redefined ((x real))
 156   'real)
 157 (assert (eq (born-to-be-redefined 1) 'integer))
 158 (defgeneric born-to-be-redefined (x))
 159 (assert (eq (born-to-be-redefined 1) 'real)) ; failed until sbcl-0.7.0.2
 160 (defgeneric born-to-be-redefined (x)
 161   (:method ((x integer))
 162     'integer))
 163 (defmethod born-to-be-redefined ((x integer))
 164   'int)
 165 (assert (eq (born-to-be-redefined 1) 'int))
 166 (defgeneric born-to-be-redefined (x))
 167 (assert (eq (born-to-be-redefined 1) 'int))
 168 \f
 169 ;;; In the removal of ITERATE from SB-PCL, a bug was introduced
 170 ;;; preventing forward-references and also change-class (which
 171 ;;; forward-references used interally) from working properly.  One
 172 ;;; symptom was reported by Brian Spilsbury (sbcl-devel 2002-04-08),
 173 ;;; and another on IRC by Dan Barlow simultaneously.  Better check
 174 ;;; that it doesn't happen again.
 175 ;;;
 176 ;;; First, the forward references:
 177 (defclass forward-ref-a (forward-ref-b) ())
 178 (defclass forward-ref-b () ())
 179 ;;; (a couple more complicated examples found by Paul Dietz' test
 180 ;;; suite):
 181 (defclass forward-ref-c1 (forward-ref-c2) ())
 182 (defclass forward-ref-c2 (forward-ref-c3) ())
 183
 184 (defclass forward-ref-d1 (forward-ref-d2 forward-ref-d3) ())
 185 (defclass forward-ref-d2 (forward-ref-d4 forward-ref-d5) ())
 186
 187 ;;; Then change-class
 188 (defclass class-with-slots ()
 189   ((a-slot :initarg :a-slot :accessor a-slot)
 190    (b-slot :initarg :b-slot :accessor b-slot)
 191    (c-slot :initarg :c-slot :accessor c-slot)))
 192
 193 (let ((foo (make-instance 'class-with-slots
 194                           :a-slot 1
 195                           :b-slot 2
 196                           :c-slot 3)))
 197   (let ((bar (change-class foo 'class-with-slots)))
 198     (assert (= (a-slot bar) 1))
 199     (assert (= (b-slot bar) 2))
 200     (assert (= (c-slot bar) 3))))
 201
 202 ;;; some more CHANGE-CLASS testing, now that we have an ANSI-compliant
 203 ;;; version (thanks to Espen Johnsen)
 204 (defclass from-class ()
 205   ((foo :initarg :foo :accessor foo)))
 206 (defclass to-class ()
 207   ((foo :initarg :foo :accessor foo)
 208    (bar :initarg :bar :accessor bar)))
 209 (let* ((from (make-instance 'from-class :foo 1))
 210        (to (change-class from 'to-class :bar 2)))
 211   (assert (= (foo to) 1))
 212   (assert (= (bar to) 2)))
 213
 214 ;;; Until Pierre Mai's patch (sbcl-devel 2002-06-18, merged in
 215 ;;; sbcl-0.7.4.39) the :MOST-SPECIFIC-LAST option had no effect.
 216 (defgeneric bug180 (x)
 217   (:method-combination list :most-specific-last))
 218 (defmethod bug180 list ((x number))
 219   'number)
 220 (defmethod bug180 list ((x fixnum))
 221   'fixnum)
 222 (assert (equal (bug180 14) '(number fixnum)))
 223 \f
 224 ;;; printing a structure class should not loop indefinitely (or cause
 225 ;;; a stack overflow):
 226 (defclass test-printing-structure-class ()
 227   ((slot :initarg :slot))
 228   (:metaclass structure-class))
 229 (print (make-instance 'test-printing-structure-class :slot 2))
 230
 231 ;;; structure-classes should behave nicely when subclassed
 232 (defclass super-structure ()
 233   ((a :initarg :a :accessor a-accessor)
 234    (b :initform 2 :reader b-reader))
 235   (:metaclass structure-class))
 236 (defclass sub-structure (super-structure)
 237   ((c :initarg :c :writer c-writer :accessor c-accessor))
 238   (:metaclass structure-class))
 239 (let ((foo (make-instance 'sub-structure :a 1 :c 3)))
 240   (assert (= (a-accessor foo) 1))
 241   (assert (= (b-reader foo) 2))
 242   (assert (= (c-accessor foo) 3))
 243   (setf (a-accessor foo) 4)
 244   (c-writer 5 foo)
 245   (assert (= (a-accessor foo) 4))
 246   (assert (= (c-accessor foo) 5)))
 247 \f
 248 ;;; At least as of sbcl-0.7.4, PCL has code to support a special
 249 ;;; encoding of effective method functions for slot accessors as
 250 ;;; FIXNUMs. Given this special casing, it'd be easy for slot accessor
 251 ;;; functions to get broken in special ways even though ordinary
 252 ;;; generic functions work. As of sbcl-0.7.4 we didn't have any tests
 253 ;;; for that possibility. Now we have a few tests:
 254 (defclass fish ()
 255   ((fin :reader ffin :writer ffin!)
 256    (tail :reader ftail :writer ftail!)))
 257 (defvar *fish* (make-instance 'fish))
 258 (ffin! 'triangular-fin *fish*)
 259 (defclass cod (fish) ())
 260 (defvar *cod* (make-instance 'cod))
 261 (defparameter *clos-dispatch-side-fx* (make-array 0 :fill-pointer 0))
 262 (defmethod ffin! (new-fin (cod cod))
 263   (format t "~&about to set ~S fin to ~S~%" cod new-fin)
 264   (vector-push-extend '(cod) *clos-dispatch-side-fx*)
 265   (prog1
 266       (call-next-method)
 267     (format t "~&done setting ~S fin to ~S~%" cod new-fin)))
 268 (defmethod ffin! :before (new-fin (cod cod))
 269   (vector-push-extend '(:before cod) *clos-dispatch-side-fx*)
 270   (format t "~&exploring the CLOS dispatch zoo with COD fins~%"))
 271 (ffin! 'almost-triang-fin *cod*)
 272 (assert (eq (ffin *cod*) 'almost-triang-fin))
 273 (assert (equalp #((:before cod) (cod)) *clos-dispatch-side-fx*))
 274 \f
 275 ;;; Until sbcl-0.7.6.21, the long form of DEFINE-METHOD-COMBINATION
 276 ;;; ignored its options; Gerd Moellmann found and fixed the problem
 277 ;;; for cmucl (cmucl-imp 2002-06-18).
 278 (define-method-combination test-mc (x)
 279   ;; X above being a method-group-specifier
 280   ((primary () :required t))
 281   `(call-method ,(first primary)))
 282
 283 (defgeneric gf (obj)
 284   (:method-combination test-mc 1))
 285
 286 (defmethod gf (obj)
 287   obj)
 288 \f
 289 ;;; Until sbcl-0.7.7.20, some conditions weren't being signalled, and
 290 ;;; some others were of the wrong type:
 291 (macrolet ((assert-program-error (form)
 292              `(multiple-value-bind (value error)
 293                   (ignore-errors ,form)
 294                 (unless (and (null value) (typep error 'program-error))
 295                   (error "~S failed: ~S, ~S" ',form value error)))))
 296   (assert-program-error (defclass foo001 () (a b a)))
 297   (assert-program-error (defclass foo002 ()
 298                           (a b)
 299                           (:default-initargs x 'a x 'b)))
 300   (assert-program-error (defclass foo003 ()
 301                           ((a :allocation :class :allocation :class))))
 302   (assert-program-error (defclass foo004 ()
 303                           ((a :silly t))))
 304   ;; and some more, found by Wolfhard Buss and fixed for cmucl by Gerd
 305   ;; Moellmann in sbcl-0.7.8.x:
 306   (assert-program-error (progn
 307                           (defmethod odd-key-args-checking (&key (key 42)) key)
 308                           (odd-key-args-checking 3)))
 309   (assert (= (odd-key-args-checking) 42))
 310   (assert (eq (odd-key-args-checking :key t) t))
 311   ;; yet some more, fixed in sbcl-0.7.9.xx
 312   (assert-program-error (defclass foo005 ()
 313                           (:metaclass sb-pcl::funcallable-standard-class)
 314                           (:metaclass 1)))
 315   (assert-program-error (defclass foo006 ()
 316                           ((a :reader (setf a)))))
 317   (assert-program-error (defclass foo007 ()
 318                           ((a :initarg 1))))
 319   (assert-program-error (defclass foo008 ()
 320                           (a :initarg :a)
 321                           (:default-initargs :a 1)
 322                           (:default-initargs :a 2)))
 323   ;; and also BUG 47d, fixed in sbcl-0.8alpha.0.26
 324   (assert-program-error (defgeneric if (x)))
 325   ;; DEFCLASS should detect an error if slot names aren't suitable as
 326   ;; variable names:
 327   (assert-program-error (defclass foo009 ()
 328                           ((:a :initarg :a))))
 329   (assert-program-error (defclass foo010 ()
 330                           (("a" :initarg :a))))
 331   (assert-program-error (defclass foo011 ()
 332                           ((#1a() :initarg :a))))
 333   (assert-program-error (defclass foo012 ()
 334                           ((t :initarg :t))))
 335   (assert-program-error (defclass foo013 () ("a")))
 336   ;; specialized lambda lists have certain restrictions on ordering,
 337   ;; repeating keywords, and the like:
 338   (assert-program-error (defmethod foo014 ((foo t) &rest) nil))
 339   (assert-program-error (defmethod foo015 ((foo t) &rest x y) nil))
 340   (assert-program-error (defmethod foo016 ((foo t) &allow-other-keys) nil))
 341   (assert-program-error (defmethod foo017 ((foo t)
 342                                            &optional x &optional y) nil))
 343   (assert-program-error (defmethod foo018 ((foo t) &rest x &rest y) nil))
 344   (assert-program-error (defmethod foo019 ((foo t) &rest x &optional y) nil))
 345   (assert-program-error (defmethod foo020 ((foo t) &key x &optional y) nil))
 346   (assert-program-error (defmethod foo021 ((foo t) &key x &rest y) nil)))
 347 \f
 348 ;;; DOCUMENTATION's argument-precedence-order wasn't being faithfully
 349 ;;; preserved through the bootstrap process until sbcl-0.7.8.39.
 350 ;;; (thanks to Gerd Moellmann)
 351 (let ((answer (documentation '+ 'function)))
 352   (assert (stringp answer))
 353   (defmethod documentation ((x (eql '+)) y) "WRONG")
 354   (assert (string= (documentation '+ 'function) answer)))
 355 \f
 356 ;;; only certain declarations are permitted in DEFGENERIC
 357 (macrolet ((assert-program-error (form)
 358              `(multiple-value-bind (value error)
 359                   (ignore-errors ,form)
 360                 (assert (null value))
 361                 (assert (typep error 'program-error)))))
 362   (assert-program-error (defgeneric bogus-declaration (x)
 363                           (declare (special y))))
 364   (assert-program-error (defgeneric bogus-declaration2 (x)
 365                           (declare (notinline concatenate)))))
 366 ;;; CALL-NEXT-METHOD should call NO-NEXT-METHOD if there is no next
 367 ;;; method.
 368 (defmethod no-next-method-test ((x integer)) (call-next-method))
 369 (assert (null (ignore-errors (no-next-method-test 1))))
 370 (defmethod no-next-method ((g (eql #'no-next-method-test)) m &rest args)
 371   'success)
 372 (assert (eq (no-next-method-test 1) 'success))
 373 (assert (null (ignore-errors (no-next-method-test 'foo))))
 374 \f
 375 ;;; regression test for bug 176, following a fix that seems
 376 ;;; simultaneously to fix 140 while not exposing 176 (by Gerd
 377 ;;; Moellmann, merged in sbcl-0.7.9.12).
 378 (dotimes (i 10)
 379   (let ((lastname (intern (format nil "C176-~D" (1- i))))
 380         (name (intern (format nil "C176-~D" i))))
 381   (eval `(defclass ,name
 382              (,@(if (= i 0) nil (list lastname)))
 383            ()))
 384   (eval `(defmethod initialize-instance :after ((x ,name) &rest any)
 385            (declare (ignore any))))))
 386 (defclass b176 () (aslot-176))
 387 (defclass c176-0 (b176) ())
 388 (assert (= 1 (setf (slot-value (make-instance 'c176-9) 'aslot-176) 1)))
 389 \f
 390 ;;; DEFINE-METHOD-COMBINATION was over-eager at checking for duplicate
 391 ;;; primary methods:
 392 (define-method-combination dmc-test-mc (&optional (order :most-specific-first))
 393   ((around (:around))
 394    (primary (dmc-test-mc) :order order :required t))
 395    (let ((form (if (rest primary)
 396                    `(and ,@(mapcar #'(lambda (method)
 397                                        `(call-method ,method))
 398                                    primary))
 399                    `(call-method ,(first primary)))))
 400      (if around
 401          `(call-method ,(first around)
 402                        (,@(rest around)
 403                         (make-method ,form)))
 404          form)))
 405
 406 (defgeneric dmc-test-mc (&key k)
 407   (:method-combination dmc-test-mc))
 408
 409 (defmethod dmc-test-mc dmc-test-mc (&key k)
 410            k)
 411
 412 (dmc-test-mc :k 1)
 413 ;;; While I'm at it, DEFINE-METHOD-COMBINATION is defined to return
 414 ;;; the NAME argument, not some random method object. So:
 415 (assert (eq (define-method-combination dmc-test-return-foo)
 416             'dmc-test-return-foo))
 417 (assert (eq (define-method-combination dmc-test-return-bar :operator and)
 418             'dmc-test-return-bar))
 419 (assert (eq (define-method-combination dmc-test-return
 420                 (&optional (order :most-specific-first))
 421               ((around (:around))
 422                (primary (dmc-test-return) :order order :required t))
 423               (let ((form (if (rest primary)
 424                               `(and ,@(mapcar #'(lambda (method)
 425                                                   `(call-method ,method))
 426                                               primary))
 427                               `(call-method ,(first primary)))))
 428                 (if around
 429                     `(call-method ,(first around)
 430                       (,@(rest around)
 431                        (make-method ,form)))
 432                     form)))
 433             'dmc-test-return))
 434 \f
 435 ;;; DEFINE-METHOD-COMBINATION should, according to the description in 7.7,
 436 ;;; allow you to do everything in the body forms yourself if you specify
 437 ;;; exactly one method group whose qualifier-pattern is *
 438 ;;;
 439 ;;; The specific language is:
 440 ;;; "The use of method group specifiers provides a convenient syntax to select
 441 ;;; methods, to divide them among the possible roles, and to perform the
 442 ;;; necessary error checking. It is possible to perform further filtering of
 443 ;;; methods in the body forms by using normal list-processing operations and
 444 ;;; the functions method-qualifiers and invalid-method-error. It is permissible
 445 ;;; to use setq on the variables named in the method group specifiers and to
 446 ;;; bind additional variables. It is also possible to bypass the method group
 447 ;;; specifier mechanism and do everything in the body forms. This is
 448 ;;; accomplished by writing a single method group with * as its only
 449 ;;; qualifier-pattern; the variable is then bound to a list of all of the
 450 ;;; applicable methods, in most-specific-first order."
 451 (define-method-combination wam-test-method-combination-a ()
 452   ((all-methods *))
 453   (do ((methods all-methods (rest methods))
 454        (primary nil)
 455        (around nil))
 456       ((null methods)
 457        (let ((primary (nreverse primary))
 458              (around (nreverse around)))
 459          (if primary
 460               (let ((form (if (rest primary)
 461                              `(call-method ,(first primary) ,(rest primary))
 462                              `(call-method ,(first primary)))))
 463                 (if around
 464                     `(call-method ,(first around) (,@(rest around)
 465                                                    (make-method ,form)))
 466                     form))
 467               `(make-method (error "No primary methods")))))
 468     (let* ((method (first methods))
 469            (qualifier (first (method-qualifiers method))))
 470       (cond
 471         ((equal :around qualifier)
 472          (push method around))
 473         ((null qualifier)
 474          (push method primary))))))
 475
 476 (defgeneric wam-test-mc-a (val)
 477   (:method-combination wam-test-method-combination-a))
 478 (assert (raises-error? (wam-test-mc-a 13)))
 479 (defmethod wam-test-mc-a ((val number))
 480   (+ val (if (next-method-p) (call-next-method) 0)))
 481 (assert (= (wam-test-mc-a 13) 13))
 482 (defmethod wam-test-mc-a :around ((val number))
 483   (+ val (if (next-method-p) (call-next-method) 0)))
 484 (assert (= (wam-test-mc-a 13) 26))
 485
 486 ;;; DEFINE-METHOD-COMBINATION
 487 ;;; When two methods are in the same method group and have the same
 488 ;;; specializers, their sort order within the group may be ambiguous. Therefore,
 489 ;;; we should throw an error when we have two methods in the same group with
 490 ;;; the same specializers /as long as/ we have more than one method group
 491 ;;; or our single method group qualifier-pattern is not *. This resolves the
 492 ;;; apparent conflict with the above 'It is also possible to bypass' language.
 493 ;;;
 494 ;;; The language specifying this behavior is:
 495 ;;; "Note that two methods with identical specializers, but with different
 496 ;;; qualifiers, are not ordered by the algorithm described in Step 2 of the
 497 ;;; method selection and combination process described in Section 7.6.6
 498 ;;; (Method Selection and Combination). Normally the two methods play different
 499 ;;; roles in the effective method because they have different qualifiers, and
 500 ;;; no matter how they are ordered in the result of Step 2, the effective
 501 ;;; method is the same. If the two methods play the same role and their order
 502 ;;; matters, an error is signaled. This happens as part of the qualifier
 503 ;;; pattern matching in define-method-combination."
 504 ;;;
 505 ;;; Note that the spec pretty much equates 'method group' and 'role'.
 506 ;; First we ensure that it fails correctly when there is more than one
 507 ;; method group
 508 (define-method-combination wam-test-method-combination-b ()
 509   ((around (:around))
 510    (primary * :required t))
 511   (let ((form (if (rest primary)
 512                   `(call-method ,(first primary) ,(rest primary))
 513                   `(call-method ,(first primary)))))
 514     (if around
 515         `(call-method ,(first around) (,@(rest around)
 516                                        (make-method ,form)))
 517         form)))
 518
 519 (defgeneric wam-test-mc-b (val)
 520   (:method-combination wam-test-method-combination-b))
 521 (defmethod wam-test-mc-b ((val number))
 522   (+ val (if (next-method-p) (call-next-method) 0)))
 523 (assert (= (wam-test-mc-b 13) 13))
 524 (defmethod wam-test-mc-b :around ((val number))
 525   (+ val (if (next-method-p) (call-next-method) 0)))
 526 (assert (= (wam-test-mc-b 13) 26))
 527 (defmethod wam-test-mc-b :somethingelse ((val number))
 528   (+ val (if (next-method-p) (call-next-method) 0)))
 529 (assert (raises-error? (wam-test-mc-b 13)))
 530
 531 ;;; now, ensure that it fails with a single group with a qualifier-pattern
 532 ;;; that is not *
 533 (define-method-combination wam-test-method-combination-c ()
 534   ((methods listp :required t))
 535   (if (rest methods)
 536       `(call-method ,(first methods) ,(rest methods))
 537       `(call-method ,(first methods))))
 538
 539 (defgeneric wam-test-mc-c (val)
 540   (:method-combination wam-test-method-combination-c))
 541 (assert (raises-error? (wam-test-mc-c 13)))
 542 (defmethod wam-test-mc-c :foo ((val number))
 543   (+ val (if (next-method-p) (call-next-method) 0)))
 544 (assert (= (wam-test-mc-c 13) 13))
 545 (defmethod wam-test-mc-c :bar ((val number))
 546   (+ val (if (next-method-p) (call-next-method) 0)))
 547 (assert (raises-error? (wam-test-mc-c 13)))
 548
 549 ;;; DEFMETHOD should signal an ERROR if an incompatible lambda list is
 550 ;;; given:
 551 (defmethod incompatible-ll-test-1 (x) x)
 552 (assert (raises-error? (defmethod incompatible-ll-test-1 (x y) y)))
 553 (assert (raises-error? (defmethod incompatible-ll-test-1 (x &rest y) y)))
 554 ;;; Sneakily using a bit of MOPness to check some consistency
 555 (assert (= (length
 556             (sb-pcl:generic-function-methods #'incompatible-ll-test-1)) 1))
 557
 558 (defmethod incompatible-ll-test-2 (x &key bar) bar)
 559 (assert (raises-error? (defmethod incompatible-ll-test-2 (x) x)))
 560 (defmethod incompatible-ll-test-2 (x &rest y) y)
 561 (assert (= (length
 562             (sb-pcl:generic-function-methods #'incompatible-ll-test-2)) 1))
 563 (defmethod incompatible-ll-test-2 ((x integer) &key bar) bar)
 564 (assert (= (length
 565             (sb-pcl:generic-function-methods #'incompatible-ll-test-2)) 2))
 566
 567 ;;; Per Christophe, this is an illegal method call because of 7.6.5
 568 (assert (raises-error? (incompatible-ll-test-2 t 1 2)))
 569
 570 (assert (eq (incompatible-ll-test-2 1 :bar 'yes) 'yes))
 571
 572 (defmethod incompatible-ll-test-3 ((x integer)) x)
 573 (remove-method #'incompatible-ll-test-3
 574                (find-method #'incompatible-ll-test-3
 575                             nil
 576                             (list (find-class 'integer))))
 577 (assert (raises-error? (defmethod incompatible-ll-test-3 (x y) (list x y))))
 578
 579 \f
 580 ;;; Attempting to instantiate classes with forward references in their
 581 ;;; CPL should signal errors (FIXME: of what type?)
 582 (defclass never-finished-class (this-one-unfinished-too) ())
 583 (multiple-value-bind (result error)
 584     (ignore-errors (make-instance 'never-finished-class))
 585   (assert (null result))
 586   (assert (typep error 'error)))
 587 (multiple-value-bind (result error)
 588     (ignore-errors (make-instance 'this-one-unfinished-too))
 589   (assert (null result))
 590   (assert (typep error 'error)))
 591 \f
 592 ;;; Classes with :ALLOCATION :CLASS slots should be subclassable (and
 593 ;;; weren't for a while in sbcl-0.7.9.xx)
 594 (defclass superclass-with-slot ()
 595   ((a :allocation :class)))
 596 (defclass subclass-for-class-allocation (superclass-with-slot) ())
 597 (make-instance 'subclass-for-class-allocation)
 598 \f
 599 ;;; bug #136: CALL-NEXT-METHOD was being a little too lexical,
 600 ;;; resulting in failure in the following:
 601 (defmethod call-next-method-lexical-args ((x integer))
 602   x)
 603 (defmethod call-next-method-lexical-args :around ((x integer))
 604   (let ((x (1+ x)))
 605     (call-next-method)))
 606 (assert (= (call-next-method-lexical-args 3) 3))
 607 \f
 608 ;;; DEFINE-METHOD-COMBINATION with arguments was hopelessly broken
 609 ;;; until 0.7.9.5x
 610 (defvar *d-m-c-args-test* nil)
 611 (define-method-combination progn-with-lock ()
 612   ((methods ()))
 613   (:arguments object)
 614   `(unwind-protect
 615     (progn (lock (object-lock ,object))
 616            ,@(mapcar #'(lambda (method)
 617                          `(call-method ,method))
 618                      methods))
 619     (unlock (object-lock ,object))))
 620 (defun object-lock (obj)
 621   (push "object-lock" *d-m-c-args-test*)
 622   obj)
 623 (defun unlock (obj)
 624   (push "unlock" *d-m-c-args-test*)
 625   obj)
 626 (defun lock (obj)
 627   (push "lock" *d-m-c-args-test*)
 628   obj)
 629 (defgeneric d-m-c-args-test (x)
 630   (:method-combination progn-with-lock))
 631 (defmethod d-m-c-args-test ((x symbol))
 632   (push "primary" *d-m-c-args-test*))
 633 (defmethod d-m-c-args-test ((x number))
 634   (error "foo"))
 635 (assert (equal (d-m-c-args-test t) '("primary" "lock" "object-lock")))
 636 (assert (equal *d-m-c-args-test*
 637                '("unlock" "object-lock" "primary" "lock" "object-lock")))
 638 (setf *d-m-c-args-test* nil)
 639 (ignore-errors (d-m-c-args-test 1))
 640 (assert (equal *d-m-c-args-test*
 641                '("unlock" "object-lock" "lock" "object-lock")))
 642 \f
 643 ;;; The walker (on which DEFMETHOD depended) didn't know how to handle
 644 ;;; SYMBOL-MACROLET properly.  In fact, as of sbcl-0.7.10.20 it still
 645 ;;; doesn't, but it does well enough to compile the following without
 646 ;;; error (the problems remain in asking for a complete macroexpansion
 647 ;;; of an arbitrary form).
 648 (symbol-macrolet ((x 1))
 649   (defmethod bug222 (z)
 650     (macrolet ((frob (form) `(progn ,form ,x)))
 651       (frob (print x)))))
 652 (assert (= (bug222 t) 1))
 653
 654 ;;; also, a test case to guard against bogus environment hacking:
 655
 656 (eval-when (:compile-toplevel :load-toplevel :execute)
 657   (setq bug222-b 3))
 658 ;;; this should at the least compile:
 659 (let ((bug222-b 1))
 660   (defmethod bug222-b (z stream)
 661     (macrolet ((frob (form) `(progn ,form ,bug222-b)))
 662       (frob (format stream "~D~%" bug222-b)))))
 663 ;;; and it would be nice (though not specified by ANSI) if the answer
 664 ;;; were as follows:
 665 (let ((x (make-string-output-stream)))
 666   (let ((value (bug222-b t x)))
 667     ;; not specified by ANSI
 668     #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
 669     (assert (= value 3)))
 670   ;; specified.
 671   (assert (char= (char (get-output-stream-string x) 0) #\1)))
 672 \f
 673 ;;; REINITIALIZE-INSTANCE, in the ctor optimization, wasn't checking
 674 ;;; for invalid initargs where it should:
 675 (defclass class234 () ())
 676 (defclass subclass234 (class234) ())
 677 (defvar *bug234* 0)
 678 (defun bug-234 ()
 679   (reinitialize-instance (make-instance 'class234) :dummy 0))
 680 (defun subbug-234 ()
 681   (reinitialize-instance (make-instance 'subclass234) :dummy 0))
 682 (assert (raises-error? (bug-234) program-error))
 683 (defmethod shared-initialize :after ((i class234) slots &key dummy)
 684   (incf *bug234*))
 685 (assert (typep (subbug-234) 'subclass234))
 686 (assert (= *bug234*
 687            ;; once for MAKE-INSTANCE, once for REINITIALIZE-INSTANCE
 688            2))
 689
 690 ;;; also, some combinations of MAKE-INSTANCE and subclassing missed
 691 ;;; new methods (Gerd Moellmann sbcl-devel 2002-12-29):
 692 (defclass class234-b1 () ())
 693 (defclass class234-b2 (class234-b1) ())
 694 (defvar *bug234-b* 0)
 695 (defun bug234-b ()
 696   (make-instance 'class234-b2))
 697 (compile 'bug234-b)
 698 (bug234-b)
 699 (assert (= *bug234-b* 0))
 700 (defmethod initialize-instance :before ((x class234-b1) &rest args)
 701   (declare (ignore args))
 702   (incf *bug234-b*))
 703 (bug234-b)
 704 (assert (= *bug234-b* 1))
 705 \f
 706 ;;; we should be able to make classes with uninterned names:
 707 (defclass #:class-with-uninterned-name () ())
 708 \f
 709 ;;; SLOT-MISSING should be called when there are missing slots.
 710 (defclass class-with-all-slots-missing () ())
 711 (defmethod slot-missing (class (o class-with-all-slots-missing)
 712                          slot-name op
 713                          &optional new-value)
 714   op)
 715 (assert (eq (slot-value (make-instance 'class-with-all-slots-missing) 'foo)
 716             'slot-value))
 717 (assert (eq (funcall (lambda (x) (slot-value x 'bar))
 718                      (make-instance 'class-with-all-slots-missing))
 719             'slot-value))
 720 (assert (eq (funcall (lambda (x) (setf (slot-value x 'baz) 'baz))
 721                      (make-instance 'class-with-all-slots-missing))
 722             ;; SLOT-MISSING's value is specified to be ignored; we
 723             ;; return NEW-VALUE.
 724             'baz))
 725 \f
 726 ;;; we should be able to specialize on anything that names a class.
 727 (defclass name-for-class () ())
 728 (defmethod something-that-specializes ((x name-for-class)) 1)
 729 (setf (find-class 'other-name-for-class) (find-class 'name-for-class))
 730 (defmethod something-that-specializes ((x other-name-for-class)) 2)
 731 (assert (= (something-that-specializes (make-instance 'name-for-class)) 2))
 732 (assert (= (something-that-specializes (make-instance 'other-name-for-class))
 733            2))
 734 \f
 735 ;;; more forward referenced classes stuff
 736 (defclass frc-1 (frc-2) ())
 737 (assert (subtypep 'frc-1 (find-class 'frc-2)))
 738 (assert (subtypep (find-class 'frc-1) 'frc-2))
 739 (assert (not (subtypep (find-class 'frc-2) 'frc-1)))
 740 (defclass frc-2 (frc-3) ((a :initarg :a)))
 741 (assert (subtypep 'frc-1 (find-class 'frc-3)))
 742 (defclass frc-3 () ())
 743 (assert (typep (make-instance 'frc-1 :a 2) (find-class 'frc-1)))
 744 (assert (typep (make-instance 'frc-2 :a 3) (find-class 'frc-2)))
 745 \f
 746 ;;; check that we can define classes with two slots of different names
 747 ;;; (even if it STYLE-WARNs).
 748 (defclass odd-name-class ()
 749   ((name :initarg :name)
 750    (cl-user::name :initarg :name2)))
 751 (let ((x (make-instance 'odd-name-class :name 1 :name2 2)))
 752   (assert (= (slot-value x 'name) 1))
 753   (assert (= (slot-value x 'cl-user::name) 2)))
 754 \f
 755 ;;; ALLOCATE-INSTANCE should work on structures, even if defined by
 756 ;;; DEFSTRUCT (and not DEFCLASS :METACLASS STRUCTURE-CLASS).
 757 (defstruct allocatable-structure a)
 758 (assert (typep (allocate-instance (find-class 'allocatable-structure))
 759                'allocatable-structure))
 760 \f
 761 ;;; Bug found by Paul Dietz when devising CPL tests: somewhat
 762 ;;; amazingly, calls to CPL would work a couple of times, and then
 763 ;;; start returning NIL.  A fix was found (relating to the
 764 ;;; applicability of constant-dfun optimization) by Gerd Moellmann.
 765 (defgeneric cpl (x)
 766   (:method-combination list)
 767   (:method list ((x broadcast-stream)) 'broadcast-stream)
 768   (:method list ((x integer)) 'integer)
 769   (:method list ((x number)) 'number)
 770   (:method list ((x stream)) 'stream)
 771   (:method list ((x structure-object)) 'structure-object))
 772 (assert (equal (cpl 0) '(integer number)))
 773 (assert (equal (cpl 0) '(integer number)))
 774 (assert (equal (cpl 0) '(integer number)))
 775 (assert (equal (cpl 0) '(integer number)))
 776 (assert (equal (cpl 0) '(integer number)))
 777 (assert (equal (cpl (make-broadcast-stream))
 778                '(broadcast-stream stream structure-object)))
 779 (assert (equal (cpl (make-broadcast-stream))
 780                '(broadcast-stream stream structure-object)))
 781 (assert (equal (cpl (make-broadcast-stream))
 782                '(broadcast-stream stream structure-object)))
 783 \f
 784 ;;; Bug in CALL-NEXT-METHOD: assignment to the method's formal
 785 ;;; parameters shouldn't affect the arguments to the next method for a
 786 ;;; no-argument call to CALL-NEXT-METHOD
 787 (defgeneric cnm-assignment (x)
 788   (:method (x) x)
 789   (:method ((x integer)) (setq x 3)
 790            (list x (call-next-method) (call-next-method x))))
 791 (assert (equal (cnm-assignment 1) '(3 1 3)))
 792 \f
 793 ;;; Bug reported by Istvan Marko 2003-07-09
 794 (let ((class-name (gentemp)))
 795   (loop for i from 1 to 9
 796         for slot-name = (intern (format nil "X~D" i))
 797         for initarg-name = (intern (format nil "X~D" i) :keyword)
 798         collect `(,slot-name :initarg ,initarg-name) into slot-descs
 799         append `(,initarg-name (list 0)) into default-initargs
 800         finally (eval `(defclass ,class-name ()
 801                          (,@slot-descs)
 802                          (:default-initargs ,@default-initargs))))
 803   (let ((f (compile nil `(lambda () (make-instance ',class-name)))))
 804     (assert (typep (funcall f) class-name))))
 805
 806 ;;; bug 262: DEFMETHOD failed on a generic function without a lambda
 807 ;;; list
 808 (ensure-generic-function 'bug262)
 809 (defmethod bug262 (x y)
 810   (list x y))
 811 (assert (equal (bug262 1 2) '(1 2)))
 812
 813 ;;; salex on #lisp 2003-10-13 reported that type declarations inside
 814 ;;; WITH-SLOTS are too hairy to be checked
 815 (defun ensure-no-notes (form)
 816   (handler-case (compile nil `(lambda () ,form))
 817     (sb-ext:compiler-note (c)
 818       ;; FIXME: it would be better to check specifically for the "type
 819       ;; is too hairy" note
 820       (error c))))
 821 (defvar *x*)
 822 (ensure-no-notes '(with-slots (a) *x*
 823                    (declare (integer a))
 824                    a))
 825 (ensure-no-notes '(with-slots (a) *x*
 826                    (declare (integer a))
 827                    (declare (notinline slot-value))
 828                    a))
 829
 830 ;;; from CLHS 7.6.5.1
 831 (defclass character-class () ((char :initarg :char)))
 832 (defclass picture-class () ((glyph :initarg :glyph)))
 833 (defclass character-picture-class (character-class picture-class) ())
 834
 835 (defmethod width ((c character-class) &key font) font)
 836 (defmethod width ((p picture-class) &key pixel-size) pixel-size)
 837
 838 (assert (raises-error?
 839          (width (make-instance 'character-class :char #\Q)
 840                 :font 'baskerville :pixel-size 10)
 841          program-error))
 842 (assert (raises-error?
 843          (width (make-instance 'picture-class :glyph #\Q)
 844                 :font 'baskerville :pixel-size 10)
 845          program-error))
 846 (assert (eq (width (make-instance 'character-picture-class :char #\Q)
 847                    :font 'baskerville :pixel-size 10)
 848             'baskerville))
 849
 850 ;;; class redefinition shouldn't give any warnings, in the usual case
 851 (defclass about-to-be-redefined () ((some-slot :accessor some-slot)))
 852 (handler-bind ((warning #'error))
 853   (defclass about-to-be-redefined () ((some-slot :accessor some-slot))))
 854
 855 ;;; attempts to add accessorish methods to generic functions with more
 856 ;;; complex lambda lists should fail
 857 (defgeneric accessoroid (object &key &allow-other-keys))
 858 (assert (raises-error?
 859          (defclass accessoroid-class () ((slot :accessor accessoroid)))
 860          program-error))
 861
 862 ;;; reported by Bruno Haible sbcl-devel 2004-04-15
 863 (defclass shared-slot-and-redefinition ()
 864   ((size :initarg :size :initform 1 :allocation :class)))
 865 (let ((i (make-instance 'shared-slot-and-redefinition)))
 866   (defclass shared-slot-and-redefinition ()
 867     ((size :initarg :size :initform 2 :allocation :class)))
 868   (assert (= (slot-value i 'size) 1)))
 869
 870 ;;; reported by Bruno Haible sbcl-devel 2004-04-15
 871 (defclass superclass-born-to-be-obsoleted () (a))
 872 (defclass subclass-born-to-be-obsoleted (superclass-born-to-be-obsoleted) ())
 873 (defparameter *born-to-be-obsoleted*
 874   (make-instance 'subclass-born-to-be-obsoleted))
 875 (defparameter *born-to-be-obsoleted-obsoleted* nil)
 876 (defmethod update-instance-for-redefined-class
 877     ((o subclass-born-to-be-obsoleted) a d pl &key)
 878   (setf *born-to-be-obsoleted-obsoleted* t))
 879 (make-instances-obsolete 'superclass-born-to-be-obsoleted)
 880 (slot-boundp *born-to-be-obsoleted* 'a)
 881 (assert *born-to-be-obsoleted-obsoleted*)
 882
 883 ;;; additional test suggested by Bruno Haible sbcl-devel 2004-04-21
 884 (defclass super-super-obsoleted () (a))
 885 (defclass super-obsoleted-1 (super-super-obsoleted) ())
 886 (defclass super-obsoleted-2 (super-super-obsoleted) ())
 887 (defclass obsoleted (super-obsoleted-1 super-obsoleted-2) ())
 888 (defparameter *obsoleted* (make-instance 'obsoleted))
 889 (defparameter *obsoleted-counter* 0)
 890 (defmethod update-instance-for-redefined-class ((o obsoleted) a d pl &key)
 891   (incf *obsoleted-counter*))
 892 (make-instances-obsolete 'super-super-obsoleted)
 893 (slot-boundp *obsoleted* 'a)
 894 (assert (= *obsoleted-counter* 1))
 895
 896 ;;; yet another MAKE-INSTANCES-OBSOLETE test, this time from Nikodemus
 897 ;;; Siivola.  Not all methods for accessing slots are created equal...
 898 (defclass yet-another-obsoletion-super () ((obs :accessor obs-of :initform 0)))
 899 (defclass yet-another-obsoletion-sub (yet-another-obsoletion-super) ())
 900 (defmethod shared-initialize :after ((i yet-another-obsoletion-super)
 901                                      slots &rest init)
 902   (incf (obs-of i)))
 903
 904 (defvar *yao-super* (make-instance 'yet-another-obsoletion-super))
 905 (defvar *yao-sub* (make-instance 'yet-another-obsoletion-sub))
 906
 907 (assert (= (obs-of *yao-super*) 1))
 908 (assert (= (obs-of *yao-sub*) 1))
 909 (make-instances-obsolete 'yet-another-obsoletion-super)
 910 (assert (= (obs-of *yao-sub*) 2))
 911 (assert (= (obs-of *yao-super*) 2))
 912 (make-instances-obsolete 'yet-another-obsoletion-super)
 913 (assert (= (obs-of *yao-super*) 3))
 914 (assert (= (obs-of *yao-sub*) 3))
 915 (assert (= (slot-value *yao-super* 'obs) 3))
 916 (assert (= (slot-value *yao-sub* 'obs) 3))
 917
 918 ;;; shared -> local slot transfers of inherited slots, reported by
 919 ;;; Bruno Haible
 920 (let (i)
 921   (defclass super-with-magic-slot ()
 922     ((magic :initarg :size :initform 1 :allocation :class)))
 923   (defclass sub-of-super-with-magic-slot (super-with-magic-slot) ())
 924   (setq i (make-instance 'sub-of-super-with-magic-slot))
 925   (defclass super-with-magic-slot ()
 926     ((magic :initarg :size :initform 2)))
 927   (assert (= 1 (slot-value i 'magic))))
 928
 929 ;;; MAKE-INSTANCES-OBSOLETE return values
 930 (defclass one-more-to-obsolete () ())
 931 (assert (eq 'one-more-to-obsolete
 932             (make-instances-obsolete 'one-more-to-obsolete)))
 933 (assert (eq (find-class 'one-more-to-obsolete)
 934             (make-instances-obsolete (find-class 'one-more-to-obsolete))))
 935
 936 ;;; Sensible error instead of a BUG. Reported by Thomas Burdick.
 937 (multiple-value-bind (value err)
 938     (ignore-errors
 939       (defclass slot-def-with-duplicate-accessors ()
 940         ((slot :writer get-slot :reader get-slot))))
 941   (assert (typep err 'error))
 942   (assert (not (typep err 'sb-int:bug))))
 943
 944 ;;; BUG 321: errors in parsing DEFINE-METHOD-COMBINATION arguments
 945 ;;; lambda lists.
 946
 947 (define-method-combination w-args ()
 948   ((method-list *))
 949   (:arguments arg1 arg2 &aux (extra :extra))
 950   `(progn ,@(mapcar (lambda (method) `(call-method ,method)) method-list)))
 951 (defgeneric mc-test-w-args (p1 p2 s)
 952   (:method-combination w-args)
 953   (:method ((p1 number) (p2 t) s)
 954     (vector-push-extend (list 'number p1 p2) s))
 955   (:method ((p1 string) (p2 t) s)
 956     (vector-push-extend (list 'string p1 p2) s))
 957   (:method ((p1 t) (p2 t) s) (vector-push-extend (list t p1 p2) s)))
 958 (let ((v (make-array 0 :adjustable t :fill-pointer t)))
 959   (assert (= (mc-test-w-args 1 2 v) 1))
 960   (assert (equal (aref v 0) '(number 1 2)))
 961   (assert (equal (aref v 1) '(t 1 2))))
 962
 963 ;;; BUG 276: declarations and mutation.
 964 (defmethod fee ((x fixnum))
 965   (setq x (/ x 2))
 966   x)
 967 (assert (= (fee 1) 1/2))
 968 (defmethod fum ((x fixnum))
 969   (setf x (/ x 2))
 970   x)
 971 (assert (= (fum 3) 3/2))
 972 (defmethod fii ((x fixnum))
 973   (declare (special x))
 974   (setf x (/ x 2))
 975   x)
 976 (assert (= (fii 1) 1/2))
 977 (defvar *faa*)
 978 (defmethod faa ((*faa* string-stream))
 979   (setq *faa* (make-broadcast-stream *faa*))
 980   (write-line "Break, you sucker!" *faa*)
 981   'ok)
 982 (assert (eq 'ok (faa (make-string-output-stream))))
 983 (defmethod fex ((x fixnum) (y fixnum))
 984   (multiple-value-setq (x y) (values (/ x y) (/ y x)))
 985   (list x y))
 986 (assert (equal (fex 5 3) '(5/3 3/5)))
 987
 988 ;;; Bug reported by Zach Beane; incorrect return of (function
 989 ;;; ',fun-name) in defgeneric
 990 (assert
 991  (typep (funcall (compile nil
 992                           '(lambda () (flet ((nonsense () nil))
 993                                         (defgeneric nonsense ())))))
 994         'generic-function))
 995
 996 (assert
 997  (typep (funcall (compile nil
 998                           '(lambda () (flet ((nonsense-2 () nil))
 999                                         (defgeneric nonsense-2 ()
1000                                           (:method () t))))))
1001         'generic-function))
1002
1003 ;;; bug reported by Bruno Haible: (setf find-class) using a
1004 ;;; forward-referenced class
1005 (defclass fr-sub (fr-super) ())
1006 (setf (find-class 'fr-alt) (find-class 'fr-super))
1007 (assert (eq (find-class 'fr-alt) (find-class 'fr-super)))
1008
1009
1010 ;;; ANSI Figure 4-8: all defined classes.  Check that we can define
1011 ;;; methods on all of these.
1012 (progn
1013   (defgeneric method-for-defined-classes (x))
1014   (dolist (c '(arithmetic-error
1015                generic-function simple-error array hash-table
1016                simple-type-error
1017                bit-vector integer simple-warning
1018                broadcast-stream list standard-class
1019                built-in-class logical-pathname standard-generic-function
1020                cell-error method standard-method
1021                character method-combination standard-object
1022                class null storage-condition
1023                complex number stream
1024                concatenated-stream package stream-error
1025                condition package-error string
1026                cons parse-error string-stream
1027                control-error pathname structure-class
1028                division-by-zero print-not-readable structure-object
1029                echo-stream program-error style-warning
1030                end-of-file random-state symbol
1031                error ratio synonym-stream
1032                file-error rational t
1033                file-stream reader-error two-way-stream
1034                float readtable type-error
1035                floating-point-inexact real unbound-slot
1036                floating-point-invalid-operation restart unbound-variable
1037                floating-point-overflow sequence undefined-function
1038                floating-point-underflow serious-condition vector
1039                function simple-condition warning))
1040     (eval `(defmethod method-for-defined-classes ((x ,c)) (princ x))))
1041   (assert (string= (with-output-to-string (*standard-output*)
1042                      (method-for-defined-classes #\3))
1043                    "3")))
1044
1045
1046 \f
1047 ;;; When class definition does not complete due to a bad accessor
1048 ;;; name, do not cause an error when a new accessor name is provided
1049 ;;; during class redefinition
1050
1051 (defun existing-name (object)
1052   (list object))
1053
1054 (assert (raises-error? (defclass redefinition-of-accessor-class ()
1055                          ((slot :accessor existing-name)))))
1056
1057 (defclass redefinition-of-accessor-class ()
1058   ((slot :accessor new-name)))
1059
1060 \f
1061
1062 (load "package-ctor-bug.lisp")
1063 (assert (= (package-ctor-bug:test) 3))
1064 (delete-package "PACKAGE-CTOR-BUG")
1065 (load "package-ctor-bug.lisp")
1066 (assert (= (package-ctor-bug:test) 3))
1067
1068 (with-test (:name (:defmethod (setf find-class) integer))
1069   (mapcar #'eval
1070           '(
1071             (deftype defined-type () 'integer)
1072             (assert (raises-error?
1073                      (defmethod method-on-defined-type ((x defined-type)) x)))
1074             (deftype defined-type-and-class () 'integer)
1075             (setf (find-class 'defined-type-and-class) (find-class 'integer))
1076             (defmethod method-on-defined-type-and-class
1077                 ((x defined-type-and-class))
1078               (1+ x))
1079             (assert (= (method-on-defined-type-and-class 3) 4)))))
1080
1081 ;; bug 281
1082 (let ((sb-pcl::*max-emf-precomputation-methods* 0))
1083   (eval '(defgeneric bug-281 (x)
1084           (:method-combination +)
1085           (:method ((x symbol)) 1)
1086           (:method + ((x number)) x)))
1087   (assert (= 1 (bug-281 1)))
1088   (assert (= 4.2 (bug-281 4.2)))
1089   (multiple-value-bind (val err) (ignore-errors (bug-281 'symbol))
1090     (assert (not val))
1091     (assert (typep err 'error))))
1092 \f
1093 ;;; RESTART-CASE and CALL-METHOD
1094
1095 ;;; from Bruno Haible
1096
1097 (defun rc-cm/prompt-for-new-values ()
1098   (format *debug-io* "~&New values: ")
1099   (finish-output *debug-io*)
1100   (list (read *debug-io*)))
1101
1102 (defun rc-cm/add-method-restarts (form method)
1103   (let ((block (gensym))
1104         (tag (gensym)))
1105     `(block ,block
1106       (tagbody
1107          ,tag
1108          (return-from ,block
1109            (restart-case ,form
1110              (method-redo ()
1111                :report (lambda (stream)
1112                          (format stream "Try calling ~S again." ,method))
1113                (go ,tag))
1114              (method-return (l)
1115                :report (lambda (stream)
1116                          (format stream "Specify return values for ~S call."
1117                                  ,method))
1118                :interactive (lambda () (rc-cm/prompt-for-new-values))
1119                (return-from ,block (values-list l)))))))))
1120
1121 (defun rc-cm/convert-effective-method (efm)
1122   (if (consp efm)
1123       (if (eq (car efm) 'call-method)
1124           (let ((method-list (third efm)))
1125             (if (or (typep (first method-list) 'method) (rest method-list))
1126                 ;; Reduce the case of multiple methods to a single one.
1127                 ;; Make the call to the next-method explicit.
1128                 (rc-cm/convert-effective-method
1129                  `(call-method ,(second efm)
1130                    ((make-method
1131                      (call-method ,(first method-list) ,(rest method-list))))))
1132                 ;; Now the case of at most one method.
1133                 (if (typep (second efm) 'method)
1134                     ;; Wrap the method call in a RESTART-CASE.
1135                     (rc-cm/add-method-restarts
1136                      (cons (rc-cm/convert-effective-method (car efm))
1137                            (rc-cm/convert-effective-method (cdr efm)))
1138                      (second efm))
1139                     ;; Normal recursive processing.
1140                     (cons (rc-cm/convert-effective-method (car efm))
1141                           (rc-cm/convert-effective-method (cdr efm))))))
1142           (cons (rc-cm/convert-effective-method (car efm))
1143                 (rc-cm/convert-effective-method (cdr efm))))
1144       efm))
1145
1146 (define-method-combination standard-with-restarts ()
1147   ((around (:around))
1148    (before (:before))
1149    (primary () :required t)
1150    (after (:after)))
1151   (flet ((call-methods-sequentially (methods)
1152            (mapcar #'(lambda (method)
1153                        `(call-method ,method))
1154                    methods)))
1155     (let ((form (if (or before after (rest primary))
1156                     `(multiple-value-prog1
1157                        (progn
1158                          ,@(call-methods-sequentially before)
1159                          (call-method ,(first primary) ,(rest primary)))
1160                       ,@(call-methods-sequentially (reverse after)))
1161                     `(call-method ,(first primary)))))
1162       (when around
1163         (setq form
1164               `(call-method ,(first around)
1165                 (,@(rest around) (make-method ,form)))))
1166       (rc-cm/convert-effective-method form))))
1167
1168 (defgeneric rc-cm/testgf16 (x)
1169   (:method-combination standard-with-restarts))
1170 (defclass rc-cm/testclass16a () ())
1171 (defclass rc-cm/testclass16b (rc-cm/testclass16a) ())
1172 (defclass rc-cm/testclass16c (rc-cm/testclass16a) ())
1173 (defclass rc-cm/testclass16d (rc-cm/testclass16b rc-cm/testclass16c) ())
1174 (defmethod rc-cm/testgf16 ((x rc-cm/testclass16a))
1175   (list 'a
1176         (not (null (find-restart 'method-redo)))
1177         (not (null (find-restart 'method-return)))))
1178 (defmethod rc-cm/testgf16 ((x rc-cm/testclass16b))
1179   (cons 'b (call-next-method)))
1180 (defmethod rc-cm/testgf16 ((x rc-cm/testclass16c))
1181   (cons 'c (call-next-method)))
1182 (defmethod rc-cm/testgf16 ((x rc-cm/testclass16d))
1183   (cons 'd (call-next-method)))
1184 (assert (equal (rc-cm/testgf16 (make-instance 'rc-cm/testclass16d))
1185                '(d b c a t t)))
1186
1187 ;;; test case from Gerd Moellmann
1188 (define-method-combination r-c/c-m-1 ()
1189   ((primary () :required t))
1190   `(restart-case (call-method ,(first primary))
1191      ()))
1192
1193 (defgeneric r-c/c-m-1-gf ()
1194   (:method-combination r-c/c-m-1)
1195   (:method () nil))
1196
1197 (assert (null (r-c/c-m-1-gf)))
1198
1199 (handler-bind ((warning #'error))
1200   (eval '(defclass class-for-ctor/class-slot ()
1201           ((class-slot :initarg :class-slot :allocation :class))))
1202   (eval '(let ((c1 (make-instance 'class-for-ctor/class-slot))
1203                (c2 (make-instance 'class-for-ctor/class-slot :class-slot 1)))
1204           (assert (equal (list (slot-value c1 'class-slot)
1205                                (slot-value c2 'class-slot))
1206                    (list 1 1))))))
1207 \f
1208 ;;; tests of ctors on anonymous classes
1209 (defparameter *unnamed* (defclass ctor-unnamed-literal-class () ()))
1210 (setf (class-name *unnamed*) nil)
1211 (setf (find-class 'ctor-unnamed-literal-class) nil)
1212 (defparameter *unnamed2* (defclass ctor-unnamed-literal-class2 () ()))
1213 (defun ctor-unnamed-literal-class ()
1214   (make-instance '#.*unnamed*))
1215 (compile 'ctor-unnamed-literal-class)
1216 (defun ctor-unnamed-literal-class2 ()
1217   (make-instance '#.(find-class 'ctor-unnamed-literal-class2)))
1218 (compile 'ctor-unnamed-literal-class2)
1219 (defun ctor-unnamed-literal-class2/symbol ()
1220   (make-instance 'ctor-unnamed-literal-class2))
1221 (compile 'ctor-unnamed-literal-class2/symbol)
1222 (setf (class-name *unnamed2*) nil)
1223 (setf (find-class 'ctor-unnamed-literal-class2) nil)
1224 (with-test (:name (:ctor :unnamed-before))
1225   (assert (typep (ctor-unnamed-literal-class) *unnamed*)))
1226 (with-test (:name (:ctor :unnamed-after))
1227   (assert (typep (ctor-unnamed-literal-class2) *unnamed2*)))
1228 (with-test (:name (:ctor :unnamed-after/symbol))
1229   (assert (raises-error? (ctor-unnamed-literal-class2/symbol))))
1230 \f
1231 ;;; classes with slot types shouldn't break if the types don't name
1232 ;;; classes (bug #391)
1233 (defclass slot-type-superclass () ((slot :type fixnum)))
1234 (defclass slot-type-subclass (slot-type-superclass)
1235   ((slot :type (integer 1 5))))
1236 (let ((instance (make-instance 'slot-type-subclass)))
1237   (setf (slot-value instance 'slot) 3))
1238 \f
1239 ;;; ctors where there's a non-standard SHARED-INITIALIZE method and an
1240 ;;; initarg which isn't self-evaluating (kpreid on #lisp 2006-01-29)
1241 (defclass kpreid-enode ()
1242   ((slot :initarg not-a-keyword)))
1243 (defmethod shared-initialize ((o kpreid-enode) slots &key &allow-other-keys)
1244   (call-next-method))
1245 (defun make-kpreid-enode ()
1246   (make-instance 'kpreid-enode 'not-a-keyword 3))
1247 (with-test (:name (:ctor :non-keyword-initarg))
1248   (let ((x (make-kpreid-enode))
1249         (y (make-kpreid-enode)))
1250     (= (slot-value x 'slot) (slot-value y 'slot))))
1251 \f
1252 ;;; defining a class hierarchy shouldn't lead to spurious classoid
1253 ;;; errors on TYPEP questions (reported by Tim Moore on #lisp
1254 ;;; 2006-03-10)
1255 (defclass backwards-2 (backwards-1) (a b))
1256 (defclass backwards-3 (backwards-2) ())
1257 (defun typep-backwards-3 (x)
1258   (typep x 'backwards-3))
1259 (defclass backwards-1 () (a b))
1260 (assert (not (typep-backwards-3 1)))
1261 (assert (not (typep-backwards-3 (make-instance 'backwards-2))))
1262 (assert (typep-backwards-3 (make-instance 'backwards-3)))
1263 \f
1264 (defgeneric remove-method-1 (x)
1265   (:method ((x integer)) (1+ x)))
1266 (defgeneric remove-method-2 (x)
1267   (:method ((x integer)) (1- x)))
1268 (assert (eq #'remove-method-1
1269             (remove-method #'remove-method-1
1270                            (find-method #'remove-method-2
1271                                         nil
1272                                         (list (find-class 'integer))))))
1273 (assert (= (remove-method-1 3) 4))
1274 (assert (= (remove-method-2 3) 2))
1275
1276 ;;; ANSI doesn't require these restarts, but now that we have them we
1277 ;;; better test them too.
1278 (defclass slot-unbound-restart-test () ((x)))
1279 (let ((test (make-instance 'slot-unbound-restart-test)))
1280   (assert (not (slot-boundp test 'x)))
1281   (assert (= 42 (handler-bind ((unbound-slot (lambda (c) (use-value 42 c))))
1282                   (slot-value test 'x))))
1283   (assert (not (slot-boundp test 'x)))
1284   (assert (= 13 (handler-bind ((unbound-slot (lambda (c) (store-value 13 c))))
1285                   (slot-value test 'x))))
1286   (assert (= 13 (slot-value test 'x))))
1287
1288 ;;; Using class instances as specializers, reported by Pascal Costanza, ref CLHS 7.6.2
1289 (defclass class-as-specializer-test ()
1290    ())
1291 (eval `(defmethod class-as-specializer-test1 ((x ,(find-class 'class-as-specializer-test)))
1292           'foo))
1293 (assert (eq 'foo (class-as-specializer-test1 (make-instance 'class-as-specializer-test))))
1294 (funcall (compile nil `(lambda ()
1295                          (defmethod class-as-specializer-test2 ((x ,(find-class 'class-as-specializer-test)))
1296                            'bar))))
1297 (assert (eq 'bar (class-as-specializer-test2 (make-instance 'class-as-specializer-test))))
1298 \f
1299 ;;; CHANGE-CLASS and tricky allocation.
1300 (defclass foo-to-be-changed ()
1301   ((a :allocation :class :initform 1)))
1302 (defclass bar-to-be-changed (foo-to-be-changed) ())
1303 (defvar *bar-to-be-changed* (make-instance 'bar-to-be-changed))
1304 (defclass baz-to-be-changed ()
1305   ((a :allocation :instance :initform 2)))
1306 (change-class *bar-to-be-changed* 'baz-to-be-changed)
1307 (assert (= (slot-value *bar-to-be-changed* 'a) 1))
1308 \f
1309 ;;; proper name and class redefinition
1310 (defvar *to-be-renamed1* (defclass to-be-renamed1 () ()))
1311 (defvar *to-be-renamed2* (defclass to-be-renamed2 () ()))
1312 (setf (find-class 'to-be-renamed1) (find-class 'to-be-renamed2))
1313 (defvar *renamed1* (defclass to-be-renamed1 () ()))
1314 (assert (not (eq *to-be-renamed1* *to-be-renamed2*)))
1315 (assert (not (eq *to-be-renamed1* *renamed1*)))
1316 (assert (not (eq *to-be-renamed2* *renamed1*)))
1317 \f
1318 ;;; CLASS-NAME (and various other standardized generic functions) have
1319 ;;; their effective methods precomputed; in the process of rearranging
1320 ;;; (SETF FIND-CLASS) and FINALIZE-INHERITANCE, this broke.
1321 (defclass class-with-odd-class-name-method ()
1322   ((a :accessor class-name)))
1323 \f
1324 ;;; another case where precomputing (this time on PRINT-OBJET) and
1325 ;;; lazily-finalized classes caused problems.  (report from James Y
1326 ;;; Knight sbcl-devel 20-07-2006)
1327
1328 (defclass base-print-object () ())
1329 ;;; this has the side-effect of finalizing BASE-PRINT-OBJECT, and
1330 ;;; additionally the second specializer (STREAM) changes the cache
1331 ;;; structure to require two keys, not just one.
1332 (defmethod print-object ((o base-print-object) (s stream))
1333   nil)
1334
1335 ;;; unfinalized as yet
1336 (defclass sub-print-object (base-print-object) ())
1337 ;;; the accessor causes an eager finalization
1338 (defclass subsub-print-object (sub-print-object)
1339   ((a :accessor a)))
1340
1341 ;;; triggers a discriminating function (and so cache) recomputation.
1342 ;;; The method on BASE-PRINT-OBJECT will cause the system to attempt
1343 ;;; to fill the cache for all subclasses of BASE-PRINT-OBJECT which
1344 ;;; have valid wrappers; however, in the course of doing so, the
1345 ;;; SUB-PRINT-OBJECT class gets finalized, which invalidates the
1346 ;;; SUBSUB-PRINT-OBJECT wrapper; if an invalid wrapper gets into a
1347 ;;; cache with more than one key, then failure ensues.
1348 (reinitialize-instance #'print-object)
1349 \f
1350 ;;; bug in long-form method combination: if there's an applicable
1351 ;;; method not part of any method group, we need to call
1352 ;;; INVALID-METHOD-ERROR.  (MC27 test case from Bruno Haible)
1353 (define-method-combination mc27 ()
1354   ((normal ())
1355    (ignored (:ignore :unused)))
1356   `(list 'result
1357     ,@(mapcar #'(lambda (method) `(call-method ,method)) normal)))
1358 (defgeneric test-mc27 (x)
1359   (:method-combination mc27)
1360   (:method :ignore ((x number)) (/ 0)))
1361 (assert (raises-error? (test-mc27 7)))
1362
1363 (define-method-combination mc27prime ()
1364   ((normal ())
1365    (ignored (:ignore)))
1366   `(list 'result ,@(mapcar (lambda (m) `(call-method ,m)) normal)))
1367 (defgeneric test-mc27prime (x)
1368   (:method-combination mc27prime)
1369   (:method :ignore ((x number)) (/ 0)))
1370 (assert (equal '(result) (test-mc27prime 3)))
1371 (assert (raises-error? (test-mc27 t))) ; still no-applicable-method
1372 \f
1373 ;;; more invalid wrappers.  This time for a long-standing bug in the
1374 ;;; compiler's expansion for TYPEP on various class-like things, with
1375 ;;; user-visible consequences.
1376 (defclass obsolete-again () ())
1377 (defvar *obsolete-again* (make-instance 'obsolete-again))
1378 (defvar *obsolete-again-hash* (sxhash *obsolete-again*))
1379 (make-instances-obsolete (find-class 'obsolete-again))
1380 (assert (not (streamp *obsolete-again*)))
1381 (make-instances-obsolete (find-class 'obsolete-again))
1382 (assert (= (sxhash *obsolete-again*) *obsolete-again-hash*))
1383 (compile (defun is-a-structure-object-p (x) (typep x 'structure-object)))
1384 (make-instances-obsolete (find-class 'obsolete-again))
1385 (assert (not (is-a-structure-object-p *obsolete-again*)))
1386 \f
1387 ;;; overeager optimization of slot-valuish things
1388 (defclass listoid ()
1389   ((caroid :initarg :caroid)
1390    (cdroid :initarg :cdroid :initform nil)))
1391 (defmethod lengthoid ((x listoid))
1392   (let ((result 0))
1393     (loop until (null x)
1394           do (incf result) (setq x (slot-value x 'cdroid)))
1395     result))
1396 (with-test (:name ((:setq :method-parameter) slot-value))
1397   (assert (= (lengthoid (make-instance 'listoid)) 1))
1398   (assert (= (lengthoid
1399               (make-instance 'listoid :cdroid
1400                              (make-instance 'listoid :cdroid
1401                                             (make-instance 'listoid))))
1402              3)))
1403
1404 \f
1405
1406 ;;;; Tests for argument parsing in fast-method-functions.
1407
1408 (defvar *foo* 0)
1409
1410 (eval-when (:compile-toplevel :load-toplevel :execute)
1411   (setf (symbol-value 'a) 'invalid))
1412
1413 (defmacro test1 (lambda-list values args &key declarations cnm)
1414   `(progn
1415      (fmakunbound 'll-method)
1416      (fmakunbound 'll-function)
1417      (defmethod ll-method ,lambda-list
1418        ,@declarations
1419        ,@(when cnm
1420            `((when nil (call-next-method))))
1421        (list ,@values))
1422      (defun ll-function ,lambda-list
1423        ,@declarations
1424        (list ,@values))
1425      (dotimes (i 2)
1426        (assert (equal (ll-method ,@args)
1427                       (ll-function ,@args))))))
1428
1429 (defmacro test (&rest args)
1430   `(progn
1431      (test1 ,@args :cnm nil)
1432      (test1 ,@args :cnm t)))
1433
1434 ;; Just plain arguments
1435
1436 (test (a) (a) (1))
1437 (test (a b c d e f g h i) (a b c d e f g h i) (1 2 3 4 5 6 7 8 9))
1438
1439 (test (*foo*) (*foo* (symbol-value '*foo*)) (1))
1440
1441 (test (a) (a (symbol-value 'a)) (1)
1442       :declarations ((declare (special a))))
1443
1444 ;; Optionals
1445
1446 (test (a &optional b c) (a b c) (1))
1447 (test (a &optional b c) (a b c) (1 2))
1448 (test (a &optional b c) (a b c) (1 2 3))
1449
1450 (test (a &optional (b 'b b-p) (c 'c c-p)) (a b c b-p c-p) (1))
1451 (test (a &optional (b 'b b-p) (c 'c c-p)) (a b c b-p c-p) (1 2))
1452 (test (a &optional (b 'b b-p) (c 'c c-p)) (a b c b-p c-p) (1 2 3))
1453
1454 (test (&optional *foo*) (*foo* (symbol-value '*foo*)) ())
1455 (test (&optional *foo*) (*foo* (symbol-value '*foo*)) (1))
1456
1457 (test (&optional (*foo* 'z foo-p)) (*foo* (symbol-value '*foo*) foo-p) ())
1458 (test (&optional (*foo* 'z foo-p)) (*foo* (symbol-value '*foo*) foo-p) (1))
1459
1460 (test (&optional a) (a (symbol-value 'a)) ()
1461       :declarations ((declare (special a))))
1462 (test (&optional a) (a (symbol-value 'a)) (1)
1463       :declarations ((declare (special a))))
1464
1465 (test (&optional (a 'z a-p)) (a (symbol-value 'a) a-p) ()
1466       :declarations ((declare (special a))))
1467 (test (&optional (a 'z a-p)) (a (symbol-value 'a) a-p) (1)
1468       :declarations ((declare (special a))))
1469
1470 (defparameter *count* 0)
1471
1472 (test (&optional (a (incf *count*)) (b (incf *count*)))
1473       (a b *count* (setf *count* 0))
1474       ())
1475
1476 ;; Keywords with some &RESTs thrown in
1477
1478 (dolist (args '((1)
1479                 (1 :b 2)
1480                 (1 :c 3)
1481                 (1 :b 2 :c 3)
1482                 (1 :c 3 :b 2)
1483                 (1 :c 3 :c 1 :b 2 :b 4)))
1484   (eval `(test (a &key b c) (a b c) ,args))
1485   (eval `(test (a &key (b 'b b-p) (c 'c c-p))
1486                (a b c b-p c-p)
1487                ,args))
1488   (eval `(test (a &rest rest &key (b 'b b-p) (c 'c c-p))
1489                (a b c b-p c-p rest)
1490                ,args))
1491   (eval `(test (a &rest *foo* &key (b 'b b-p) (c 'c c-p))
1492                (a b c b-p c-p *foo* (symbol-value '*foo*))
1493                ,args))
1494   (eval `(test (a &rest *foo* &key (b 'b b-p) (c 'c c-p))
1495                (a b c b-p c-p *foo* (symbol-value '*foo*))
1496                ,args
1497                :declarations ((declare (special b-p))))))
1498
1499 (dolist (args '(()
1500                 (:*foo* 1)
1501                 (:*foo* 1 :*foo* 2)))
1502   (eval `(test (&key *foo*) (*foo* (symbol-value '*foo*)) ,args))
1503   (eval `(test (&key (*foo* 'z foo-p)) (*foo* (symbol-value '*foo*) foo-p)
1504                ,args))
1505   (eval `(test (&key ((:*foo* a) 'z foo-p)) (a (symbol-value 'a) foo-p)
1506                ,args))
1507   (eval `(test (&key ((:*foo* a) 'z foo-p)) (a (symbol-value 'a) foo-p)
1508                ,args
1509                :declarations ((declare (special a))))))
1510
1511 (defparameter *count* 0)
1512
1513 (test (&key (a (incf *count*)) (b (incf *count*)))
1514       (a b *count* (setf *count* 0))
1515       ())
1516
1517 (test (&key a b &allow-other-keys) (a b) (:a 1 :b 2 :c 3))
1518
1519 (defmethod clim-style-lambda-list-test (a b &optional c d &key x y)
1520   (list a b c d x y))
1521
1522 (clim-style-lambda-list-test 1 2)
1523
1524 (setf *count* 0)
1525
1526 (test (&aux (a (incf *count*)) (b (incf *count*)))
1527       (a b *count* (setf *count* 0))
1528       ())
1529
1530 ;;;; long-form method combination with &rest in :arguments
1531 ;;;; (this had a bug what with fixed in 1.0.4.something)
1532 (define-method-combination long-form-with-&rest ()
1533   ((methods *))
1534   (:arguments x &rest others)
1535   `(progn
1536      ,@(mapcar (lambda (method)
1537                  `(call-method ,method))
1538                methods)
1539      (list ,x (length ,others))))
1540
1541 (defgeneric test-long-form-with-&rest (x &rest others)
1542   (:method-combination long-form-with-&rest))
1543
1544 (defmethod test-long-form-with-&rest (x &rest others)
1545   nil)
1546
1547 (assert (equal '(:foo 13)
1548                (apply #'test-long-form-with-&rest :foo (make-list 13))))
1549
1550 \f
1551 ;;;; success