X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fbraid.lisp;h=518abf7724e161bde91901f3683f67c93c630c5c;hb=57b330cc8334015f9953d7fb82a30afc82d2a471;hp=46b7a6cbe84337c453d3f41ce9f73f6b4dad9b40;hpb=0e7a9105ae992fc4befa37846c42f298e12918c0;p=sbcl.git diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 46b7a6c..518abf7 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -219,6 +219,8 @@ 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 @@ -310,7 +312,10 @@ slot-class)) (set-slot 'direct-slots direct-slots) (set-slot 'slots slots) - (set-slot 'slot-table (make-slot-table class 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 @@ -408,9 +413,10 @@ slot-name readers writers - nil))))))))) + nil + (ecd-source-location definition)))))))))) -(defun !bootstrap-accessor-definition (class-name accessor-name slot-name type) +(defun !bootstrap-accessor-definition (class-name accessor-name slot-name type source-location) (multiple-value-bind (accessor-class make-method-function arglist specls doc) (ecase type (reader (values 'standard-reader-method @@ -444,28 +450,33 @@ doc :slot-name slot-name :object-class class-name - :method-class-function (constantly (find-class accessor-class)))))))) + :method-class-function (constantly (find-class accessor-class)) + :definition-source source-location)))))) (defun !bootstrap-accessor-definitions1 (class-name - slot-name - readers - writers - boundps) + slot-name + readers + writers + boundps + source-location) (flet ((do-reader-definition (reader) (!bootstrap-accessor-definition class-name reader slot-name - 'reader)) + 'reader + source-location)) (do-writer-definition (writer) (!bootstrap-accessor-definition class-name writer slot-name - 'writer)) + 'writer + source-location)) (do-boundp-definition (boundp) (!bootstrap-accessor-definition class-name boundp slot-name - 'boundp))) + 'boundp + source-location))) (dolist (reader readers) (do-reader-definition reader)) (dolist (writer writers) (do-writer-definition writer)) (dolist (boundp boundps) (do-boundp-definition boundp)))) @@ -527,12 +538,10 @@ (defun eval-form (form) (lambda () (eval form))) -(defun ensure-non-standard-class (name &optional existing-class) +(defun ensure-non-standard-class (name classoid &optional existing-class) (flet ((ensure (metaclass &optional (slots nil slotsp)) - (let ((supers - (mapcar #'classoid-name (classoid-direct-superclasses - (find-classoid name))))) + (let ((supers (mapcar #'classoid-name (classoid-direct-superclasses classoid)))) (if slotsp (ensure-class-using-class existing-class name :metaclass metaclass :name name @@ -573,16 +582,16 @@ ((condition-type-p name) (ensure 'condition-class (mapcar #'slot-initargs-from-condition-slot - (condition-classoid-slots (find-classoid name))))) + (condition-classoid-slots classoid)))) (t (error "~@<~S is not the name of a class.~@:>" name))))) (defun ensure-deffoo-class (classoid) (let ((class (classoid-pcl-class classoid))) (cond (class - (ensure-non-standard-class (class-name class) class)) + (ensure-non-standard-class (class-name class) classoid class)) ((eq 'complete *boot-state*) - (ensure-non-standard-class (classoid-name classoid)))))) + (ensure-non-standard-class (classoid-name classoid) classoid))))) (pushnew 'ensure-deffoo-class sb-kernel::*defstruct-hooks*) (pushnew 'ensure-deffoo-class sb-kernel::*define-condition-hooks*) @@ -591,8 +600,8 @@ (defun make-class-predicate (class name) (let* ((gf (ensure-generic-function name :lambda-list '(object))) (mlist (if (eq *boot-state* 'complete) - (generic-function-methods gf) - (early-gf-methods gf)))) + (early-gf-methods gf) + (generic-function-methods gf)))) (unless mlist (unless (eq class *the-class-t*) (let* ((default-method-function #'constantly-nil) @@ -659,7 +668,6 @@ (setf (info :type :translator class) (lambda (spec) (declare (ignore spec)) classoid))))) -(clrhash *find-class*) (!bootstrap-meta-braid) (!bootstrap-accessor-definitions t) (!bootstrap-class-predicates t) @@ -667,24 +675,25 @@ (!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) sb-kernel::*classoid-cells*) + (when (classoid-cell-pcl-class x) + (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) @@ -706,11 +715,18 @@ ;;; :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 "~@" + (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 "~@" - generic-function - args)) + (error 'no-primary-method :generic-function generic-function :args args)) (defmethod invalid-qualifiers ((gf generic-function) combin