X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fbraid.lisp;h=8f1ef7ba8d3ccbe7e78a694c9f1130d756c17e1d;hb=961c6bf2eda5d492d5dbb7e275fe4e0931f7adf8;hp=a3cabbb1f8005ec675b75f6ffe847413899b1c26;hpb=3a5eefac8a65dfd36729031f0a9b9dd8c022b7f2;p=sbcl.git diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index a3cabbb..8f1ef7b 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -52,43 +52,61 @@ :initial-element +slot-unbound+)))) instance)) -(defmacro allocate-funcallable-instance-slots (wrapper &optional - slots-init-p slots-init) +(defmacro allocate-standard-funcallable-instance-slots + (wrapper &optional slots-init-p slots-init) `(let ((no-of-slots (wrapper-no-of-instance-slots ,wrapper))) - ,(if slots-init-p - `(if ,slots-init-p - (make-array no-of-slots :initial-contents ,slots-init) - (make-array no-of-slots :initial-element +slot-unbound+)) - `(make-array no-of-slots :initial-element +slot-unbound+)))) - -(defun allocate-funcallable-instance (wrapper &optional - (slots-init nil slots-init-p)) - (let ((fin (%make-pcl-funcallable-instance nil nil - (get-instance-hash-code)))) + ,(if slots-init-p + `(if ,slots-init-p + (make-array no-of-slots :initial-contents ,slots-init) + (make-array no-of-slots :initial-element +slot-unbound+)) + `(make-array no-of-slots :initial-element +slot-unbound+)))) + +(define-condition unset-funcallable-instance-function + (reference-condition simple-error) + () + (:default-initargs + :references (list '(:amop :generic-function allocate-instance) + '(:amop :function set-funcallable-instance-function)))) + +(defun allocate-standard-funcallable-instance + (wrapper &optional (slots-init nil slots-init-p)) + (let ((fin (%make-standard-funcallable-instance + nil nil (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))) + (error 'unset-funcallable-instance-function + :format-control "~@" + :format-arguments (list fin)))) (setf (fsc-instance-wrapper fin) wrapper - (fsc-instance-slots fin) (allocate-funcallable-instance-slots - wrapper slots-init-p slots-init)) + (fsc-instance-slots fin) + (allocate-standard-funcallable-instance-slots + 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 ;;;; @@ -100,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 @@ -113,7 +131,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 +145,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 +156,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 +168,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 +179,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) @@ -185,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) @@ -194,14 +208,11 @@ (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-funcallable-instance wrapper) + (allocate-standard-funcallable-instance wrapper) (allocate-standard-instance wrapper))) (setq direct-slots @@ -213,8 +224,12 @@ name class slots 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 - ((std-class standard-class funcallable-standard-class) + ((standard-class funcallable-standard-class) (!bootstrap-initialize-class meta class name class-eq-specializer-wrapper source @@ -241,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 @@ -251,9 +271,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 +290,22 @@ (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 'safe-p nil) + (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 +313,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,9 +321,15 @@ `(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)) + (set-slot 'slots slots) + (setf (layout-slot-table wrapper) + (make-slot-table class slots + (member metaclass-name + '(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 @@ -324,9 +349,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) @@ -364,26 +386,25 @@ (set-val 'initform (get-val :initform)) (set-val 'initfunction (get-val :initfunction)) (set-val 'initargs (get-val :initargs)) - (set-val 'readers (get-val :readers)) - (set-val 'writers (get-val :writers)) + (unless effective-p + (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)) - (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) - (let ((table (or (gethash slot-name *name->class->slotd-table*) - (setf (gethash slot-name *name->class->slotd-table*) - (make-hash-table :test 'eq :size 5))))) - (setf (gethash class table) slotd))) + (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)) @@ -408,15 +429,10 @@ 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 + (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 @@ -434,8 +450,7 @@ (list class-name) (list class-name) "automatically generated boundp method"))) - (let ((gf (ensure-generic-function accessor-name - :lambda-list arglist))) + (let ((gf (ensure-generic-function accessor-name :lambda-list arglist))) (if (find specls (early-gf-methods gf) :key #'early-method-specializers :test 'equal) @@ -449,39 +464,46 @@ (funcall make-method-function class-name slot-name) doc - slot-name)))))) + :slot-name slot-name + :object-class class-name + :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)))) +;;; 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,34 +542,22 @@ 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)) - -(defun class-of (x) - (wrapper-class* (wrapper-of-macro x))) - -;;; FIXME: We probably don't need both WRAPPER-OF and WRAPPER-OF-MACRO. #-sb-fluid (declaim (inline wrapper-of)) (defun wrapper-of (x) - (wrapper-of-macro x)) + (layout-of x)) + +(defun class-of (x) + (wrapper-class* (wrapper-of x))) (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 @@ -560,11 +570,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))))) @@ -574,11 +581,9 @@ :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))))) + (let ((initform (condition-slot-initform slot)) + (initfun (condition-slot-initfunction slot))) + `(:initform ',initform :initfunction ,initfun))) :allocation ,(condition-slot-allocation slot) :documentation ,(condition-slot-documentation slot)))) (cond ((structure-type-p name) @@ -588,29 +593,31 @@ ((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-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)))))) + (ensure-non-standard-class (class-name class) classoid class)) + ((eq 'complete **boot-state**) + (ensure-non-standard-class (classoid-name classoid) 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*) +;;; 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) - (default-method-initargs (list :function - default-method-function)) + (default-method-initargs (list :function default-method-function + 'plist '(:constant-value nil))) (default-method (make-a-method 'standard-method () @@ -618,59 +625,61 @@ (list *the-class-t*) default-method-initargs "class predicate default method"))) - (setf (method-function-get default-method-function :constant-value) - nil) (add-method gf default-method))) (let* ((class-method-function #'constantly-t) - (class-method-initargs (list :function - class-method-function)) + (class-method-initargs (list :function class-method-function + 'plist '(:constant-value t))) (class-method (make-a-method 'standard-method () (list 'object) (list class) class-method-initargs "class predicate class method"))) - (setf (method-function-get class-method-function :constant-value) t) (add-method gf class-method))) gf)) ;;; 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) - (let ((lclass (layout-classoid layout))) - (unless (eq (classoid-layout lclass) 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) (setf (layout-inherits layout) - (order-layout-inherits - (map 'simple-vector #'class-wrapper - (reverse (rest (class-precedence-list class)))))) + (order-layout-inherits + (map 'simple-vector #'class-wrapper + (reverse (rest (class-precedence-list class)))))) (register-layout layout :invalidate t) - ;; Subclasses of formerly forward-referenced-class may be - ;; unknown to CL:FIND-CLASS and also anonymous. This - ;; functionality moved here from (SETF FIND-CLASS). + ;; FIXME: I don't think this should be necessary, but without it + ;; we are unable to compile (TYPEP foo ') in the + ;; same file as the class is defined. If we had environments, + ;; then I think the classsoid whould only be associated with the + ;; name in that environment... Alternatively, fix the compiler + ;; so that TYPEP foo ' is slow but compileable. (let ((name (class-name class))) - (setf (find-classoid name) lclass - (classoid-name lclass) name))))) - -(defun set-class-type-translation (class name) - (let ((classoid (find-classoid name nil))) - (etypecase classoid - (null) - (built-in-classoid - (let ((translation (built-in-classoid-translation classoid))) - (cond - (translation - (aver (ctype-p translation)) - (setf (info :type :translator class) - (lambda (spec) (declare (ignore spec)) translation))) - (t - (setf (info :type :translator class) - (lambda (spec) (declare (ignore spec)) classoid)))))) - (classoid - (setf (info :type :translator class) - (lambda (spec) (declare (ignore spec)) classoid)))))) - -(clrhash *find-class*) + (when (and name (symbolp name) (eq name (classoid-name classoid))) + (setf (find-classoid name) classoid)))))) + +(defun %set-class-type-translation (class classoid) + (when (not (typep classoid 'classoid)) + (setq classoid (find-classoid classoid nil))) + (etypecase classoid + (null) + (built-in-classoid + (let ((translation (built-in-classoid-translation classoid))) + (cond + (translation + (aver (ctype-p translation)) + (setf (info :type :translator class) + (lambda (spec) (declare (ignore spec)) translation))) + (t + (setf (info :type :translator class) + (lambda (spec) (declare (ignore spec)) classoid)))))) + (classoid + (setf (info :type :translator class) + (lambda (spec) (declare (ignore spec)) classoid))))) + (!bootstrap-meta-braid) (!bootstrap-accessor-definitions t) (!bootstrap-class-predicates t) @@ -678,26 +687,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 "~@" + (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