X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fbraid.lisp;h=82f15630bacd051853d5b3c14fca61b42bd8aefe;hb=227096b878fee7afae9d3bc2cee5df01449bca2d;hp=25bc778e029aab6dd80d9339e0e6a39a52d196d7;hpb=a736ac10b709b2d40305f0a6e3764afd246a8ef5;p=sbcl.git diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 25bc778..82f1563 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -65,7 +65,7 @@ (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)) @@ -120,6 +120,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 +129,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 +145,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 +179,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) @@ -190,7 +194,8 @@ 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 +237,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)) @@ -255,11 +265,13 @@ (metaclass-name class name class-eq-wrapper source direct-supers direct-subclasses cpl wrapper &optional - proto direct-slots slots direct-default-initargs default-initargs) + (proto nil proto-p) + direct-slots slots direct-default-initargs default-initargs) (flet ((classes (names) (mapcar #'find-class names)) (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 @@ -290,10 +302,10 @@ ,@(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 @@ -310,20 +322,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 (or 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) @@ -522,36 +539,65 @@ (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 maybe-reinitialize-structure-class (classoid) + (let ((class (classoid-pcl-class classoid))) + (when class + (ensure-non-standard-class (class-name class) class)))) + +(pushnew 'maybe-reinitialize-structure-class sb-kernel::*defstruct-hooks*) (defun make-class-predicate (class name) (let* ((gf (ensure-generic-function name)) @@ -652,7 +698,7 @@ (setq *boot-state* 'braid) (defmethod no-applicable-method (generic-function &rest args) - (error "~@" generic-function args)) @@ -674,3 +720,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))))