(slots-init nil slots-init-p))
(let ((fin (%make-pcl-funcallable-instance nil nil
(get-instance-hash-code))))
- (set-funcallable-instance-fun
+ (set-funcallable-instance-function
fin
- #'(sb-kernel:instance-lambda (&rest args)
+ #'(instance-lambda (&rest args)
(declare (ignore args))
(error "The function of the funcallable-instance ~S has not been set."
fin)))
(metaclass-name class name
class-eq-wrapper source direct-supers direct-subclasses cpl wrapper
&optional
- proto direct-slots slots direct-default-initargs default-initargs)
+ (proto nil proto-p)
+ direct-slots slots direct-default-initargs default-initargs)
(flet ((classes (names) (mapcar #'find-class names))
(set-slot (slot-name value)
(!bootstrap-set-slot metaclass-name class slot-name value)))
(set-slot 'from-defclass-p t)
(set-slot 'plist nil)
(set-slot 'prototype (funcall constructor-sym)))
- (set-slot 'prototype (or proto (allocate-standard-instance wrapper))))
+ (set-slot 'prototype
+ (if proto-p proto (allocate-standard-instance wrapper))))
class))
(defun !bootstrap-make-slot-definitions (name class slots wrapper effective-p)
(dolist (e *built-in-classes*)
(destructuring-bind (name supers subs cpl prototype) e
(let* ((class (find-class name))
- (lclass (sb-kernel:find-classoid name))
- (wrapper (sb-kernel:classoid-layout lclass)))
+ (lclass (find-classoid name))
+ (wrapper (classoid-layout lclass)))
(set (get-built-in-class-symbol name) class)
(set (get-built-in-wrapper-symbol name) wrapper)
- (setf (sb-kernel:classoid-pcl-class lclass) class)
+ (setf (classoid-pcl-class lclass) class)
(!bootstrap-initialize-class 'built-in-class class
name class-eq-wrapper nil
(make-class-predicate class (class-predicate-name class))))))
\f
(defmacro wrapper-of-macro (x)
- `(sb-kernel:layout-of ,x))
+ `(layout-of ,x))
(defun class-of (x)
(wrapper-class* (wrapper-of-macro x)))
(defun wrapper-of (x)
(wrapper-of-macro x))
-(defvar *find-structure-class* nil)
-
(defun eval-form (form)
(lambda () (eval form)))
:initform ,(structure-slotd-init-form slotd)
:initfunction ,(eval-form (structure-slotd-init-form slotd))))
-(defun find-structure-class (symbol)
- (if (structure-type-p symbol)
- (unless (eq *find-structure-class* symbol)
- (let ((*find-structure-class* symbol))
- (ensure-class symbol
- :metaclass 'structure-class
- :name symbol
- :direct-superclasses
- (mapcar #'sb-kernel:classoid-name
- (sb-kernel:classoid-direct-superclasses
- (sb-kernel:find-classoid symbol)))
- :direct-slots
- (mapcar #'slot-initargs-from-structure-slotd
- (structure-type-slot-description-list
- symbol)))))
- (error "~S is not a legal structure class name." symbol)))
+(defun ensure-non-standard-class (name)
+ (flet
+ ((ensure (metaclass &optional (slots nil slotsp))
+ (let ((supers
+ (mapcar #'classoid-name (classoid-direct-superclasses
+ (find-classoid name)))))
+ (if slotsp
+ (ensure-class-using-class name nil
+ :metaclass metaclass :name name
+ :direct-superclasses supers
+ :direct-slots slots)
+ (ensure-class-using-class name nil
+ :metaclass metaclass :name name
+ :direct-superclasses supers)))))
+ (cond ((structure-type-p name)
+ (ensure 'structure-class
+ (mapcar #'slot-initargs-from-structure-slotd
+ (structure-type-slot-description-list name))))
+ ((condition-type-p name)
+ (ensure 'condition-class))
+ (t
+ (error "~@<~S is not the name of a class.~@:>" name)))))
\f
(defun make-class-predicate (class name)
(let* ((gf (ensure-generic-function name))
;;; Set the inherits from CPL, and register the layout. This actually
;;; installs the class in the Lisp type system.
(defun update-lisp-class-layout (class layout)
- (let ((lclass (sb-kernel:layout-classoid layout)))
- (unless (eq (sb-kernel:classoid-layout lclass) layout)
- (setf (sb-kernel:layout-inherits layout)
- (sb-kernel:order-layout-inherits
+ (let ((lclass (layout-classoid layout)))
+ (unless (eq (classoid-layout lclass) layout)
+ (setf (layout-inherits layout)
+ (order-layout-inherits
(map 'simple-vector #'class-wrapper
(reverse (rest (class-precedence-list class))))))
- (sb-kernel:register-layout layout :invalidate t)
+ (register-layout layout :invalidate t)
;; 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 (sb-kernel:find-classoid name) lclass
- (sb-kernel:classoid-name lclass) name)))))
+ (setf (find-classoid name) lclass
+ (classoid-name lclass) name)))))
(defun set-class-type-translation (class name)
- (let ((classoid (sb-kernel:find-classoid name nil)))
+ (let ((classoid (find-classoid name nil)))
(etypecase classoid
(null)
- (sb-kernel:built-in-classoid
- (let ((translation (sb-kernel::built-in-classoid-translation classoid)))
+ (built-in-classoid
+ (let ((translation (built-in-classoid-translation classoid)))
(cond
(translation
- (aver (sb-kernel:ctype-p 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))))))
- (sb-kernel:classoid
+ (classoid
(setf (info :type :translator class)
(lambda (spec) (declare (ignore spec)) classoid))))))
(dohash (name x *find-class*)
(let* ((class (find-class-from-cell name x))
(layout (class-wrapper class))
- (lclass (sb-kernel:layout-classoid layout))
- (lclass-pcl-class (sb-kernel:classoid-pcl-class lclass))
- (olclass (sb-kernel:find-classoid name nil)))
+ (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 (sb-kernel:classoid-pcl-class lclass) class))
+ (setf (classoid-pcl-class lclass) class))
(update-lisp-class-layout class layout)
(cond (olclass
(aver (eq lclass olclass)))
(t
- (setf (sb-kernel:find-classoid name) lclass)))
+ (setf (find-classoid name) lclass)))
(set-class-type-translation class name)))
projects / sbcl.git / blobdiff