X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fbraid.lisp;h=ed76500b43edb34c339c0fb6e3de870fcc0e2df1;hb=f3f677703e37f5a335b3be7fa64f7748ad969517;hp=87fded0137289680227bbf2930fddd401cf8c1f1;hpb=ca379afc74fe525fd70035546d066de5f5ec874d;p=sbcl.git diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 87fded0..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 @@ -120,6 +119,7 @@ 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 @@ -128,7 +128,7 @@ 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 @@ -144,7 +144,8 @@ (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))) @@ -177,6 +178,8 @@ 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) @@ -185,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) @@ -232,6 +234,11 @@ (!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)) @@ -261,6 +268,7 @@ (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 @@ -277,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)) @@ -285,16 +294,17 @@ (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 @@ -311,21 +321,25 @@ (!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) @@ -360,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*) @@ -420,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) @@ -549,28 +564,45 @@ `(: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)))))) + :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)) + (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 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)))) @@ -668,7 +700,7 @@ (setq *boot-state* 'braid) (defmethod no-applicable-method (generic-function &rest args) - (error "~@" generic-function args)) @@ -690,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))))