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

diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp
index 79dd636..307e520 100644
--- a/src/pcl/braid.lisp
+++ b/src/pcl/braid.lisp
@@ -1,10 +1,10 @@
 ;;;; bootstrapping the meta-braid
 ;;;;
-;;;; The code in this file takes the early definitions that have been saved
-;;;; up and actually builds those class objects. This work is largely driven
-;;;; off of those class definitions, but the fact that STANDARD-CLASS is the
-;;;; class of all metaclasses in the braid is built into this code pretty
-;;;; deeply.
+;;;; The code in this file takes the early definitions that have been
+;;;; saved up and actually builds those class objects. This work is
+;;;; largely driven off of those class definitions, but the fact that
+;;;; STANDARD-CLASS is the class of all metaclasses in the braid is
+;;;; built into this code pretty deeply.
 
 ;;;; This software is part of the SBCL system. See the README file for
 ;;;; more information.
@@ -44,7 +44,7 @@
 			(i 0 (1+ i)))
 		       ((>= i no-of-slots)) ;endp rem-slots))
 		     (declare (list rem-slots)
-			      (type sb-int:index i))
+			      (type index i))
 		     (setf (aref slots i) (first rem-slots)))
 		   slots))
 		(t
@@ -118,11 +118,6 @@
 	      classes)))
 
 (defun !bootstrap-meta-braid ()
-  (let* ((name 'class)
-	 (predicate-name (make-type-predicate-name name)))
-    (setf (gdefinition predicate-name)
-	  #'(lambda (x) (declare (ignore x)) t))
-    (do-satisfies-deftype name predicate-name))
   (let* ((*create-classes-from-internal-structure-definitions-p* nil)
 	 std-class-wrapper std-class
 	 standard-class-wrapper standard-class
@@ -264,9 +259,6 @@
       (setq *standard-method-combination* smc))))
 
 ;;; Initialize a class metaobject.
-;;;
-;;; FIXME: This and most stuff in this file is probably only needed at
-;;; init time.
 (defun !bootstrap-initialize-class
        (metaclass-name class name
 	class-eq-wrapper source direct-supers direct-subclasses cpl wrapper
@@ -317,7 +309,8 @@
 					(make-class-predicate-name name)))
 	  (set-slot 'defstruct-form
 		    `(defstruct (structure-object (:constructor
-						   ,constructor-sym))))
+						   ,constructor-sym)
+						  (:copier nil))))
 	  (set-slot 'defstruct-constructor constructor-sym)
 	  (set-slot 'from-defclass-p t)
 	  (set-slot 'plist nil)
@@ -604,9 +597,9 @@
 		 (reverse (rest (class-precedence-list class)))))
       (sb-kernel:register-layout layout :invalidate nil)
 
-      ;; Subclasses of formerly forward-referenced-class may be unknown
-      ;; to CL:FIND-CLASS and also anonymous. This functionality moved
-      ;; here from (SETF FIND-CLASS).
+      ;; Subclasses of formerly forward-referenced-class may be
+      ;; unknown to CL:FIND-CLASS and also anonymous. This
+      ;; functionality moved here from (SETF FIND-CLASS).
       (let ((name (class-name class)))
 	(setf (cl:find-class name) lclass
 	      ;; FIXME: It's nasty to use double colons. Perhaps the
@@ -618,42 +611,35 @@
 	      ;; messing with raw CLASS-%NAME)
 	      (sb-kernel::class-%name lclass) name)))))
 
-(eval-when (:load-toplevel :execute)
-
-  (clrhash *find-class*)
-  (!bootstrap-meta-braid)
-  (!bootstrap-accessor-definitions t)
-  (!bootstrap-class-predicates t)
-  (!bootstrap-accessor-definitions nil)
-  (!bootstrap-class-predicates nil)
-  (!bootstrap-built-in-classes)
-
-  (sb-int:dohash (name x *find-class*)
-    (let* ((class (find-class-from-cell name x))
-	   (layout (class-wrapper class))
-	   (lclass (sb-kernel:layout-class layout))
-	   (lclass-pcl-class (sb-kernel:class-pcl-class lclass))
-	   (olclass (cl:find-class name nil)))
-      (if lclass-pcl-class
-	  (assert (eq class lclass-pcl-class))
-	  (setf (sb-kernel:class-pcl-class lclass) class))
-
-      (update-lisp-class-layout class layout)
-
-      (cond (olclass
-	     (assert (eq lclass olclass)))
-	    (t
-	     (setf (cl:find-class name) lclass)))))
-
-  (setq *boot-state* 'braid)
+(clrhash *find-class*)
+(!bootstrap-meta-braid)
+(!bootstrap-accessor-definitions t)
+(!bootstrap-class-predicates t)
+(!bootstrap-accessor-definitions nil)
+(!bootstrap-class-predicates nil)
+(!bootstrap-built-in-classes)
+
+(dohash (name x *find-class*)
+	(let* ((class (find-class-from-cell name x))
+	       (layout (class-wrapper class))
+	       (lclass (sb-kernel:layout-class layout))
+	       (lclass-pcl-class (sb-kernel:class-pcl-class lclass))
+	       (olclass (cl:find-class name nil)))
+	  (if lclass-pcl-class
+	      (aver (eq class lclass-pcl-class))
+	      (setf (sb-kernel:class-pcl-class lclass) class))
+
+	  (update-lisp-class-layout class layout)
+
+	  (cond (olclass
+		 (aver (eq lclass olclass)))
+		(t
+		 (setf (cl:find-class name) lclass)))))
 
-  ) ; EVAL-WHEN
+(setq *boot-state* 'braid)
 
 (defmethod no-applicable-method (generic-function &rest args)
-  ;; FIXME: probably could be ERROR instead of CERROR
-  (cerror "Retry call to ~S."
-	  "There is no matching method for the generic function ~S~@
-	  when called with arguments ~S."
-	  generic-function
-	  args)
-  (apply generic-function args))
+  (error "~@<There is no matching method for the generic function ~2I~_~S~
+	  ~I~_when called with arguments ~2I~_~S.~:>"
+	 generic-function
+	 args))