X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fbraid.lisp;h=e426863c16b05cff51827c61f258f5b5337fa9c5;hb=683874b497a99cd2c11b6c5d9b47e2785b1ede5f;hp=307e5204f81a6b17e48b3b8861e18a8e5fa879ab;hpb=f2aa2d01b8d69f1c7bff18f86279d4f1018fe127;p=sbcl.git

diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp
index 307e520..e426863 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 (%%allocate-instance--class))
+  (let ((instance (%make-standard-instance nil))
 	(no-of-slots (wrapper-no-of-instance-slots wrapper)))
     (setf (std-instance-wrapper instance) wrapper)
     (setf (std-instance-slots instance)
@@ -63,8 +63,8 @@
 
 (defun allocate-funcallable-instance (wrapper &optional
 					      (slots-init nil slots-init-p))
-  (let ((fin (allocate-funcallable-instance-1)))
-    (set-funcallable-instance-function
+  (let ((fin (%make-pcl-funcallable-instance nil nil)))
+    (set-funcallable-instance-fun
      fin
      #'(sb-kernel:instance-lambda (&rest args)
 	 (declare (ignore args))
@@ -92,14 +92,8 @@
 ;;;; BOOTSTRAP-META-BRAID
 ;;;;
 ;;;; This function builds the base metabraid from the early class definitions.
-;;;;
-;;;; FIXME: This, like lotso the other stuff in PCL, is not needed in target
-;;;; Lisp, only at bootstrap time. Perhaps we should do something kludgy like
-;;;; putting a special character (#\$, perhaps) at the beginning of each
-;;;; needed-only-at-bootstrap-time symbol and then UNINTERN them all once we're
-;;;; done bootstrapping?
 
-(defmacro initial-classes-and-wrappers (&rest classes)
+(defmacro !initial-classes-and-wrappers (&rest classes)
   `(progn
      ,@(mapcar #'(lambda (class)
 		   (let ((wr (intern (format nil "~A-WRAPPER" class)
@@ -131,7 +125,7 @@
 	 standard-effective-slot-definition
 	 class-eq-specializer-wrapper class-eq-specializer
 	 standard-generic-function-wrapper standard-generic-function)
-    (initial-classes-and-wrappers
+    (!initial-classes-and-wrappers
      standard-class funcallable-standard-class
      slot-class built-in-class structure-class std-class
      standard-direct-slot-definition standard-effective-slot-definition
@@ -536,19 +530,9 @@
 			:metaclass 'structure-class
 			:name symbol
 			:direct-superclasses
-			(cond ;; Handle our CMU-CL-ish structure-based
-			      ;; conditions.
-			      ((cl:subtypep symbol 'condition)
-			       (mapcar #'cl:class-name
-				       (sb-kernel:class-direct-superclasses
-					(cl:find-class symbol))))
-			      ;; a hack to add the STREAM class as a
-			      ;; mixin to the LISP-STREAM class.
-			      ((eq symbol 'sb-kernel:lisp-stream)
-			       '(structure-object stream))
-			      ((structure-type-included-type-name symbol)
-			       (list (structure-type-included-type-name
-				      symbol))))
+                        (mapcar #'cl:class-name
+                                (sb-kernel:class-direct-superclasses
+                                 (cl:find-class symbol)))
 			:direct-slots
 			(mapcar #'slot-initargs-from-structure-slotd
 				(structure-type-slot-description-list
@@ -565,12 +549,13 @@
 	(let* ((default-method-function #'constantly-nil)
 	       (default-method-initargs (list :function
 					      default-method-function))
-	       (default-method (make-a-method 'standard-method
-					      ()
-					      (list 'object)
-					      (list *the-class-t*)
-					      default-method-initargs
-					      "class predicate default method")))
+	       (default-method (make-a-method
+				'standard-method
+				()
+				(list 'object)
+				(list *the-class-t*)
+				default-method-initargs
+				"class predicate default method")))
 	  (setf (method-function-get default-method-function :constant-value)
 		nil)
 	  (add-method gf default-method)))
@@ -593,8 +578,9 @@
   (let ((lclass (sb-kernel:layout-class layout)))
     (unless (eq (sb-kernel:class-layout lclass) layout)
       (setf (sb-kernel:layout-inherits layout)
-	    (map 'vector #'class-wrapper
-		 (reverse (rest (class-precedence-list class)))))
+              (sb-kernel:order-layout-inherits
+               (map 'simple-vector #'class-wrapper
+                    (reverse (rest (class-precedence-list class))))))
       (sb-kernel:register-layout layout :invalidate nil)
 
       ;; Subclasses of formerly forward-referenced-class may be