X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fbraid.lisp;h=6b08ed17002cb110cd7d045f86dcf69aba27f013;hb=a3ab89c1db0dd9bfb911532ca134be16f16c4c1b;hp=ca670369853dcbfa2cbad8da82055756df37afdf;hpb=b4d7d8a9eba49f0e0e6351568d45b7ac64f4047f;p=sbcl.git

diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp
index ca67036..6b08ed1 100644
--- a/src/pcl/braid.lisp
+++ b/src/pcl/braid.lisp
@@ -33,7 +33,7 @@
 
 (defun allocate-standard-instance (wrapper
 				   &optional (slots-init nil slots-init-p))
-  (let ((instance (%make-standard-instance nil))
+  (let ((instance (%make-standard-instance nil (get-instance-hash-code)))
 	(no-of-slots (wrapper-no-of-instance-slots wrapper)))
     (setf (std-instance-wrapper instance) wrapper)
     (setf (std-instance-slots instance)
@@ -63,7 +63,8 @@
 
 (defun allocate-funcallable-instance (wrapper &optional
 					      (slots-init nil slots-init-p))
-  (let ((fin (%make-pcl-funcallable-instance nil nil)))
+  (let ((fin (%make-pcl-funcallable-instance nil nil
+					     (get-instance-hash-code))))
     (set-funcallable-instance-fun
      fin
      #'(sb-kernel:instance-lambda (&rest args)
@@ -243,7 +244,7 @@
 				    smc
 				    name
 				    value)))
-	(set-slot 'source *load-truename*)
+	(set-slot 'source *load-pathname*)
 	(set-slot 'type 'standard)
 	(set-slot 'documentation "The standard method combination.")
 	(set-slot 'options ()))
@@ -293,6 +294,22 @@
       (set-slot 'direct-slots direct-slots)
       (set-slot 'slots slots)
       (set-slot 'initialize-info nil))
+
+    ;; For all direct superclasses SUPER of CLASS, make sure CLASS is
+    ;; a direct subclass of SUPER.  Note that METACLASS-NAME doesn't
+    ;; matter here for the slot DIRECT-SUBCLASSES, since every class
+    ;; inherits the slot from class CLASS.
+    (dolist (super direct-supers)
+      (let* ((super (find-class super))
+	     (subclasses (!bootstrap-get-slot metaclass-name super
+					      'direct-subclasses)))
+	(cond ((eq +slot-unbound+ subclasses)
+	       (!bootstrap-set-slot metaclass-name super 'direct-subclasses
+				    (list class)))
+	      ((not (memq class subclasses))
+	       (!bootstrap-set-slot metaclass-name super 'direct-subclasses
+				    (cons class subclasses))))))
+
     (if (eq metaclass-name 'structure-class)
 	(let ((constructor-sym '|STRUCTURE-OBJECT class constructor|))
 	  (set-slot 'predicate-name (or (cadr (assoc name
@@ -379,9 +396,9 @@
 		(!bootstrap-accessor-definitions1
 		 'slot-object
 		 slot-name
-		 (list (slot-reader-symbol slot-name))
-		 (list (slot-writer-symbol slot-name))
-		 (list (slot-boundp-symbol slot-name)))))))))))
+		 (list (slot-reader-name slot-name))
+		 (list (slot-writer-name slot-name))
+		 (list (slot-boundp-name slot-name)))))))))))
 
 (defun !bootstrap-accessor-definition (class-name accessor-name slot-name type)
   (multiple-value-bind (accessor-class make-method-function arglist specls doc)
@@ -578,7 +595,7 @@
               (sb-kernel:order-layout-inherits
                (map 'simple-vector #'class-wrapper
                     (reverse (rest (class-precedence-list class))))))
-      (sb-kernel:register-layout layout :invalidate nil)
+      (sb-kernel:register-layout layout :invalidate t)
 
       ;; Subclasses of formerly forward-referenced-class may be
       ;; unknown to CL:FIND-CLASS and also anonymous. This
@@ -626,3 +643,21 @@
 	  ~I~_when called with arguments ~2I~_~S.~:>"
 	 generic-function
 	 args))
+
+(defmethod no-next-method ((generic-function standard-generic-function)
+			   (method standard-method) &rest args)
+  (error "~@<There is no next method for the generic function ~2I~_~S~
+	  ~I~_when called from method ~2I~_~S~I~_with arguments ~2I~_~S.~:>"
+	 generic-function
+	 method
+	 args))
+
+;;; An extension to the ANSI standard: in the presence of e.g. a
+;;; :BEFORE method, it would seem that going through
+;;; NO-APPLICABLE-METHOD is prohibited, as in fact there is an
+;;; applicable method.  -- CSR, 2002-11-15
+(defmethod no-primary-method (generic-function &rest args)
+  (error "~@<There is no primary method for the generic function ~2I~_~S~
+	  ~I~_when called with arguments ~2I~_~S.~:>"
+	 generic-function
+	 args))