name class slots
standard-effective-slot-definition-wrapper t))
+ (setf (layout-slot-table wrapper) (make-slot-table class slots t))
+
(case meta
((standard-class funcallable-standard-class)
(!bootstrap-initialize-class
(set-slot 'name name)
(set-slot 'finalized-p t)
(set-slot 'source source)
+ (set-slot 'safe-p nil)
(set-slot '%type (if (eq class (find-class t))
t
;; FIXME: Could this just be CLASS instead
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)))))
;; For all direct superclasses SUPER of CLASS, make sure CLASS is
;; a direct subclass of SUPER. Note that METACLASS-NAME doesn't
(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
(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)
(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)))
(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)
(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))
(!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) *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))
- (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