X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fbraid.lisp;h=2c761aa08568e9b946cd5db88f286c2651ce1d83;hb=99df968112602d07a4b91492ab45367df27ee8ac;hp=a3cabbb1f8005ec675b75f6ffe847413899b1c26;hpb=3a5eefac8a65dfd36729031f0a9b9dd8c022b7f2;p=sbcl.git diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index a3cabbb..2c761aa 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -67,7 +67,7 @@ (get-instance-hash-code)))) (set-funcallable-instance-function fin - #'(instance-lambda (&rest args) + #'(lambda (&rest args) (declare (ignore args)) (error "The function of the funcallable-instance ~S has not been set." fin))) @@ -113,7 +113,6 @@ (defun !bootstrap-meta-braid () (let* ((*create-classes-from-internal-structure-definitions-p* nil) - std-class-wrapper std-class standard-class-wrapper standard-class funcallable-standard-class-wrapper funcallable-standard-class slot-class-wrapper slot-class @@ -128,7 +127,7 @@ standard-generic-function-wrapper standard-generic-function) (!initial-classes-and-wrappers standard-class funcallable-standard-class - slot-class built-in-class structure-class condition-class std-class + slot-class built-in-class structure-class condition-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 @@ -139,7 +138,6 @@ (meta (ecd-metaclass definition)) (wrapper (ecase meta (slot-class slot-class-wrapper) - (std-class std-class-wrapper) (standard-class standard-class-wrapper) (funcallable-standard-class funcallable-standard-class-wrapper) @@ -152,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))) @@ -163,8 +161,6 @@ (let* ((class (find-class name)) (wrapper (cond ((eq class slot-class) slot-class-wrapper) - ((eq class std-class) - std-class-wrapper) ((eq class standard-class) standard-class-wrapper) ((eq class funcallable-standard-class) @@ -214,7 +210,7 @@ standard-effective-slot-definition-wrapper t)) (case meta - ((std-class standard-class funcallable-standard-class) + ((standard-class funcallable-standard-class) (!bootstrap-initialize-class meta class name class-eq-specializer-wrapper source @@ -251,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)))) @@ -270,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) @@ -292,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)) @@ -302,7 +296,7 @@ `(default-initargs ,default-initargs)))) (when (memq metaclass-name '(standard-class funcallable-standard-class structure-class condition-class - slot-class std-class)) + slot-class)) (set-slot 'direct-slots direct-slots) (set-slot 'slots slots)) @@ -324,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) @@ -367,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)) @@ -408,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) @@ -475,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 () @@ -520,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)) @@ -592,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)))