- (setf (cl:find-class name) lclass
- ;; FIXME: It's nasty to use double colons. Perhaps the
- ;; best way to fix this is not to export CLASS-%NAME
- ;; from SB-KERNEL, but instead to move the whole
- ;; UPDATE-LISP-CLASS-LAYOUT function to SB-KERNEL, and
- ;; export it. (since it's also nasty for us to be
- ;; reaching into %KERNEL implementation details my
- ;; 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)
-
- ) ; EVAL-WHEN
+ (setf (find-classoid name) lclass
+ (classoid-name lclass) name)))))
+
+(defun set-class-type-translation (class name)
+ (let ((classoid (find-classoid name nil)))
+ (etypecase classoid
+ (null)
+ (built-in-classoid
+ (let ((translation (built-in-classoid-translation classoid)))
+ (cond
+ (translation
+ (aver (ctype-p translation))
+ (setf (info :type :translator class)
+ (lambda (spec) (declare (ignore spec)) translation)))
+ (t
+ (setf (info :type :translator class)
+ (lambda (spec) (declare (ignore spec)) classoid))))))
+ (classoid
+ (setf (info :type :translator class)
+ (lambda (spec) (declare (ignore spec)) classoid))))))
+
+(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 (layout-classoid layout))
+ (lclass-pcl-class (classoid-pcl-class lclass))
+ (olclass (find-classoid name nil)))
+ (if lclass-pcl-class
+ (aver (eq class lclass-pcl-class))
+ (setf (classoid-pcl-class lclass) class))
+
+ (update-lisp-class-layout class layout)
+
+ (cond (olclass
+ (aver (eq lclass olclass)))
+ (t
+ (setf (find-classoid name) lclass)))
+
+ (set-class-type-translation class name)))
+
+(setq *boot-state* 'braid)