X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fpcl%2Fboot.lisp;h=e71a3bb9806faa5f2d818ab43b181f00647e20c6;hb=03770e700a55a111d9d350b4c2a6fae98662e1ed;hp=e6006942ec8b0bc4b01a83fb4b50a3fc8a5bdb37;hpb=ccd8e0156b45b6aa88d95bd796e1f49aebebe37d;p=sbcl.git

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index e600694..e71a3bb 100644
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -252,8 +252,9 @@ bootstrapping.
 
 (defun load-defgeneric (fun-name lambda-list source-location &rest initargs)
   (when (fboundp fun-name)
-    (style-warn "redefining ~S in DEFGENERIC" fun-name)
     (let ((fun (fdefinition fun-name)))
+      (warn 'sb-kernel:redefinition-with-defgeneric :name fun-name
+            :old fun :new-location source-location)
       (when (generic-function-p fun)
         (loop for method in (generic-function-initial-methods fun)
               do (remove-method fun method))
@@ -1496,7 +1497,7 @@ bootstrapping.
                           ;; another binding it won't have a %CLASS
                           ;; declaration anymore, and this won't get
                           ;; executed.
-                          (pushnew var parameters-setqd))))
+                          (pushnew var parameters-setqd :test #'eq))))
                     form)
                    ((and (eq (car form) 'function)
                          (cond ((eq (cadr form) 'call-next-method)
@@ -1572,8 +1573,10 @@ bootstrapping.
                         (generic-function-methods gf)
                         (find-method gf qualifiers specializers nil))))
       (when method
-        (style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD"
-                    gf-spec qualifiers specializers))))
+        (style-warn 'sb-kernel:redefinition-with-defmethod
+                    :generic-function gf-spec :old-method method
+                    :qualifiers qualifiers :specializers specializers
+                    :new-location source-location))))
   (let ((method (apply #'add-named-method
                        gf-spec qualifiers specializers lambda-list
                        :definition-source source-location
@@ -1913,14 +1916,19 @@ bootstrapping.
   (aver (= (symbol-value (intern (format nil "*SM-~A-INDEX*" s)))
            (!bootstrap-slot-index 'standard-reader-method s)
            (!bootstrap-slot-index 'standard-writer-method s)
-           (!bootstrap-slot-index 'standard-boundp-method s))))
+           (!bootstrap-slot-index 'standard-boundp-method s)
+           (!bootstrap-slot-index 'global-reader-method s)
+           (!bootstrap-slot-index 'global-writer-method s)
+           (!bootstrap-slot-index 'global-boundp-method s))))
+
+(define-symbol-macro *standard-method-classes*
+  (list *the-class-standard-method* *the-class-standard-reader-method*
+        *the-class-standard-writer-method* *the-class-standard-boundp-method*
+        *the-class-global-reader-method* *the-class-global-writer-method*
+        *the-class-global-boundp-method*))
 
 (defun safe-method-specializers (method)
-  (let ((standard-method-classes
-         (list *the-class-standard-method*
-               *the-class-standard-reader-method*
-               *the-class-standard-writer-method*
-               *the-class-standard-boundp-method*))
+  (let ((standard-method-classes *standard-method-classes*)
         (class (class-of method)))
     (if (member class standard-method-classes)
         (clos-slots-ref (get-slots method) *sm-specializers-index*)
@@ -1930,21 +1938,13 @@ bootstrapping.
     (and (typep mf '%method-function)
          (%method-function-fast-function mf))))
 (defun safe-method-function (method)
-  (let ((standard-method-classes
-         (list *the-class-standard-method*
-               *the-class-standard-reader-method*
-               *the-class-standard-writer-method*
-               *the-class-standard-boundp-method*))
+  (let ((standard-method-classes *standard-method-classes*)
         (class (class-of method)))
     (if (member class standard-method-classes)
         (clos-slots-ref (get-slots method) *sm-%function-index*)
         (method-function method))))
 (defun safe-method-qualifiers (method)
-  (let ((standard-method-classes
-         (list *the-class-standard-method*
-               *the-class-standard-reader-method*
-               *the-class-standard-writer-method*
-               *the-class-standard-boundp-method*))
+  (let ((standard-method-classes *standard-method-classes*)
         (class (class-of method)))
     (if (member class standard-method-classes)
         (clos-slots-ref (get-slots method) *sm-qualifiers-index*)
@@ -2011,6 +2011,7 @@ bootstrapping.
                         (package (symbol-package symbol)))
                    (and (or (eq package *pcl-package*)
                             (memq package (package-use-list *pcl-package*)))
+                        (not (eq package #.(find-package "CL")))
                         ;; FIXME: this test will eventually be
                         ;; superseded by the *internal-pcl...* test,
                         ;; above.  While we are in a process of