(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
#'(instance-lambda (&rest args)
(declare (ignore args))
(defmacro !initial-classes-and-wrappers (&rest classes)
`(progn
,@(mapcar (lambda (class)
- (let ((wr (intern (format nil "~A-WRAPPER" class)
- *pcl-package*)))
+ (let ((wr (format-symbol *pcl-package* "~A-WRAPPER" class)))
`(setf ,wr ,(if (eq class 'standard-generic-function)
'*sgf-wrapper*
`(boot-make-wrapper
slot-class-wrapper slot-class
built-in-class-wrapper built-in-class
structure-class-wrapper structure-class
+ condition-class-wrapper condition-class
standard-direct-slot-definition-wrapper
standard-direct-slot-definition
standard-effective-slot-definition-wrapper
standard-generic-function-wrapper standard-generic-function)
(!initial-classes-and-wrappers
standard-class funcallable-standard-class
- slot-class built-in-class structure-class std-class
+ slot-class built-in-class structure-class condition-class std-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
(funcallable-standard-class
funcallable-standard-class-wrapper)
(built-in-class built-in-class-wrapper)
- (structure-class structure-class-wrapper)))
+ (structure-class structure-class-wrapper)
+ (condition-class condition-class-wrapper)))
(class (or (find-class name nil)
(allocate-standard-instance wrapper))))
(setf (find-class name) class)))
built-in-class-wrapper)
((eq class structure-class)
structure-class-wrapper)
+ ((eq class condition-class)
+ condition-class-wrapper)
((eq class class-eq-specializer)
class-eq-specializer-wrapper)
((eq class standard-generic-function)
(boot-make-wrapper (length slots) name))))
(proto nil))
(when (eq name t) (setq *the-wrapper-of-t* wrapper))
- (set (intern (format nil "*THE-CLASS-~A*" (symbol-name name))
- *pcl-package*)
- class)
+ (set (make-class-symbol name) class)
(dolist (slot slots)
(unless (eq (getf slot :allocation :instance) :instance)
- (error "Slot allocation ~S is not supported in bootstrap.")))
+ (error "Slot allocation ~S is not supported in bootstrap."
+ (getf slot :allocation))))
(when (typep wrapper 'wrapper)
(setf (wrapper-instance-slots-layout wrapper)
(!bootstrap-initialize-class
meta
class name class-eq-specializer-wrapper source
+ direct-supers direct-subclasses cpl wrapper))
+ (condition-class
+ (!bootstrap-initialize-class
+ meta
+ class name class-eq-specializer-wrapper source
direct-supers direct-subclasses cpl wrapper))))))))
(let* ((smc-class (find-class 'standard-method-combination))
(set-slot (slot-name value)
(!bootstrap-set-slot metaclass-name class slot-name value)))
(set-slot 'name name)
+ (set-slot 'finalized-p t)
(set-slot 'source source)
(set-slot 'type (if (eq class (find-class t))
t
class)
spec))
(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-superclasses (classes direct-supers))
(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 'plist
`(,@(and direct-default-initargs
`(direct-default-initargs ,direct-default-initargs))
,@(and default-initargs
`(default-initargs ,default-initargs))))
(when (memq metaclass-name '(standard-class funcallable-standard-class
- structure-class slot-class std-class))
+ structure-class condition-class
+ slot-class std-class))
(set-slot 'direct-slots direct-slots)
- (set-slot 'slots slots)
- (set-slot 'initialize-info nil))
+ (set-slot 'slots slots))
;; For all direct superclasses SUPER of CLASS, make sure CLASS is
;; a direct subclass of SUPER. Note that METACLASS-NAME doesn't
(!bootstrap-set-slot metaclass-name super 'direct-subclasses
(cons class subclasses))))))
- (if (eq 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)
- (:copier nil))))
- (set-slot 'defstruct-constructor constructor-sym)
- (set-slot 'from-defclass-p t)
- (set-slot 'plist nil)
- (set-slot 'prototype (funcall constructor-sym)))
- (set-slot 'prototype
- (if proto-p proto (allocate-standard-instance wrapper))))
+ (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)
+ (:copier nil))))
+ (set-slot 'defstruct-constructor constructor-sym)
+ (set-slot 'from-defclass-p t)
+ (set-slot 'plist nil)
+ (set-slot 'prototype (funcall constructor-sym))))
+ (condition-class
+ (set-slot 'prototype (make-condition name)))
+ (t
+ (set-slot 'prototype
+ (if proto-p proto (allocate-standard-instance wrapper)))))
class))
(defun !bootstrap-make-slot-definitions (name class slots wrapper effective-p)
(set-val 'location index)
(let ((fsc-p nil))
(set-val 'reader-function (make-optimized-std-reader-method-function
- fsc-p slot-name index))
+ fsc-p nil slot-name index))
(set-val 'writer-function (make-optimized-std-writer-method-function
- fsc-p slot-name index))
+ fsc-p nil slot-name index))
(set-val 'boundp-function (make-optimized-std-boundp-method-function
- fsc-p slot-name index)))
+ 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*)
(list class-name)
(list class-name)
"automatically generated boundp method")))
- (let ((gf (ensure-generic-function accessor-name)))
+ (let ((gf (ensure-generic-function accessor-name
+ :lambda-list arglist)))
(if (find specls (early-gf-methods gf)
:key #'early-method-specializers
:test 'equal)
(defun wrapper-of (x)
(wrapper-of-macro x))
-(defvar *find-structure-class* nil)
-
(defun eval-form (form)
(lambda () (eval form)))
-(defun slot-initargs-from-structure-slotd (slotd)
- `(:name ,(structure-slotd-name slotd)
- :defstruct-accessor-symbol ,(structure-slotd-accessor-symbol slotd)
- :internal-reader-function ,(structure-slotd-reader-function slotd)
- :internal-writer-function ,(structure-slotd-writer-function slotd)
- :type ,(or (structure-slotd-type slotd) t)
- :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 #'classoid-name
- (classoid-direct-superclasses
- (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 &optional existing-class)
+ (flet
+ ((ensure (metaclass &optional (slots nil slotsp))
+ (let ((supers
+ (mapcar #'classoid-name (classoid-direct-superclasses
+ (find-classoid name)))))
+ (if slotsp
+ (ensure-class-using-class existing-class name
+ :metaclass metaclass :name name
+ :direct-superclasses supers
+ :direct-slots slots)
+ (ensure-class-using-class existing-class name
+ :metaclass metaclass :name name
+ :direct-superclasses supers))))
+ (slot-initargs-from-structure-slotd (slotd)
+ (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)))
+ :type ,(or (structure-slotd-type slotd) t)
+ :initform ,(structure-slotd-init-form slotd)
+ :initfunction ,(eval-form (structure-slotd-init-form slotd)))))
+ (slot-initargs-from-condition-slot (slot)
+ `(:name ,(condition-slot-name slot)
+ :initargs ,(condition-slot-initargs slot)
+ :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)))))
+ :allocation ,(condition-slot-allocation slot)
+ :documentation ,(condition-slot-documentation slot))))
+ (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
+ (mapcar #'slot-initargs-from-condition-slot
+ (condition-classoid-slots (find-classoid name)))))
+ (t
+ (error "~@<~S is not the name of a class.~@:>" name)))))
+
+(defun ensure-defstruct-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))))))
+
+(pushnew 'ensure-defstruct-class sb-kernel::*defstruct-hooks*)
\f
(defun make-class-predicate (class name)
- (let* ((gf (ensure-generic-function name))
+ (let* ((gf (ensure-generic-function name :lambda-list '(object)))
(mlist (if (eq *boot-state* 'complete)
(generic-function-methods gf)
(early-gf-methods gf))))
(setq *boot-state* 'braid)
(defmethod no-applicable-method (generic-function &rest args)
- (error "~@<There is no matching method for the generic function ~2I~_~S~
+ (error "~@<There is no applicable method for the generic function ~2I~_~S~
~I~_when called with arguments ~2I~_~S.~:>"
generic-function
args))
~I~_when called with arguments ~2I~_~S.~:>"
generic-function
args))
+
+(defmethod invalid-qualifiers ((gf generic-function)
+ combin
+ method)
+ (let ((qualifiers (method-qualifiers method)))
+ (let ((why (cond
+ ((cdr qualifiers) "has too many qualifiers")
+ (t (aver (not (member (car qualifiers)
+ '(:around :before :after))))
+ "has an invalid qualifier"))))
+ (invalid-method-error
+ method
+ "The method ~S on ~S ~A.~%~
+ Standard method combination requires all methods to have one~%~
+ of the single qualifiers :AROUND, :BEFORE and :AFTER or to~%~
+ have no qualifier at all."
+ method gf why))))