X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fbraid.lisp;h=ed76500b43edb34c339c0fb6e3de870fcc0e2df1;hb=ad3beba970fab6e451a461c9f9b14faf4ef17718;hp=e236279e985720704d978492befe9c29c5f75201;hpb=83e5661ae59addac315e6754013b3887b477570f;p=sbcl.git diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index e236279..ed76500 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -97,8 +97,7 @@ (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 @@ -189,12 +188,11 @@ (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) @@ -287,6 +285,7 @@ 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)) @@ -295,6 +294,7 @@ (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)) @@ -304,8 +304,7 @@ 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 @@ -375,11 +374,11 @@ (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*) @@ -435,7 +434,8 @@ (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) @@ -564,7 +564,7 @@ `(:internal-reader-function ,(structure-slotd-reader-function slotd) :internal-writer-function - ,(structure-slotd-writer-function slotd))) + ,(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))))) @@ -579,8 +579,8 @@ `(:initfunction ,form-or-fun) `(:initform ,form-or-fun :initfunction ,(lambda () form-or-fun))))) - :allocation (condition-slot-allocation slot) - :documentation (condition-slot-documentation slot)))) + :allocation ,(condition-slot-allocation slot) + :documentation ,(condition-slot-documentation slot)))) (cond ((structure-type-p name) (ensure 'structure-class (mapcar #'slot-initargs-from-structure-slotd @@ -592,15 +592,17 @@ (t (error "~@<~S is not the name of a class.~@:>" name))))) -(defun maybe-reinitialize-structure-class (classoid) +(defun ensure-defstruct-class (classoid) (let ((class (classoid-pcl-class classoid))) - (when class - (ensure-non-standard-class (class-name class) class)))) + (cond (class + (ensure-non-standard-class (class-name class) class)) + ((eq 'complete *boot-state*) + (ensure-non-standard-class (classoid-name classoid)))))) -(pushnew 'maybe-reinitialize-structure-class sb-kernel::*defstruct-hooks*) +(pushnew 'ensure-defstruct-class sb-kernel::*defstruct-hooks*) (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)))) @@ -698,7 +700,7 @@ (setq *boot-state* 'braid) (defmethod no-applicable-method (generic-function &rest args) - (error "~@" generic-function args)) @@ -720,3 +722,20 @@ ~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))))