X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fbraid.lisp;h=2c761aa08568e9b946cd5db88f286c2651ce1d83;hb=99df968112602d07a4b91492ab45367df27ee8ac;hp=776822fec7c6f4b661dd44619a2539332807da3a;hpb=1a405defbd26ca767e71494b67127fcc00a8af12;p=sbcl.git diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 776822f..2c761aa 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -150,7 +150,7 @@ (dolist (definition *early-class-definitions*) (let ((name (ecd-class-name definition)) (meta (ecd-metaclass definition)) - (source (ecd-source definition)) + (source (ecd-source-location definition)) (direct-supers (ecd-superclass-names definition)) (direct-slots (ecd-canonical-slots definition)) (other-initargs (ecd-other-initargs definition))) @@ -247,9 +247,9 @@ smc name value))) - (set-slot 'source *load-pathname*) - (set-slot 'type 'standard) - (set-slot 'documentation "The standard method combination.") + (set-slot 'source nil) + (set-slot 'type-name 'standard) + (set-slot '%documentation "The standard method combination.") (set-slot 'options ())) (setq *standard-method-combination* smc)))) @@ -266,21 +266,21 @@ (set-slot 'name name) (set-slot 'finalized-p t) (set-slot 'source source) - (set-slot 'type (if (eq class (find-class t)) - t - ;; FIXME: Could this just be CLASS instead - ;; of `(CLASS ,CLASS)? If not, why not? - ;; (See also similar expression in - ;; SHARED-INITIALIZE :BEFORE (CLASS).) - `(class ,class))) + (set-slot '%type (if (eq class (find-class t)) + t + ;; FIXME: Could this just be CLASS instead + ;; of `(CLASS ,CLASS)? If not, why not? + ;; (See also similar expression in + ;; SHARED-INITIALIZE :BEFORE (CLASS).) + `(class ,class))) (set-slot 'class-eq-specializer (let ((spec (allocate-standard-instance class-eq-wrapper))) - (!bootstrap-set-slot 'class-eq-specializer spec 'type + (!bootstrap-set-slot 'class-eq-specializer spec '%type `(class-eq ,class)) (!bootstrap-set-slot 'class-eq-specializer spec 'object class) spec)) - (set-slot 'class-precedence-list (classes cpl)) + (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) @@ -288,9 +288,7 @@ (set-slot 'direct-subclasses (classes direct-subclasses)) (set-slot 'direct-methods (cons nil nil)) (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 '%documentation nil) (set-slot 'plist `(,@(and direct-default-initargs `(direct-default-initargs ,direct-default-initargs)) @@ -320,9 +318,6 @@ (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) @@ -363,9 +358,9 @@ (set-val 'readers (get-val :readers)) (set-val 'writers (get-val :writers)) (set-val 'allocation :instance) - (set-val 'type (or (get-val :type) t)) - (set-val 'documentation (or (get-val :documentation) "")) - (set-val 'class class) + (set-val '%type (or (get-val :type) t)) + (set-val '%documentation (or (get-val :documentation) "")) + (set-val '%class class) (when effective-p (set-val 'location index) (let ((fsc-p nil)) @@ -404,13 +399,7 @@ slot-name readers writers - nil) - (!bootstrap-accessor-definitions1 - 'slot-object - slot-name - (list (slot-reader-name slot-name)) - (list (slot-writer-name slot-name)) - (list (slot-boundp-name slot-name))))))))))) + nil))))))))) (defun !bootstrap-accessor-definition (class-name accessor-name slot-name type) (multiple-value-bind (accessor-class make-method-function arglist specls doc) @@ -471,13 +460,13 @@ (dolist (writer writers) (do-writer-definition writer)) (dolist (boundp boundps) (do-boundp-definition boundp)))) +;;; FIXME: find a better name. (defun !bootstrap-class-predicates (early-p) (let ((*early-p* early-p)) - (dolist (definition *early-class-definitions*) - (let* ((name (ecd-class-name definition)) - (class (find-class name))) - (setf (find-class-predicate name) - (make-class-predicate class (class-predicate-name class))))))) + (dolist (ecp *early-class-predicates*) + (let ((class-name (car ecp)) + (predicate-name (cadr ecp))) + (make-class-predicate (find-class class-name) predicate-name))))) (defun !bootstrap-built-in-classes () @@ -516,13 +505,7 @@ name class-eq-wrapper nil supers subs (cons name cpl) - wrapper prototype))))) - - (dolist (e *built-in-classes*) - (let* ((name (car e)) - (class (find-class name))) - (setf (find-class-predicate name) - (make-class-predicate class (class-predicate-name class)))))) + wrapper prototype)))))) (defmacro wrapper-of-macro (x) `(layout-of ,x)) @@ -588,14 +571,15 @@ (t (error "~@<~S is not the name of a class.~@:>" name))))) -(defun ensure-defstruct-class (classoid) +(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)))))) -(pushnew 'ensure-defstruct-class sb-kernel::*defstruct-hooks*) +(pushnew 'ensure-deffoo-class sb-kernel::*defstruct-hooks*) +(pushnew 'ensure-deffoo-class sb-kernel::*define-condition-hooks*) (defun make-class-predicate (class name) (let* ((gf (ensure-generic-function name :lambda-list '(object)))