:initial-element +slot-unbound+))))
instance))
-(defmacro allocate-funcallable-instance-slots (wrapper &optional
- slots-init-p slots-init)
+(defmacro allocate-standard-funcallable-instance-slots
+ (wrapper &optional slots-init-p slots-init)
`(let ((no-of-slots (wrapper-no-of-instance-slots ,wrapper)))
- ,(if slots-init-p
- `(if ,slots-init-p
- (make-array no-of-slots :initial-contents ,slots-init)
- (make-array no-of-slots :initial-element +slot-unbound+))
- `(make-array no-of-slots :initial-element +slot-unbound+))))
-
-(defun allocate-funcallable-instance (wrapper &optional
- (slots-init nil slots-init-p))
- (let ((fin (%make-pcl-funcallable-instance nil nil
- (get-instance-hash-code))))
+ ,(if slots-init-p
+ `(if ,slots-init-p
+ (make-array no-of-slots :initial-contents ,slots-init)
+ (make-array no-of-slots :initial-element +slot-unbound+))
+ `(make-array no-of-slots :initial-element +slot-unbound+))))
+
+(define-condition unset-funcallable-instance-function
+ (reference-condition simple-error)
+ ()
+ (:default-initargs
+ :references (list '(:amop :generic-function allocate-instance)
+ '(:amop :function set-funcallable-instance-function))))
+
+(defun allocate-standard-funcallable-instance
+ (wrapper &optional (slots-init nil slots-init-p))
+ (let ((fin (%make-standard-funcallable-instance
+ nil nil (get-instance-hash-code))))
(set-funcallable-instance-function
fin
- #'(instance-lambda (&rest args)
+ #'(lambda (&rest args)
(declare (ignore args))
- (error "The function of the funcallable-instance ~S has not been set."
- fin)))
+ (error 'unset-funcallable-instance-function
+ :format-control "~@<The function of funcallable instance ~
+ ~S has not been set.~@:>"
+ :format-arguments (list fin))))
(setf (fsc-instance-wrapper fin) wrapper
- (fsc-instance-slots fin) (allocate-funcallable-instance-slots
- wrapper slots-init-p slots-init))
+ (fsc-instance-slots fin)
+ (allocate-standard-funcallable-instance-slots
+ wrapper slots-init-p slots-init))
fin))
(defun allocate-structure-instance (wrapper &optional
(defun !bootstrap-meta-braid ()
(let* ((*create-classes-from-internal-structure-definitions-p* nil)
- std-class-wrapper std-class
standard-class-wrapper standard-class
funcallable-standard-class-wrapper funcallable-standard-class
slot-class-wrapper slot-class
standard-generic-function-wrapper standard-generic-function)
(!initial-classes-and-wrappers
standard-class funcallable-standard-class
- slot-class built-in-class structure-class condition-class std-class
+ slot-class built-in-class structure-class condition-class
standard-direct-slot-definition standard-effective-slot-definition
class-eq-specializer standard-generic-function)
;; First, make a class metaobject for each of the early classes. For
(meta (ecd-metaclass definition))
(wrapper (ecase meta
(slot-class slot-class-wrapper)
- (std-class std-class-wrapper)
(standard-class standard-class-wrapper)
(funcallable-standard-class
funcallable-standard-class-wrapper)
(dolist (definition *early-class-definitions*)
(let ((name (ecd-class-name definition))
(meta (ecd-metaclass definition))
- (source (ecd-source definition))
+ (source (ecd-source-location definition))
(direct-supers (ecd-superclass-names definition))
(direct-slots (ecd-canonical-slots definition))
(other-initargs (ecd-other-initargs definition)))
(let* ((class (find-class name))
(wrapper (cond ((eq class slot-class)
slot-class-wrapper)
- ((eq class std-class)
- std-class-wrapper)
((eq class standard-class)
standard-class-wrapper)
((eq class funcallable-standard-class)
()))
(setq proto (if (eq meta 'funcallable-standard-class)
- (allocate-funcallable-instance wrapper)
+ (allocate-standard-funcallable-instance wrapper)
(allocate-standard-instance wrapper)))
(setq direct-slots
name class slots
standard-effective-slot-definition-wrapper t))
+ (setf (layout-slot-table wrapper) (make-slot-table class slots t))
+
(case meta
- ((std-class standard-class funcallable-standard-class)
+ ((standard-class funcallable-standard-class)
(!bootstrap-initialize-class
meta
class name class-eq-specializer-wrapper source
smc
name
value)))
- (set-slot 'source *load-pathname*)
- (set-slot 'type 'standard)
- (set-slot 'documentation "The standard method combination.")
+ (set-slot 'source nil)
+ (set-slot 'type-name 'standard)
+ (set-slot '%documentation "The standard method combination.")
(set-slot 'options ()))
(setq *standard-method-combination* smc))))
(set-slot 'name name)
(set-slot 'finalized-p t)
(set-slot 'source source)
- (set-slot 'type (if (eq class (find-class t))
- t
- ;; FIXME: Could this just be CLASS instead
- ;; of `(CLASS ,CLASS)? If not, why not?
- ;; (See also similar expression in
- ;; SHARED-INITIALIZE :BEFORE (CLASS).)
- `(class ,class)))
+ (set-slot 'safe-p nil)
+ (set-slot '%type (if (eq class (find-class t))
+ t
+ ;; FIXME: Could this just be CLASS instead
+ ;; of `(CLASS ,CLASS)? If not, why not?
+ ;; (See also similar expression in
+ ;; SHARED-INITIALIZE :BEFORE (CLASS).)
+ `(class ,class)))
(set-slot 'class-eq-specializer
(let ((spec (allocate-standard-instance class-eq-wrapper)))
- (!bootstrap-set-slot 'class-eq-specializer spec 'type
+ (!bootstrap-set-slot 'class-eq-specializer spec '%type
`(class-eq ,class))
(!bootstrap-set-slot 'class-eq-specializer spec 'object
class)
spec))
- (set-slot 'class-precedence-list (classes cpl))
+ (set-slot '%class-precedence-list (classes cpl))
(set-slot 'cpl-available-p t)
(set-slot 'can-precede-list (classes (cdr cpl)))
(set-slot 'incompatible-superclass-list nil)
(set-slot 'direct-subclasses (classes direct-subclasses))
(set-slot 'direct-methods (cons nil nil))
(set-slot 'wrapper wrapper)
- (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*))
- (make-class-predicate-name name)))
- (set-slot 'documentation nil)
+ (set-slot '%documentation nil)
(set-slot 'plist
`(,@(and direct-default-initargs
`(direct-default-initargs ,direct-default-initargs))
`(default-initargs ,default-initargs))))
(when (memq metaclass-name '(standard-class funcallable-standard-class
structure-class condition-class
- slot-class std-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)))))
;; For all direct superclasses SUPER of CLASS, make sure CLASS is
;; a direct subclass of SUPER. Note that METACLASS-NAME doesn't
(case metaclass-name
(structure-class
(let ((constructor-sym '|STRUCTURE-OBJECT class constructor|))
- (set-slot 'predicate-name (or (cadr (assoc name
- *early-class-predicates*))
- (make-class-predicate-name name)))
(set-slot 'defstruct-form
`(defstruct (structure-object (:constructor
,constructor-sym)
(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 'documentation (or (get-val :documentation) ""))
- (set-val 'class class)
+ (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))
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)
- (let ((table (or (gethash slot-name *name->class->slotd-table*)
- (setf (gethash slot-name *name->class->slotd-table*)
- (make-hash-table :test 'eq :size 5)))))
- (setf (gethash class table) slotd)))
+ (set-val 'accessor-flags 7))
(when (and (eq name 'standard-class)
(eq slot-name 'slots) effective-p)
(setq *the-eslotd-standard-class-slots* slotd))
slot-name
readers
writers
- nil)
- (!bootstrap-accessor-definitions1
- 'slot-object
- slot-name
- (list (slot-reader-name slot-name))
- (list (slot-writer-name slot-name))
- (list (slot-boundp-name slot-name)))))))))))
+ 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
(list class-name)
(list class-name)
"automatically generated boundp method")))
- (let ((gf (ensure-generic-function accessor-name
- :lambda-list arglist)))
+ (let ((gf (ensure-generic-function accessor-name :lambda-list arglist)))
(if (find specls (early-gf-methods gf)
:key #'early-method-specializers
:test 'equal)
(funcall make-method-function
class-name slot-name)
doc
- slot-name))))))
+ :slot-name slot-name
+ :object-class class-name
+ :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))))
+;;; FIXME: find a better name.
(defun !bootstrap-class-predicates (early-p)
(let ((*early-p* early-p))
- (dolist (definition *early-class-definitions*)
- (let* ((name (ecd-class-name definition))
- (class (find-class name)))
- (setf (find-class-predicate name)
- (make-class-predicate class (class-predicate-name class)))))))
+ (dolist (ecp *early-class-predicates*)
+ (let ((class-name (car ecp))
+ (predicate-name (cadr ecp)))
+ (make-class-predicate (find-class class-name) predicate-name)))))
(defun !bootstrap-built-in-classes ()
name class-eq-wrapper nil
supers subs
(cons name cpl)
- wrapper prototype)))))
-
- (dolist (e *built-in-classes*)
- (let* ((name (car e))
- (class (find-class name)))
- (setf (find-class-predicate name)
- (make-class-predicate class (class-predicate-name class))))))
+ 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
((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-defstruct-class (classoid)
+(defun ensure-deffoo-class (classoid)
(let ((class (classoid-pcl-class classoid)))
(cond (class
- (ensure-non-standard-class (class-name class) class))
+ (ensure-non-standard-class (class-name class) classoid class))
((eq 'complete *boot-state*)
- (ensure-non-standard-class (classoid-name classoid))))))
+ (ensure-non-standard-class (classoid-name classoid) classoid)))))
-(pushnew 'ensure-defstruct-class sb-kernel::*defstruct-hooks*)
+(pushnew 'ensure-deffoo-class sb-kernel::*defstruct-hooks*)
+(pushnew 'ensure-deffoo-class sb-kernel::*define-condition-hooks*)
\f
+;;; 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))))
+ (early-gf-methods gf)
+ (generic-function-methods gf))))
(unless mlist
(unless (eq class *the-class-t*)
(let* ((default-method-function #'constantly-nil)
- (default-method-initargs (list :function
- default-method-function))
+ (default-method-initargs (list :function default-method-function
+ 'plist '(:constant-value nil)))
(default-method (make-a-method
'standard-method
()
(list *the-class-t*)
default-method-initargs
"class predicate default method")))
- (setf (method-function-get default-method-function :constant-value)
- nil)
(add-method gf default-method)))
(let* ((class-method-function #'constantly-t)
- (class-method-initargs (list :function
- class-method-function))
+ (class-method-initargs (list :function class-method-function
+ 'plist '(:constant-value t)))
(class-method (make-a-method 'standard-method
()
(list 'object)
(list class)
class-method-initargs
"class predicate class method")))
- (setf (method-function-get class-method-function :constant-value) t)
(add-method gf class-method)))
gf))
;;; 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 (layout-classoid layout)))
- (unless (eq (classoid-layout lclass) 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)
(setf (layout-inherits layout)
- (order-layout-inherits
- (map 'simple-vector #'class-wrapper
- (reverse (rest (class-precedence-list class))))))
+ (order-layout-inherits
+ (map 'simple-vector #'class-wrapper
+ (reverse (rest (class-precedence-list class))))))
(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).
+ ;; FIXME: I don't think this should be necessary, but without it
+ ;; we are unable to compile (TYPEP foo '<class-name>) in the
+ ;; same file as the class is defined. If we had environments,
+ ;; then I think the classsoid whould only be associated with the
+ ;; name in that environment... Alternatively, fix the compiler
+ ;; so that TYPEP foo '<class-name> is slow but compileable.
(let ((name (class-name class)))
- (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*)
+ (when (and name (symbolp name) (eq name (classoid-name classoid)))
+ (setf (find-classoid name) classoid))))))
+
+(defun %set-class-type-translation (class classoid)
+ (when (not (typep classoid 'classoid))
+ (setq classoid (find-classoid classoid 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)))))
+
(!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)
;;; :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