X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=37fde27c819af26c116e8356b368a2ee54b267f2;hb=416152f084604094445a758ff399871132dff2bd;hp=ec5ffb2c53f4d72f662e2582c2a09407a4cb23ce;hpb=d5aafdd8ab6387e12bac187048ed322bc96fb79a;p=sbcl.git diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index ec5ffb2..37fde27 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -335,10 +335,9 @@ (defmethod ensure-class-using-class (name (class null) &rest args &key) (multiple-value-bind (meta initargs) (ensure-class-values class args) - (inform-type-system-about-class (class-prototype meta) name);*** (setf class (apply #'make-instance meta :name name initargs) (find-class name) class) - (inform-type-system-about-class class name) ;*** + (inform-type-system-about-class class name) class)) (defmethod ensure-class-using-class (name (class pcl-class) &rest args &key) @@ -347,12 +346,22 @@ (unless (eq (class-of class) meta) (change-class class meta)) (apply #'reinitialize-instance class initargs) (setf (find-class name) class) - (inform-type-system-about-class class name) ;*** + (inform-type-system-about-class class name) class)) (defmethod class-predicate-name ((class t)) 'constantly-nil) +(defun fix-super (s) + (cond ((classp s) s) + ((not (legal-class-name-p s)) + (error "~S is not a class or a legal class name." s)) + (t + (or (find-class s nil) + (setf (find-class s) + (make-instance 'forward-referenced-class + :name s)))))) + (defun ensure-class-values (class args) (let* ((initargs (copy-list args)) (unsupplied (list 1)) @@ -367,34 +376,17 @@ *the-class-standard-class*) (t (class-of class))))) - (flet ((fix-super (s) - (cond ((classp s) s) - ((not (legal-class-name-p s)) - (error "~S is not a class or a legal class name." s)) - (t - (or (find-class s nil) - (setf (find-class s) - (make-instance 'forward-referenced-class - :name s))))))) - (loop (unless (remf initargs :metaclass) (return))) - (loop (unless (remf initargs :direct-superclasses) (return))) - (loop (unless (remf initargs :direct-slots) (return))) - (values meta - (list* :direct-superclasses - (and (neq supplied-supers unsupplied) - (mapcar #'fix-super supplied-supers)) - :direct-slots - (and (neq supplied-slots unsupplied) supplied-slots) - initargs))))) + (loop (unless (remf initargs :metaclass) (return))) + (loop (unless (remf initargs :direct-superclasses) (return))) + (loop (unless (remf initargs :direct-slots) (return))) + (values meta + (list* :direct-superclasses + (and (neq supplied-supers unsupplied) + (mapcar #'fix-super supplied-supers)) + :direct-slots + (and (neq supplied-slots unsupplied) supplied-slots) + initargs)))) -#|| ; since it doesn't do anything -(defmethod shared-initialize :before ((class std-class) - slot-names - &key direct-superclasses) - (declare (ignore slot-names)) - ;; *** error checking - ) -||# (defmethod shared-initialize :after ((class std-class) @@ -472,6 +464,75 @@ #'(lambda (dependent) (apply #'update-dependent class dependent initargs)))) +(defmethod shared-initialize :after ((slotd standard-slot-definition) + slot-names &key) + (declare (ignore slot-names)) + (with-slots (allocation class) + slotd + (setq allocation (if (eq allocation :class) class allocation)))) + +(defmethod shared-initialize :after ((slotd structure-slot-definition) + slot-names + &key (allocation :instance)) + (declare (ignore slot-names)) + (unless (eq allocation :instance) + (error "Structure slots must have :INSTANCE allocation."))) + +(defun make-structure-class-defstruct-form + (name direct-slots include) + (let* ((conc-name (intern (format nil "~S structure class " name))) + (constructor (intern (format nil "~A constructor" conc-name))) + (defstruct `(defstruct (,name + ,@(when include + `((:include ,(class-name include)))) + (:print-function print-std-instance) + (:predicate nil) + (:conc-name ,conc-name) + (:constructor ,constructor ()) + (:copier nil)) + ,@(mapcar (lambda (slot) + `(,(slot-definition-name slot) + +slot-unbound+)) + direct-slots))) + (reader-names (mapcar (lambda (slotd) + (intern (format nil + "~A~A reader" + conc-name + (slot-definition-name + slotd)))) + direct-slots)) + (writer-names (mapcar (lambda (slotd) + (intern (format nil + "~A~A writer" + conc-name + (slot-definition-name + slotd)))) + direct-slots)) + (readers-init + (mapcar (lambda (slotd reader-name) + (let ((accessor + (slot-definition-defstruct-accessor-symbol + slotd))) + `(defun ,reader-name (obj) + (declare (type ,name obj)) + (,accessor obj)))) + direct-slots reader-names)) + (writers-init + (mapcar (lambda (slotd writer-name) + (let ((accessor + (slot-definition-defstruct-accessor-symbol + slotd))) + `(defun ,writer-name (nv obj) + (declare (type ,name obj)) + (setf (,accessor obj) nv)))) + direct-slots writer-names)) + (defstruct-form + `(progn + ,defstruct + ,@readers-init ,@writers-init + (cons nil nil)))) + (values defstruct-form constructor reader-names writer-names))) + (defmethod shared-initialize :after ((class structure-class) slot-names @@ -507,87 +568,39 @@ direct-slots))) (setq direct-slots (slot-value class 'direct-slots))) (when defstruct-p - (let* ((include (car (slot-value class 'direct-superclasses))) - (conc-name (intern (format nil "~S structure class " name))) - (constructor (intern (format nil "~A constructor" conc-name))) - (defstruct `(defstruct (,name - ,@(when include - `((:include ,(class-name include)))) - (:print-function print-std-instance) - (:predicate nil) - (:conc-name ,conc-name) - (:constructor ,constructor ())) - ,@(mapcar #'(lambda (slot) - `(,(slot-definition-name slot) - +slot-unbound+)) - direct-slots))) - (reader-names (mapcar (lambda (slotd) - (intern (format nil - "~A~A reader" - conc-name - (slot-definition-name - slotd)))) - direct-slots)) - (writer-names (mapcar (lambda (slotd) - (intern (format nil - "~A~A writer" - conc-name - (slot-definition-name - slotd)))) - direct-slots)) - (readers-init - (mapcar (lambda (slotd reader-name) - (let ((accessor - (slot-definition-defstruct-accessor-symbol - slotd))) - `(defun ,reader-name (obj) - (declare (type ,name obj)) - (,accessor obj)))) - direct-slots reader-names)) - (writers-init - (mapcar (lambda (slotd writer-name) - (let ((accessor - (slot-definition-defstruct-accessor-symbol - slotd))) - `(defun ,writer-name (nv obj) - (declare (type ,name obj)) - (setf (,accessor obj) nv)))) - direct-slots writer-names)) - (defstruct-form - `(progn - ,defstruct - ,@readers-init ,@writers-init - (cons nil nil)))) - (unless (structure-type-p name) (eval defstruct-form)) - (mapc #'(lambda (dslotd reader-name writer-name) - (let* ((reader (gdefinition reader-name)) - (writer (when (gboundp writer-name) - (gdefinition writer-name)))) - (setf (slot-value dslotd 'internal-reader-function) - reader) - (setf (slot-value dslotd 'internal-writer-function) - writer))) - direct-slots reader-names writer-names) - (setf (slot-value class 'defstruct-form) defstruct-form) - (setf (slot-value class 'defstruct-constructor) constructor)))) - (add-direct-subclasses class direct-superclasses) - (setf (slot-value class 'class-precedence-list) - (compute-class-precedence-list class)) - (setf (slot-value class 'slots) (compute-slots class)) - (let ((lclass (cl:find-class (class-name class)))) - (setf (sb-kernel:class-pcl-class lclass) class) - (setf (slot-value class 'wrapper) (sb-kernel:class-layout lclass))) - (update-pv-table-cache-info class) - (setq predicate-name (if predicate-name-p + (let ((include (car (slot-value class 'direct-superclasses)))) + (multiple-value-bind (defstruct-form constructor reader-names writer-names) + (make-structure-class-defstruct-form name direct-slots include) + (unless (structure-type-p name) (eval defstruct-form)) + (mapc #'(lambda (dslotd reader-name writer-name) + (let* ((reader (gdefinition reader-name)) + (writer (when (gboundp writer-name) + (gdefinition writer-name)))) + (setf (slot-value dslotd 'internal-reader-function) + reader) + (setf (slot-value dslotd 'internal-writer-function) + writer))) + direct-slots reader-names writer-names) + (setf (slot-value class 'defstruct-form) defstruct-form) + (setf (slot-value class 'defstruct-constructor) constructor)))) + (add-direct-subclasses class direct-superclasses) + (setf (slot-value class 'class-precedence-list) + (compute-class-precedence-list class)) + (setf (slot-value class 'slots) (compute-slots class)) + (let ((lclass (cl:find-class (class-name class)))) + (setf (sb-kernel:class-pcl-class lclass) class) + (setf (slot-value class 'wrapper) (sb-kernel:class-layout lclass))) + (update-pv-table-cache-info class) + (setq predicate-name (if predicate-name-p (setf (slot-value class 'predicate-name) - (car predicate-name)) + (car predicate-name)) (or (slot-value class 'predicate-name) (setf (slot-value class 'predicate-name) - (make-class-predicate-name - (class-name class)))))) - (make-class-predicate class predicate-name) - (add-slot-accessors class direct-slots)) - + (make-class-predicate-name + (class-name class)))))) + (make-class-predicate class predicate-name) + (add-slot-accessors class direct-slots))) + (defmethod direct-slot-definition-class ((class structure-class) initargs) (declare (ignore initargs)) (find-class 'structure-direct-slot-definition)) @@ -967,7 +980,7 @@ ;;; *** There is a subtle bug here which is going to have to be fixed. ;;; *** Namely, the simplistic use of the template has to be fixed. We ;;; *** have to give the optimize-slot-value method the user might have -;;; *** defined for this metclass a chance to run. +;;; *** defined for this metaclass a chance to run. (defmethod make-reader-method-function ((class slot-class) slot-name) (make-std-reader-method-function (class-name class) slot-name)) @@ -979,7 +992,6 @@ (make-std-boundp-method-function (class-name class) slot-name)) ;;;; inform-type-system-about-class -;;;; make-type-predicate ;;; ;;; These are NOT part of the standard protocol. They are internal ;;; mechanism which PCL uses to *try* and tell the type system about @@ -989,6 +1001,9 @@ ;;; the type system about new classes would be different. (defmethod inform-type-system-about-class ((class std-class) name) (inform-type-system-about-std-class name)) + +(defmethod inform-type-system-about-class ((class structure-class) (name t)) + nil) (defmethod compatible-meta-class-change-p (class proto-new-class) (eq (class-of class) (class-of proto-new-class))) @@ -1082,9 +1097,7 @@ (lambda (condition stream) ;; Don't try to print the structure, since it probably won't work. (format stream - "obsolete structure error in ~S:~@ - for a structure of type: ~S" - (sb-kernel::condition-function-name condition) + "~@" (type-of (obsolete-structure-datum condition)))))) (defun obsolete-instance-trap (owrapper nwrapper instance)