X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=b6db2a7126d3a73f2d3465789608f8142f326cfe;hb=31f68584d0732dc0d17f379773e5f87f1e5a78ad;hp=174e3289be1662203ddb0b263fbe2af68cd6d28f;hpb=7727c77c8b05dcbcf9f8878a26f94cc14ccd5218;p=sbcl.git

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 174e328..b6db2a7 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -11,8 +11,9 @@
 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
 
+(load "compiler-test-util.lisp")
 (defpackage "CLOS-IMPURE"
-  (:use "CL" "ASSERTOID" "TEST-UTIL"))
+  (:use "CL" "ASSERTOID" "TEST-UTIL" "COMPILER-TEST-UTIL"))
 (in-package "CLOS-IMPURE")
 
 ;;; It should be possible to do DEFGENERIC and DEFMETHOD referring to
@@ -71,6 +72,15 @@
 (assert (expect-error (defgeneric foo5 (x &rest))))
 (assert (expect-error (defmethod foo6 (x &rest))))
 
+;;; legal method specializers
+(defclass bug-525916-1 () ())
+(defclass bug-525916-2 () ())
+(with-test (:name :bug-525916)
+(assert (expect-error (defmethod invalid ((arg)) arg)))
+(assert (expect-error (defmethod invalid (nil) 1)))
+(assert (expect-error (defmethod invalid ((arg . bug-525916-1)) arg)))
+(assert (expect-error (defmethod invalid ((arg bug-525916-1 bug-525916-2)) arg))))
+
 ;;; more lambda-list checking
 ;;;
 ;;; DEFGENERIC lambda lists are subject to various limitations, as per
@@ -346,10 +356,14 @@
 ;;; DOCUMENTATION's argument-precedence-order wasn't being faithfully
 ;;; preserved through the bootstrap process until sbcl-0.7.8.39.
 ;;; (thanks to Gerd Moellmann)
-(let ((answer (documentation '+ 'function)))
-  (assert (stringp answer))
-  (defmethod documentation ((x (eql '+)) y) "WRONG")
-  (assert (string= (documentation '+ 'function) answer)))
+(with-test (:name :documentation-argument-precedence-order)
+  (defun foo022 ()
+    "Documentation"
+    t)
+  (let ((answer (documentation 'foo022 'function)))
+    (assert (stringp answer))
+    (defmethod documentation ((x (eql 'foo022)) y) "WRONG")
+    (assert (string= (documentation 'foo022 'function) answer))))
 
 ;;; only certain declarations are permitted in DEFGENERIC
 (macrolet ((assert-program-error (form)
@@ -1102,7 +1116,9 @@
             (assert (= (method-on-defined-type-and-class 3) 4)))))
 
 ;; bug 281
-(let ((sb-pcl::*max-emf-precomputation-methods* 0))
+(let (#+nil ; no more sb-pcl::*max-emf-precomputation-methods* as of
+            ; sbcl-1.0.41.x
+      (sb-pcl::*max-emf-precomputation-methods* 0))
   (eval '(defgeneric bug-281 (x)
           (:method-combination +)
           (:method ((x symbol)) 1)
@@ -1210,8 +1226,7 @@
 ;;; test case from Gerd Moellmann
 (define-method-combination r-c/c-m-1 ()
   ((primary () :required t))
-  `(restart-case (call-method ,(first primary))
-     ()))
+  `(restart-case (call-method ,(first primary))))
 
 (defgeneric r-c/c-m-1-gf ()
   (:method-combination r-c/c-m-1)
@@ -1344,7 +1359,7 @@
 (defclass class-with-odd-class-name-method ()
   ((a :accessor class-name)))
 
-;;; another case where precomputing (this time on PRINT-OBJET) and
+;;; another case where precomputing (this time on PRINT-OBJECT) and
 ;;; lazily-finalized classes caused problems.  (report from James Y
 ;;; Knight sbcl-devel 20-07-2006)
 
@@ -1619,5 +1634,502 @@
 (handler-bind ((warning #'error))
   (assert (= 123 (slot-value (provoke-ctor-default-initarg-problem) 'slot))))
 
+;;;; discriminating net on streams used to generate code deletion notes on
+;;;; first call
+(defgeneric stream-fd (stream direction))
+(defmethod stream-fd ((stream sb-sys:fd-stream) direction)
+  (declare (ignore direction))
+  (sb-sys:fd-stream-fd stream))
+(defmethod stream-fd ((stream synonym-stream) direction)
+  (stream-fd (symbol-value (synonym-stream-symbol stream)) direction))
+(defmethod stream-fd ((stream two-way-stream) direction)
+  (ecase direction
+    (:input
+     (stream-fd
+      (two-way-stream-input-stream stream) direction))
+    (:output
+     (stream-fd
+      (two-way-stream-output-stream stream) direction))))
+(with-test (:name (:discriminating-name :code-deletion-note))
+  (handler-bind ((compiler-note #'error))
+    (stream-fd sb-sys:*stdin* :output)
+    (stream-fd sb-sys:*stdin* :output)))
+
+(with-test (:name :bug-380)
+  (defclass bug-380 ()
+    ((slot :accessor bug380-slot)))
+  (fmakunbound 'foo-slot)
+  (defgeneric foo-slot (x y z))
+  (defclass foo ()
+    ((slot :accessor foo-slot-value))))
+
+;;; SET and (SETF SYMBOL-VALUE) used to confuse permuation vector
+;;; optimizations
+(defclass fih ()
+  ((x :initform :fih)))
+(defclass fah ()
+  ((x :initform :fah)))
+(declaim (special *fih*))
+(defmethod fihfah ((*fih* fih))
+  (set '*fih* (make-instance 'fah))
+  (list (slot-value *fih* 'x)
+        (eval '(slot-value *fih* 'x))))
+(defmethod fihfah ((fah fah))
+  (declare (special fah))
+  (set 'fah (make-instance 'fih))
+  (list (slot-value fah 'x)
+        (eval '(slot-value fah 'x))))
+(with-test (:name :set-of-a-method-specializer)
+  (assert (equal '(:fah :fah) (fihfah (make-instance 'fih))))
+  (assert (equal '(:fih :fih) (fihfah (make-instance 'fah)))))
+
+(defmethod no-implicit-declarations-for-local-specials ((faax double-float))
+  (declare (special faax))
+  (set 'faax (when (< faax 0) (- faax)))
+  faax)
+(with-test (:name :no-implicit-declarations-for-local-specials)
+  (assert (not (no-implicit-declarations-for-local-specials 1.0d0))))
+
+(defstruct bug-357-a
+  slot1
+  (slot2 t)
+  (slot3 (coerce pi 'single-float) :type single-float))
+(defclass bug-357-b (bug-357-a)
+  ((slot2 :initform 't2)
+   (slot4 :initform -44)
+   (slot5)
+   (slot6 :initform t)
+   (slot7 :initform (floor (* pi pi)))
+   (slot8 :initform 88))
+  (:metaclass structure-class))
+(defstruct (bug-357-c (:include bug-357-b (slot8 -88) (slot5 :ok)))
+  slot9
+  (slot10 t)
+  (slot11 (floor (exp 3))))
+(with-test (:name :bug-357)
+  (flet ((slots (x)
+           (list (bug-357-c-slot1 x)
+                 (bug-357-c-slot2 x)
+                 (bug-357-c-slot3 x)
+                 (bug-357-c-slot4 x)
+                 (bug-357-c-slot5 x)
+                 (bug-357-c-slot6 x)
+                 (bug-357-c-slot7 x)
+                 (bug-357-c-slot8 x)
+                 (bug-357-c-slot9 x)
+                 (bug-357-c-slot10 x)
+                 (bug-357-c-slot11 x))))
+    (let ((base (slots (make-bug-357-c))))
+      (assert (equal base (slots (make-instance 'bug-357-c))))
+      (assert (equal base '(nil t2 3.1415927 -44 :ok t 9 -88 nil t 20))))))
+
+(defclass class-slot-shared-initialize ()
+  ((a :allocation :class :initform :ok)))
+(with-test (:name :class-slot-shared-initialize)
+  (let ((x (make-instance 'class-slot-shared-initialize)))
+    (assert (eq :ok (slot-value x 'a)))
+    (slot-makunbound x 'a)
+    (assert (not (slot-boundp x 'a)))
+    (shared-initialize x '(a))
+    (assert (slot-boundp x 'a))
+    (assert (eq :ok (slot-value x 'a)))))
+
+(declaim (ftype (function (t t t) (values single-float &optional))
+                i-dont-want-to-be-clobbered-1
+                i-dont-want-to-be-clobbered-2))
+(defgeneric i-dont-want-to-be-clobbered-1 (t t t))
+(defmethod i-dont-want-to-be-clobbered-2 ((x cons) y z)
+  y)
+(defun i-cause-an-gf-info-update ()
+  (i-dont-want-to-be-clobbered-2 t t t))
+(with-test (:name :defgeneric-should-clobber-ftype)
+  ;; (because it doesn't check the argument or result types)
+  (assert (equal '(function (t t t) *)
+                 (sb-kernel:type-specifier
+                  (sb-int:info :function
+                               :type 'i-dont-want-to-be-clobbered-1))))
+  (assert (equal '(function (t t t) *)
+                 (sb-kernel:type-specifier
+                  (sb-int:info :function
+                               :type 'i-dont-want-to-be-clobbered-2))))
+  (assert (eq :defined-method
+              (sb-int:info :function
+                           :where-from 'i-dont-want-to-be-clobbered-1)))
+  (assert (eq :defined-method
+              (sb-int:info :function
+                           :where-from 'i-dont-want-to-be-clobbered-2))))
+
+(with-test (:name :bogus-parameter-specializer-name-error)
+  (assert (eq :ok
+              (handler-case
+                  (eval `(defmethod #:fii ((x "a string")) 'string))
+                (sb-int:reference-condition (c)
+                  (when (member '(:ansi-cl :macro defmethod)
+                                (sb-int:reference-condition-references c)
+                                :test #'equal)
+                    :ok))))))
+
+(defclass remove-default-initargs-test ()
+  ((x :initarg :x :initform 42)))
+(defclass remove-default-initatgs-test ()
+  ((x :initarg :x :initform 42))
+  (:default-initargs :x 0))
+(defclass remove-default-initargs-test ()
+  ((x :initarg :x :initform 42)))
+(with-test (:name :remove-default-initargs)
+  (assert (= 42 (slot-value (make-instance 'remove-default-initargs-test)
+                            'x))))
 
+(with-test (:name :bug-485019)
+  ;; there was a bug in WALK-SETQ, used in method body walking, in the
+  ;; presence of declarations on symbol macros.
+  (defclass bug-485019 ()
+    ((array :initarg :array)))
+  (defmethod bug-485019 ((bug-485019 bug-485019))
+    (with-slots (array) bug-485019
+      (declare (type (or null simple-array) array))
+      (setf array (make-array 4)))
+    bug-485019)
+  (bug-485019 (make-instance 'bug-485019)))
+
+;;; The compiler didn't propagate the declarared type before applying
+;;; the transform for (SETF SLOT-VALUE), so the generic accessor was used.
+(defstruct foo-520366
+  slot)
+(defun quux-520366 (cont)
+  (funcall cont))
+(defun bar-520366 (foo-struct)
+  (declare (type foo-520366 foo-struct))
+  (with-slots (slot) foo-struct
+    (tagbody
+       (quux-520366 #'(lambda ()
+                        (setf slot :value)
+                        (go TAG)))
+     TAG)))
+(with-test (:name :bug-520366)
+  (let ((callees (find-named-callees #'bar-520366)))
+    (assert (equal (list #'quux-520366) callees))))
+
+(defgeneric no-applicable-method/retry (x))
+(defmethod no-applicable-method/retry ((x string))
+  "string")
+(with-test (:name :no-applicable-method/retry)
+  (assert (equal "cons"
+                 (handler-bind ((error
+                                 (lambda (c)
+                                   (declare (ignore c))
+                                   (let ((r (find-restart 'sb-pcl::retry)))
+                                     (when r
+                                       (eval `(defmethod no-applicable-method/retry ((x cons))
+                                                "cons"))
+                                       (invoke-restart r))))))
+                   (no-applicable-method/retry (cons t t))))))
+
+(defgeneric no-primary-method/retry (x))
+(defmethod no-primary-method/retry :before (x) (assert x))
+(with-test (:name :no-primary-method/retry)
+  (assert (equal "ok!"
+                 (handler-bind ((error
+                                 (lambda (c)
+                                   (declare (ignore c))
+                                   (let ((r (find-restart 'sb-pcl::retry)))
+                                     (when r
+                                       (eval `(defmethod no-primary-method/retry (x)
+                                                "ok!"))
+                                       (invoke-restart r))))))
+                   (no-primary-method/retry (cons t t))))))
+
+;;; test that a cacheing strategy for make-instance initargs checking
+;;; can handle class redefinitions
+(defclass cacheing-initargs-redefinitions-check ()
+  ((slot :initarg :slot)))
+(defun cacheing-initargs-redefinitions-check-fun (&optional (initarg :slot))
+  (declare (notinline make-instance))
+  (make-instance 'cacheing-initargs-redefinitions-check)
+  (make-instance 'cacheing-initargs-redefinitions-check initarg 3))
+(with-test (:name :make-instance-initargs)
+  (make-instance 'cacheing-initargs-redefinitions-check)
+  (make-instance 'cacheing-initargs-redefinitions-check :slot 3)
+  (cacheing-initargs-redefinitions-check-fun :slot)
+  (assert (raises-error? (cacheing-initargs-redefinitions-check-fun :slot2))))
+(defclass cacheing-initargs-redefinitions-check ()
+  ((slot :initarg :slot2)))
+(with-test (:name :make-instance-redefined-initargs)
+  (make-instance 'cacheing-initargs-redefinitions-check)
+  (make-instance 'cacheing-initargs-redefinitions-check :slot2 3)
+  (cacheing-initargs-redefinitions-check-fun :slot2)
+  (assert (raises-error? (cacheing-initargs-redefinitions-check-fun :slot))))
+(defmethod initialize-instance :after ((class cacheing-initargs-redefinitions-check) &key slot)
+  nil)
+(with-test (:name :make-instance-new-method-initargs)
+  (make-instance 'cacheing-initargs-redefinitions-check)
+  (make-instance 'cacheing-initargs-redefinitions-check :slot2 3)
+  (cacheing-initargs-redefinitions-check-fun :slot2)
+  (let ((thing (cacheing-initargs-redefinitions-check-fun :slot)))
+    (assert (not (slot-boundp thing 'slot)))))
+
+(with-test (:name :defmethod-specializer-builtin-class-alias)
+  (let ((alias (gensym)))
+    (setf (find-class alias) (find-class 'symbol))
+    (eval `(defmethod lp-618387 ((s ,alias))
+             (symbol-name s)))
+    (assert (equal "FOO" (funcall 'lp-618387 :foo)))))
+
+(with-test (:name :pcl-spurious-ignore-warnings)
+  (defgeneric no-spurious-ignore-warnings (req &key key))
+  (handler-bind ((warning (lambda (x) (error "~A" x))))
+    (eval
+     '(defmethod no-spurious-ignore-warnings ((req number) &key key)
+       (declare (ignore key))
+       (check-type req integer))))
+  (defgeneric should-get-an-ignore-warning (req &key key))
+  (let ((warnings 0))
+    (handler-bind ((warning (lambda (c) (setq warnings 1) (muffle-warning c))))
+      (eval '(defmethod should-get-an-ignore-warning ((req integer) &key key)
+              (check-type req integer))))
+    (assert (= warnings 1))))
+
+(defgeneric generic-function-pretty-arglist-optional-and-key (req &optional opt &key key)
+  (:method (req &optional opt &key key)
+    (list req opt key)))
+
+(with-test (:name :generic-function-pretty-arglist-optional-and-key)
+  (handler-bind ((warning #'error))
+    ;; Used to signal a style-warning
+    (assert (equal '(req &optional opt &key key)
+                   (sb-pcl::generic-function-pretty-arglist
+                    #'generic-function-pretty-arglist-optional-and-key)))))
+
+(with-test (:name :bug-894202)
+  (assert (eq :good
+              (handler-case
+                  (let ((name (gensym "FOO"))
+                        (decl (gensym "BAR")))
+                    (eval `(defgeneric ,name ()
+                             (declare (,decl)))))
+                (warning ()
+                  :good)))))
+
+(with-test (:name :bug-898331)
+  (handler-bind ((warning #'error))
+    (eval `(defgeneric bug-898331 (request type remaining-segment-requests all-requests)))
+    (eval `(defmethod bug-898331 ((request cons) (type (eql :cancel))
+                                  remaining-segment-requests
+                                  all-segment-requests)
+             (declare (ignore all-segment-requests))
+             (check-type request t)))))
+
+(with-test (:name :bug-1001799)
+  ;; compilation of the defmethod used to cause infinite recursion
+  (let ((pax (gensym "PAX"))
+        (pnr (gensym "PNR"))
+        (sup (gensym "SUP"))
+        (frob (gensym "FROB"))
+        (sb-ext:*evaluator-mode* :compile))
+    (eval
+     `(progn
+        (declaim (optimize (speed 1) (space 1) (safety 3) (debug 3) (compilation-speed 1)))
+        (defclass ,pax (,sup)
+          ((,pnr :type (or null ,pnr))))
+        (defclass ,pnr (,sup)
+          ((,pax :type (or null ,pax))))
+        (defclass ,sup ()
+          ())
+        (defmethod ,frob ((pnr ,pnr))
+          (slot-value pnr ',pax))))))
+
+(with-test (:name :bug-1099708)
+  (defclass bug-1099708 ()
+    ((slot-1099708 :initarg :slot-1099708)))
+  ;; caused infinite equal testing in function name lookup
+  (eval
+   '(progn
+     (defun make-1099708-1 ()
+       (make-instance 'bug-1099708 :slot-1099708 '#1= (1 2 . #1#)))
+     (defun make-1099708-2 ()
+       (make-instance 'bug-1099708 :slot-1099708 '#2= (1 2 . #2#)))))
+  (assert (not (eql (slot-value (make-1099708-1) 'slot-1099708)
+                    (slot-value (make-1099708-2) 'slot-1099708)))))
+
+(with-test (:name :bug-1099708b-list)
+  (defclass bug-1099708b-list ()
+    ((slot-1099708b-list :initarg :slot-1099708b-list)))
+  (eval
+   '(progn
+     (defun make-1099708b-list-1 ()
+       (make-instance 'bug-1099708b-list :slot-1099708b-list '(some value)))
+     (defun make-1099708b-list-2 ()
+       (make-instance 'bug-1099708b-list :slot-1099708b-list '(some value)))))
+  (assert (eql (slot-value (make-1099708b-list-1) 'slot-1099708b-list)
+               (slot-value (make-1099708b-list-1) 'slot-1099708b-list)))
+  (assert (eql (slot-value (make-1099708b-list-2) 'slot-1099708b-list)
+               (slot-value (make-1099708b-list-2) 'slot-1099708b-list)))
+  (assert (not (eql (slot-value (make-1099708b-list-1) 'slot-1099708b-list)
+                    (slot-value (make-1099708b-list-2) 'slot-1099708b-list)))))
+
+(with-test (:name :bug-1099708b-string)
+  (defclass bug-1099708b-string ()
+    ((slot-1099708b-string :initarg :slot-1099708b-string)))
+  (eval
+   '(progn
+     (defun make-1099708b-string-1 ()
+       (make-instance 'bug-1099708b-string :slot-1099708b-string "string"))
+     (defun make-1099708b-string-2 ()
+       (make-instance 'bug-1099708b-string :slot-1099708b-string "string"))))
+  (assert (eql (slot-value (make-1099708b-string-1) 'slot-1099708b-string)
+               (slot-value (make-1099708b-string-1) 'slot-1099708b-string)))
+  (assert (eql (slot-value (make-1099708b-string-2) 'slot-1099708b-string)
+               (slot-value (make-1099708b-string-2) 'slot-1099708b-string)))
+  (assert (not (eql (slot-value (make-1099708b-string-1) 'slot-1099708b-string)
+                    (slot-value (make-1099708b-string-2) 'slot-1099708b-string)))))
+
+(with-test (:name :bug-1099708b-bitvector)
+  (defclass bug-1099708b-bitvector ()
+    ((slot-1099708b-bitvector :initarg :slot-1099708b-bitvector)))
+  (eval
+   '(progn
+     (defun make-1099708b-bitvector-1 ()
+       (make-instance 'bug-1099708b-bitvector :slot-1099708b-bitvector #*1011))
+     (defun make-1099708b-bitvector-2 ()
+       (make-instance 'bug-1099708b-bitvector :slot-1099708b-bitvector #*1011))))
+  (assert (eql (slot-value (make-1099708b-bitvector-1) 'slot-1099708b-bitvector)
+               (slot-value (make-1099708b-bitvector-1) 'slot-1099708b-bitvector)))
+  (assert (eql (slot-value (make-1099708b-bitvector-2) 'slot-1099708b-bitvector)
+               (slot-value (make-1099708b-bitvector-2) 'slot-1099708b-bitvector)))
+  (assert (not (eql (slot-value (make-1099708b-bitvector-1) 'slot-1099708b-bitvector)
+                    (slot-value (make-1099708b-bitvector-2) 'slot-1099708b-bitvector)))))
+
+(with-test (:name :bug-1099708b-pathname)
+  (defclass bug-1099708b-pathname ()
+    ((slot-1099708b-pathname :initarg :slot-1099708b-pathname)))
+  (eval
+   '(progn
+     (defun make-1099708b-pathname-1 ()
+       (make-instance 'bug-1099708b-pathname :slot-1099708b-pathname #p"pn"))
+     (defun make-1099708b-pathname-2 ()
+       (make-instance 'bug-1099708b-pathname :slot-1099708b-pathname #p"pn"))))
+  (assert (eql (slot-value (make-1099708b-pathname-1) 'slot-1099708b-pathname)
+               (slot-value (make-1099708b-pathname-1) 'slot-1099708b-pathname)))
+  (assert (eql (slot-value (make-1099708b-pathname-2) 'slot-1099708b-pathname)
+               (slot-value (make-1099708b-pathname-2) 'slot-1099708b-pathname)))
+  (assert (not (eql (slot-value (make-1099708b-pathname-1) 'slot-1099708b-pathname)
+                    (slot-value (make-1099708b-pathname-2) 'slot-1099708b-pathname)))))
+
+(with-test (:name :bug-1099708c-list)
+  (defclass bug-1099708c-list ()
+    ((slot-1099708c-list :initarg :slot-1099708c-list)))
+  (eval
+   '(progn
+     (defun make-1099708c-list-1 ()
+       (make-instance 'bug-1099708c-list :slot-1099708c-list #1='(some value)))
+     (defun make-1099708c-list-2 ()
+       (make-instance 'bug-1099708c-list :slot-1099708c-list #1#))))
+  (assert (eql (slot-value (make-1099708c-list-1) 'slot-1099708c-list)
+               (slot-value (make-1099708c-list-1) 'slot-1099708c-list)))
+  (assert (eql (slot-value (make-1099708c-list-2) 'slot-1099708c-list)
+               (slot-value (make-1099708c-list-2) 'slot-1099708c-list)))
+  (assert (eql (slot-value (make-1099708c-list-1) 'slot-1099708c-list)
+               (slot-value (make-1099708c-list-2) 'slot-1099708c-list))))
+
+;;; bug-1179858
+
+;;; Define a class and force the "fallback" constructor generator to be
+;;; used by having a HAIRY-AROUND-OR-NONSTANDARD-PRIMARY-METHOD-P on
+;;; SHARED-INITIALIZE.
+(defclass bug-1179858 ()
+  ((foo :initarg :foo :reader bug-1179858-foo))
+  (:default-initargs :foo (error "Should not be evaluated")))
+(defmethod shared-initialize :around ((instance bug-1179858) (slot-names t) &key)
+  (call-next-method))
+
+(with-test (:name (:make-instance :fallback-generator-initarg-handling :bug-1179858))
+  ;; Now compile a lambda containing MAKE-INSTANCE to exercise the
+  ;; fallback constructor generator. Call the resulting compiled
+  ;; function to trigger the bug.
+  (funcall (compile nil '(lambda () (make-instance 'bug-1179858 :foo t)))))
+
+;;; Other brokenness, found while investigating: fallback-generator
+;;; handling of non-keyword initialization arguments
+(defclass bug-1179858b ()
+  ((foo :initarg foo :reader bug-1179858b-foo))
+  (:default-initargs foo 14))
+(defmethod shared-initialize :around ((instance bug-1179858b) (slot-names t) &key)
+  (call-next-method))
+
+(with-test (:name (:make-instance :fallback-generator-non-keyword-initarg :bug-1179858))
+  (flet ((foo= (n i) (= (bug-1179858b-foo i) n)))
+    (assert
+     (foo= 14 (funcall (compile nil '(lambda () (make-instance 'bug-1179858b))))))
+    (assert
+     (foo= 15 (funcall (compile nil '(lambda () (make-instance 'bug-1179858b 'foo 15))))))))
+
+(with-test (:name (:cpl-violation-setup :bug-309076))
+  (assert (raises-error?
+           (progn
+             (defclass bug-309076-broken-class (standard-class) ()
+               (:metaclass sb-mop:funcallable-standard-class))
+             (sb-mop:finalize-inheritance (find-class 'bug-309076-broken-class))))))
+
+(with-test (:name (:cpl-violation-irrelevant-class :bug-309076))
+  (defclass bug-309076-class (standard-class) ())
+  (defmethod sb-mop:validate-superclass ((x bug-309076-class) (y standard-class)) t)
+  (assert (typep (make-instance 'bug-309076-class) 'bug-309076-class)))
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require 'sb-cltl2)
+  (defmethod b ()))
+
+(defmacro macro ()
+  (let ((a 20))
+    (declare (special a))
+    (assert
+     (=
+      (funcall
+       (compile nil
+                (sb-mop:make-method-lambda
+                 #'b
+                 (find-method #'b () ())
+                 '(lambda () (declare (special a)) a)
+                 nil))
+       '(1) ())
+      20))))
+
+(with-test (:name :make-method-lambda-leakage)
+  ;; lambda list of X leaks into the invocation of make-method-lambda
+  ;; during code-walking performed by make-method-lambda invoked by
+  ;; DEFMETHOD
+  (sb-cltl2:macroexpand-all '(defmethod x (a) (macro))))
+
+(with-test (:name (:defmethod-undefined-function :bug-503095))
+  (flet ((test-load (file)
+           (let (implicit-gf-warning)
+             (handler-bind
+                 ((sb-ext:implicit-generic-function-warning
+                    (lambda (x)
+                      (setf implicit-gf-warning x)
+                      (muffle-warning x)))
+                  ((or warning error) #'error))
+               (load file))
+             (assert implicit-gf-warning))))
+    (multiple-value-bind (fasl warnings errorsp) (compile-file "bug-503095.lisp")
+      (unwind-protect
+           (progn (assert (and fasl (not warnings) (not errorsp)))
+                  (test-load fasl))
+        (and fasl (delete-file fasl))))
+    (test-load "bug-503095-2.lisp")))
+
+(with-test (:name :accessor-and-plain-method)
+  (defclass a-633911 ()
+    ((x-633911 :initform nil
+               :accessor x-633911)))
+
+  (defmethod x-633911 ((b a-633911)) 10)
+
+  (defclass b-633911 ()
+    ((x-633911 :initform nil
+               :accessor x-633911)))
+
+  (assert (= (x-633911 (make-instance 'a-633911)) 10)))
+
 ;;;; success