- (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)))))
+ (setf (sb-kernel:find-classoid name) lclass
+ (sb-kernel:classoid-name lclass) name)))))
+
+(defun set-class-type-translation (class name)
+ (let ((classoid (sb-kernel:find-classoid name nil)))
+ (etypecase classoid
+ (null)
+ (sb-kernel:built-in-classoid
+ (let ((translation (sb-kernel::built-in-classoid-translation classoid)))
+ (cond
+ (translation
+ (aver (sb-kernel: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))))))
+ (sb-kernel:classoid
+ (setf (info :type :translator class)
+ (lambda (spec) (declare (ignore spec)) classoid))))))