X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fbraid.lisp;h=ce6bbc17d70132bad900a8a754ec72fe30f50411;hb=440baf2d4f88579609615c6cbf598c336fb07445;hp=e4bcd4b636f0efa7ca262f13500ac5fc537c3768;hpb=9d9b3ca52e33f8b2d77e73d0f54788dc3b5a5e46;p=sbcl.git diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index e4bcd4b..ce6bbc1 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -86,19 +86,27 @@ wrapper slots-init-p slots-init)) fin)) -(defun allocate-structure-instance (wrapper &optional - (slots-init nil slots-init-p)) - (let* ((class (wrapper-class wrapper)) - (constructor (class-defstruct-constructor class))) - (if constructor - (let ((instance (funcall constructor)) - (slots (class-slots class))) - (when slots-init-p - (dolist (slot slots) - (setf (slot-value-using-class class instance slot) - (pop slots-init)))) - instance) - (error "can't allocate an instance of class ~S" (class-name class))))) +(defun classify-slotds (slotds) + (let (instance-slots class-slots custom-slots bootp) + (dolist (slotd slotds) + (let ((alloc (cond ((consp slotd) ; bootstrap + (setf bootp t) + :instance) + (t + (slot-definition-allocation slotd))))) + (case alloc + (:instance + (push slotd instance-slots)) + (:class + (push slotd class-slots)) + (t + (push slotd custom-slots))))) + (values (if bootp + (nreverse instance-slots) + (when slotds + (sort instance-slots #'< :key #'slot-definition-location))) + class-slots + custom-slots))) ;;;; BOOTSTRAP-META-BRAID ;;;; @@ -110,7 +118,7 @@ (let ((wr (format-symbol *pcl-package* "~A-WRAPPER" class))) `(setf ,wr ,(if (eq class 'standard-generic-function) '*sgf-wrapper* - `(boot-make-wrapper + `(!boot-make-wrapper (early-class-size ',class) ',class)) ,class (allocate-standard-instance @@ -191,7 +199,7 @@ ((eq class standard-generic-function) standard-generic-function-wrapper) (t - (boot-make-wrapper (length slots) name)))) + (!boot-make-wrapper (length slots) name)))) (proto nil)) (when (eq name t) (setq *the-wrapper-of-t* wrapper)) (set (make-class-symbol name) class) @@ -200,11 +208,8 @@ (error "Slot allocation ~S is not supported in bootstrap." (getf slot :allocation)))) - (when (typep wrapper 'wrapper) - (setf (wrapper-instance-slots-layout wrapper) - (mapcar #'canonical-slot-name slots)) - (setf (wrapper-class-slots wrapper) - ())) + (when (wrapper-p wrapper) + (setf (wrapper-slots wrapper) slots)) (setq proto (if (eq meta 'funcallable-standard-class) (allocate-standard-funcallable-instance wrapper) @@ -220,6 +225,8 @@ standard-effective-slot-definition-wrapper t)) (setf (layout-slot-table wrapper) (make-slot-table class slots t)) + (when (wrapper-p wrapper) + (setf (wrapper-slots wrapper) slots)) (case meta ((standard-class funcallable-standard-class) @@ -249,6 +256,11 @@ class name class-eq-specializer-wrapper source direct-supers direct-subclasses cpl wrapper)))))))) + (setq **standard-method-classes** + (mapcar (lambda (name) + (symbol-value (make-class-symbol name))) + *standard-method-class-names*)) + (let* ((smc-class (find-class 'standard-method-combination)) (smc-wrapper (!bootstrap-get-slot 'standard-class smc-class @@ -315,7 +327,9 @@ (setf (layout-slot-table wrapper) (make-slot-table class slots (member metaclass-name - '(standard-class funcallable-standard-class))))) + '(standard-class funcallable-standard-class)))) + (when (wrapper-p wrapper) + (setf (wrapper-slots wrapper) slots))) ;; For all direct superclasses SUPER of CLASS, make sure CLASS is ;; a direct subclass of SUPER. Note that METACLASS-NAME doesn't @@ -376,19 +390,20 @@ (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 (set-val 'location index) - (let ((fsc-p nil)) - (set-val 'reader-function (make-optimized-std-reader-method-function - fsc-p nil slot-name index)) - (set-val 'writer-function (make-optimized-std-writer-method-function - fsc-p nil slot-name index)) - (set-val 'boundp-function (make-optimized-std-boundp-method-function - fsc-p nil slot-name index))) - (set-val 'accessor-flags 7)) + (set-val 'accessor-flags 7) + (set-val + 'info + (make-slot-info + :reader + (make-optimized-std-reader-method-function nil nil slot-name index) + :writer + (make-optimized-std-writer-method-function nil nil slot-name index) + :boundp + (make-optimized-std-boundp-method-function nil nil slot-name index)))) (when (and (eq name 'standard-class) (eq slot-name 'slots) effective-p) (setq *the-eslotd-standard-class-slots* slotd)) @@ -413,9 +428,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 @@ -449,28 +465,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)))) @@ -532,12 +553,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 @@ -550,11 +569,8 @@ (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))) + :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))))) @@ -578,16 +594,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)) - ((eq 'complete *boot-state*) - (ensure-non-standard-class (classoid-name classoid)))))) + (ensure-non-standard-class (class-name class) classoid class)) + ((eq 'complete **boot-state**) + (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*) @@ -595,9 +611,9 @@ ;;; 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) - (generic-function-methods gf) - (early-gf-methods gf)))) + (mlist (if (eq **boot-state** 'complete) + (early-gf-methods gf) + (generic-function-methods gf)))) (unless mlist (unless (eq class *the-class-t*) (let* ((default-method-function #'constantly-nil) @@ -625,7 +641,8 @@ ;;; Set the inherits from CPL, and register the layout. This actually ;;; installs the class in the Lisp type system. -(defun update-lisp-class-layout (class layout) +(defun %update-lisp-class-layout (class layout) + ;; Protected by *world-lock* in callers. (let ((classoid (layout-classoid layout)) (olayout (class-wrapper class))) (unless (eq (classoid-layout classoid) layout) @@ -645,7 +662,7 @@ (when (and name (symbolp name) (eq name (classoid-name classoid))) (setf (find-classoid name) classoid)))))) -(defun set-class-type-translation (class classoid) +(defun %set-class-type-translation (class classoid) (when (not (typep classoid 'classoid)) (setq classoid (find-classoid classoid nil))) (etypecase classoid @@ -664,7 +681,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) @@ -672,26 +688,27 @@ (!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) +(setq **boot-state** 'braid) (defmethod no-applicable-method (generic-function &rest args) (error "~@