0.7.9.36:

[sbcl.git] / src / pcl / braid.lisp

diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp
index 95eced7..b2ed047 100644 (file)
--- a/src/pcl/braid.lisp
+++ b/src/pcl/braid.lisp
@@ -33,7 +33,7 @@
 \f
 (defun allocate-standard-instance (wrapper
                                   &optional (slots-init nil slots-init-p))
-  (let ((instance (%%allocate-instance--class))
+  (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 (allocate-funcallable-instance-1)))
+  (let ((fin (%make-pcl-funcallable-instance nil nil
+                                            (get-instance-hash-code))))
     (set-funcallable-instance-fun
      fin
      #'(sb-kernel:instance-lambda (&rest args)
@@ -95,21 +96,21 @@
 
 (defmacro !initial-classes-and-wrappers (&rest classes)
   `(progn
-     ,@(mapcar #'(lambda (class)
-                  (let ((wr (intern (format nil "~A-WRAPPER" class)
-                                    *pcl-package*)))
-                    `(setf ,wr ,(if (eq class 'standard-generic-function)
-                                    '*sgf-wrapper*
-                                    `(boot-make-wrapper
-                                      (early-class-size ',class)
-                                      ',class))
-                           ,class (allocate-standard-instance
-                                   ,(if (eq class 'standard-generic-function)
-                                        'funcallable-standard-class-wrapper
-                                        'standard-class-wrapper))
-                           (wrapper-class ,wr) ,class
-                           (find-class ',class) ,class)))
-             classes)))
+     ,@(mapcar (lambda (class)
+                (let ((wr (intern (format nil "~A-WRAPPER" class)
+                                  *pcl-package*)))
+                  `(setf ,wr ,(if (eq class 'standard-generic-function)
+                                  '*sgf-wrapper*
+                                  `(boot-make-wrapper
+                                    (early-class-size ',class)
+                                    ',class))
+                         ,class (allocate-standard-instance
+                                 ,(if (eq class 'standard-generic-function)
+                                      'funcallable-standard-class-wrapper
+                                      'standard-class-wrapper))
+                         (wrapper-class ,wr) ,class
+                         (find-class ',class) ,class)))
+              classes)))
 
 (defun !bootstrap-meta-braid ()
   (let* ((*create-classes-from-internal-structure-definitions-p* nil)
@@ -145,10 +146,7 @@
                        (built-in-class built-in-class-wrapper)
                        (structure-class structure-class-wrapper)))
             (class (or (find-class name nil)
-                       (allocate-standard-instance wrapper))))
-       (when (or (eq meta 'standard-class)
-                 (eq meta 'funcallable-standard-class))
-         (inform-type-system-about-std-class name))
+                       (allocate-standard-instance wrapper)))) 
        (setf (find-class name) class)))
     (dolist (definition *early-class-definitions*)
       (let ((name (ecd-class-name definition))
@@ -246,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 ()))
@@ -511,7 +509,7 @@
 (defvar *find-structure-class* nil)
 
 (defun eval-form (form)
-  #'(lambda () (eval form)))
+  (lambda () (eval form)))
 
 (defun slot-initargs-from-structure-slotd (slotd)
   `(:name ,(structure-slotd-name slotd)
@@ -581,7 +579,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
@@ -629,3 +627,11 @@
          ~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))