wrapper slots-init-p slots-init))
fin))
-(defun allocate-structure-instance (wrapper &optional
- (slots-init nil slots-init-p))
- (let* ((class (wrapper-class wrapper))
- (constructor (class-defstruct-constructor class)))
- (if constructor
- (let ((instance (funcall constructor))
- (slots (class-slots class)))
- (when slots-init-p
- (dolist (slot slots)
- (setf (slot-value-using-class class instance slot)
- (pop slots-init))))
- instance)
- (error "can't allocate an instance of class ~S" (class-name class)))))
+(defun classify-slotds (slotds)
+ (let (instance-slots class-slots custom-slots bootp)
+ (dolist (slotd slotds)
+ (let ((alloc (cond ((consp slotd) ; bootstrap
+ (setf bootp t)
+ :instance)
+ (t
+ (slot-definition-allocation slotd)))))
+ (case alloc
+ (:instance
+ (push slotd instance-slots))
+ (:class
+ (push slotd class-slots))
+ (t
+ (push slotd custom-slots)))))
+ (values (if bootp
+ (nreverse instance-slots)
+ (when slotds
+ (sort instance-slots #'< :key #'slot-definition-location)))
+ class-slots
+ custom-slots)))
\f
;;;; BOOTSTRAP-META-BRAID
;;;;
(let ((wr (format-symbol *pcl-package* "~A-WRAPPER" class)))
`(setf ,wr ,(if (eq class 'standard-generic-function)
'*sgf-wrapper*
- `(boot-make-wrapper
+ `(!boot-make-wrapper
(early-class-size ',class)
',class))
,class (allocate-standard-instance
((eq class standard-generic-function)
standard-generic-function-wrapper)
(t
- (boot-make-wrapper (length slots) name))))
+ (!boot-make-wrapper (length slots) name))))
(proto nil))
(when (eq name t) (setq *the-wrapper-of-t* wrapper))
(set (make-class-symbol name) class)
(error "Slot allocation ~S is not supported in bootstrap."
(getf slot :allocation))))
- (when (typep wrapper 'wrapper)
- (setf (wrapper-instance-slots-layout wrapper)
- (mapcar #'canonical-slot-name slots))
- (setf (wrapper-class-slots wrapper)
- ()))
+ (when (wrapper-p wrapper)
+ (setf (wrapper-slots wrapper) slots))
(setq proto (if (eq meta 'funcallable-standard-class)
(allocate-standard-funcallable-instance wrapper)
name class slots
standard-effective-slot-definition-wrapper t))
+ (setf (layout-slot-table wrapper) (make-slot-table class slots t))
+ (when (wrapper-p wrapper)
+ (setf (wrapper-slots wrapper) slots))
+
(case meta
((standard-class funcallable-standard-class)
(!bootstrap-initialize-class
class name class-eq-specializer-wrapper source
direct-supers direct-subclasses cpl wrapper))))))))
+ (setq **standard-method-classes**
+ (mapcar (lambda (name)
+ (symbol-value (make-class-symbol name)))
+ *standard-method-class-names*))
+
(let* ((smc-class (find-class 'standard-method-combination))
(smc-wrapper (!bootstrap-get-slot 'standard-class
smc-class
structure-class condition-class
slot-class))
(set-slot 'direct-slots direct-slots)
- (set-slot 'slots slots))
+ (set-slot 'slots slots)
+ (setf (layout-slot-table wrapper)
+ (make-slot-table class slots
+ (member metaclass-name
+ '(standard-class funcallable-standard-class))))
+ (when (wrapper-p wrapper)
+ (setf (wrapper-slots wrapper) slots)))
;; For all direct superclasses SUPER of CLASS, make sure CLASS is
;; a direct subclass of SUPER. Note that METACLASS-NAME doesn't
(set-val 'initform (get-val :initform))
(set-val 'initfunction (get-val :initfunction))
(set-val 'initargs (get-val :initargs))
- (set-val 'readers (get-val :readers))
- (set-val 'writers (get-val :writers))
+ (unless effective-p
+ (set-val 'readers (get-val :readers))
+ (set-val 'writers (get-val :writers)))
(set-val 'allocation :instance)
(set-val '%type (or (get-val :type) t))
- (set-val '%type-check-function (get-val 'type-check-function))
(set-val '%documentation (or (get-val :documentation) ""))
(set-val '%class class)
(when effective-p
(set-val 'location index)
- (let ((fsc-p nil))
- (set-val 'reader-function (make-optimized-std-reader-method-function
- fsc-p nil slot-name index))
- (set-val 'writer-function (make-optimized-std-writer-method-function
- fsc-p nil slot-name index))
- (set-val 'boundp-function (make-optimized-std-boundp-method-function
- fsc-p nil slot-name index)))
- (set-val 'accessor-flags 7))
+ (set-val 'accessor-flags 7)
+ (set-val
+ 'info
+ (make-slot-info
+ :reader
+ (make-optimized-std-reader-method-function nil nil slot-name index)
+ :writer
+ (make-optimized-std-writer-method-function nil nil slot-name index)
+ :boundp
+ (make-optimized-std-boundp-method-function nil nil slot-name index))))
(when (and (eq name 'standard-class)
(eq slot-name 'slots) effective-p)
(setq *the-eslotd-standard-class-slots* slotd))
slot-name
readers
writers
- nil)))))))))
+ nil
+ (ecd-source-location definition))))))))))
-(defun !bootstrap-accessor-definition (class-name accessor-name slot-name type)
+(defun !bootstrap-accessor-definition (class-name accessor-name slot-name type source-location)
(multiple-value-bind (accessor-class make-method-function arglist specls doc)
(ecase type
(reader (values 'standard-reader-method
doc
:slot-name slot-name
:object-class class-name
- :method-class-function (constantly (find-class accessor-class))))))))
+ :method-class-function (constantly (find-class accessor-class))
+ :definition-source source-location))))))
(defun !bootstrap-accessor-definitions1 (class-name
- slot-name
- readers
- writers
- boundps)
+ slot-name
+ readers
+ writers
+ boundps
+ source-location)
(flet ((do-reader-definition (reader)
(!bootstrap-accessor-definition class-name
reader
slot-name
- 'reader))
+ 'reader
+ source-location))
(do-writer-definition (writer)
(!bootstrap-accessor-definition class-name
writer
slot-name
- 'writer))
+ 'writer
+ source-location))
(do-boundp-definition (boundp)
(!bootstrap-accessor-definition class-name
boundp
slot-name
- 'boundp)))
+ 'boundp
+ source-location)))
(dolist (reader readers) (do-reader-definition reader))
(dolist (writer writers) (do-writer-definition writer))
(dolist (boundp boundps) (do-boundp-definition boundp))))
(cons name cpl)
wrapper prototype))))))
\f
-(defmacro wrapper-of-macro (x)
- `(layout-of ,x))
-
-(defun class-of (x)
- (wrapper-class* (wrapper-of-macro x)))
-
-;;; FIXME: We probably don't need both WRAPPER-OF and WRAPPER-OF-MACRO.
#-sb-fluid (declaim (inline wrapper-of))
(defun wrapper-of (x)
- (wrapper-of-macro x))
+ (layout-of x))
+
+(defun class-of (x)
+ (wrapper-class* (wrapper-of x)))
(defun eval-form (form)
(lambda () (eval form)))
-(defun ensure-non-standard-class (name &optional existing-class)
+(defun ensure-non-standard-class (name classoid &optional existing-class)
(flet
((ensure (metaclass &optional (slots nil slotsp))
- (let ((supers
- (mapcar #'classoid-name (classoid-direct-superclasses
- (find-classoid name)))))
+ (let ((supers (mapcar #'classoid-name (classoid-direct-superclasses classoid))))
(if slotsp
(ensure-class-using-class existing-class name
:metaclass metaclass :name name
(let ((accessor (structure-slotd-accessor-symbol slotd)))
`(:name ,(structure-slotd-name slotd)
:defstruct-accessor-symbol ,accessor
- ,@(when (fboundp accessor)
- `(:internal-reader-function
- ,(structure-slotd-reader-function slotd)
- :internal-writer-function
- ,(structure-slotd-writer-function name slotd)))
+ :internal-reader-function ,(structure-slotd-reader-function slotd)
+ :internal-writer-function ,(structure-slotd-writer-function name slotd)
:type ,(or (structure-slotd-type slotd) t)
:initform ,(structure-slotd-init-form slotd)
:initfunction ,(eval-form (structure-slotd-init-form slotd)))))
:readers ,(condition-slot-readers slot)
:writers ,(condition-slot-writers slot)
,@(when (condition-slot-initform-p slot)
- (let ((form-or-fun (condition-slot-initform slot)))
- (if (functionp form-or-fun)
- `(:initfunction ,form-or-fun)
- `(:initform ,form-or-fun
- :initfunction ,(lambda () form-or-fun)))))
+ (let ((initform (condition-slot-initform slot))
+ (initfun (condition-slot-initfunction slot)))
+ `(:initform ',initform :initfunction ,initfun)))
:allocation ,(condition-slot-allocation slot)
:documentation ,(condition-slot-documentation slot))))
(cond ((structure-type-p name)
((condition-type-p name)
(ensure 'condition-class
(mapcar #'slot-initargs-from-condition-slot
- (condition-classoid-slots (find-classoid name)))))
+ (condition-classoid-slots classoid))))
(t
(error "~@<~S is not the name of a class.~@:>" name)))))
(defun ensure-deffoo-class (classoid)
(let ((class (classoid-pcl-class classoid)))
(cond (class
- (ensure-non-standard-class (class-name class) class))
- ((eq 'complete *boot-state*)
- (ensure-non-standard-class (classoid-name classoid))))))
+ (ensure-non-standard-class (class-name class) classoid class))
+ ((eq 'complete **boot-state**)
+ (ensure-non-standard-class (classoid-name classoid) classoid)))))
(pushnew 'ensure-deffoo-class sb-kernel::*defstruct-hooks*)
(pushnew 'ensure-deffoo-class sb-kernel::*define-condition-hooks*)
;;; FIXME: only needed during bootstrap
(defun make-class-predicate (class name)
(let* ((gf (ensure-generic-function name :lambda-list '(object)))
- (mlist (if (eq *boot-state* 'complete)
- (generic-function-methods gf)
- (early-gf-methods gf))))
+ (mlist (if (eq **boot-state** 'complete)
+ (early-gf-methods gf)
+ (generic-function-methods gf))))
(unless mlist
(unless (eq class *the-class-t*)
(let* ((default-method-function #'constantly-nil)
;;; 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)
+(defun %update-lisp-class-layout (class layout)
+ ;; Protected by *world-lock* in callers.
(let ((classoid (layout-classoid layout))
(olayout (class-wrapper class)))
(unless (eq (classoid-layout classoid) layout)
(when (and name (symbolp name) (eq name (classoid-name classoid)))
(setf (find-classoid name) classoid))))))
-(defun set-class-type-translation (class classoid)
+(defun %set-class-type-translation (class classoid)
(when (not (typep classoid 'classoid))
(setq classoid (find-classoid classoid nil)))
(etypecase 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-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))
+(dohash ((name x) sb-kernel::*classoid-cells*)
+ (when (classoid-cell-pcl-class x)
+ (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)
+ (%update-lisp-class-layout class layout)
- (cond (olclass
- (aver (eq lclass olclass)))
- (t
- (setf (find-classoid name) lclass)))
+ (cond (olclass
+ (aver (eq lclass olclass)))
+ (t
+ (setf (find-classoid name) lclass)))
- (set-class-type-translation class name)))
+ (%set-class-type-translation class name))))
-(setq *boot-state* 'braid)
+(setq **boot-state** 'braid)
(defmethod no-applicable-method (generic-function &rest args)
(error "~@<There is no applicable method for the generic function ~2I~_~S~
;;; :BEFORE method, it would seem that going through
;;; NO-APPLICABLE-METHOD is prohibited, as in fact there is an
;;; applicable method. -- CSR, 2002-11-15
+(define-condition no-primary-method (reference-condition error)
+ ((generic-function :initarg :generic-function :reader no-primary-method-generic-function)
+ (args :initarg :args :reader no-primary-method-args))
+ (:report
+ (lambda (c s)
+ (format s "~@<There is no primary method for the generic function ~2I~_~S~
+ ~I~_when called with arguments ~2I~_~S.~:>"
+ (no-primary-method-generic-function c)
+ (no-primary-method-args c))))
+ (:default-initargs :references (list '(:ansi-cl :section (7 6 6 2)))))
(defmethod no-primary-method (generic-function &rest args)
- (error "~@<There is no primary method for the generic function ~2I~_~S~
- ~I~_when called with arguments ~2I~_~S.~:>"
- generic-function
- args))
+ (error 'no-primary-method :generic-function generic-function :args args))
(defmethod invalid-qualifiers ((gf generic-function)
combin
projects / sbcl.git / blobdiff