X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=733c4d3c99096809759f75376ac87c7b21f60595;hb=4f8f4b25cb564509437d8fc26038143150077f14;hp=8d9dde3bfd89ad5692fd08a7f26464cae72b7903;hpb=c70ef5922e4e5290fab52b90c3614be83c0b8f8b;p=sbcl.git diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 8d9dde3..733c4d3 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -286,13 +286,14 @@ (constantly (make-member-type :members (list (specializer-object specl)))))) (defun real-load-defclass (name metaclass-name supers slots other - readers writers slot-names source-location) + readers writers slot-names source-location safe-p) (with-single-package-locked-error (:symbol name "defining ~S as a class") (%compiler-defclass name readers writers slot-names) (let ((res (apply #'ensure-class name :metaclass metaclass-name :direct-superclasses supers :direct-slots slots :definition-source source-location + 'safe-p safe-p other))) res))) @@ -309,7 +310,7 @@ (defmethod ensure-class-using-class ((class null) name &rest args &key) (multiple-value-bind (meta initargs) - (ensure-class-values class args) + (frob-ensure-class-args args) (setf class (apply #'make-instance meta :name name initargs)) (without-package-locks (setf (find-class name) class)) @@ -318,7 +319,7 @@ (defmethod ensure-class-using-class ((class pcl-class) name &rest args &key) (multiple-value-bind (meta initargs) - (ensure-class-values class args) + (frob-ensure-class-args args) (unless (eq (class-of class) meta) (apply #'change-class class meta initargs)) (apply #'reinitialize-instance class initargs) @@ -327,34 +328,29 @@ (set-class-type-translation class name) class)) -(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) - (ensure-class s :metaclass 'forward-referenced-class))))) - -(defun ensure-class-values (class initargs) +(defun frob-ensure-class-args (args) (let (metaclass metaclassp reversed-plist) - (doplist (key val) initargs - (cond ((eq key :metaclass) - (setf metaclass val - metaclassp key)) - (t - (when (eq key :direct-superclasses) - (setf val (mapcar #'fix-super val))) - (setf reversed-plist (list* val key reversed-plist))))) - (values (cond (metaclassp - (if (classp metaclass) - metaclass - (find-class metaclass))) - ((or (null class) (forward-referenced-class-p class)) - *the-class-standard-class*) - (t - (class-of class))) - (nreverse reversed-plist)))) - + (flet ((frob-superclass (s) + (cond + ((classp s) s) + ((legal-class-name-p s) + (or (find-class s nil) + (ensure-class s :metaclass 'forward-referenced-class))) + (t (error "Not a class or a legal class name: ~S." s))))) + (doplist (key val) args + (cond ((eq key :metaclass) + (unless metaclassp + (setf metaclass val metaclassp key))) + (t + (when (eq key :direct-superclasses) + (setf val (mapcar #'frob-superclass val))) + (setf reversed-plist (list* val key reversed-plist))))) + (values (cond (metaclassp + (if (classp metaclass) + metaclass + (find-class metaclass))) + (t *the-class-standard-class*)) + (nreverse reversed-plist))))) (defmethod shared-initialize :after ((class std-class) slot-names &key @@ -703,17 +699,13 @@ (defun fix-slot-accessors (class dslotds add/remove) (flet ((fix (gfspec name r/w) (let ((gf (cond ((eq add/remove 'add) - (if (fboundp gfspec) - (without-package-locks - (ensure-generic-function gfspec)) + (or (find-generic-function gfspec nil) (ensure-generic-function gfspec :lambda-list (case r/w (r '(object)) (w '(new-value object)))))) - ((generic-function-p (and (fboundp gfspec) - (fdefinition gfspec))) - (without-package-locks - (ensure-generic-function gfspec)))))) + (t + (find-generic-function gfspec nil))))) (when gf (case r/w (r (if (eq add/remove 'add) @@ -1045,6 +1037,7 @@ (allocation nil) (allocation-class nil) (type t) + (type-check-function nil) (documentation nil) (documentationp nil) (namep nil) @@ -1070,6 +1063,15 @@ allocation-class (slot-definition-class slotd) allocp t)) (setq initargs (append (slot-definition-initargs slotd) initargs)) + (let ((fun (slot-definition-type-check-function slotd))) + (when fun + (setf type-check-function + (if type-check-function + (let ((old-function type-check-function)) + (lambda (value) + (funcall old-function value) + (funcall fun value))) + fun)))) (let ((slotd-type (slot-definition-type slotd))) (setq type (cond ((eq type t) slotd-type) @@ -1086,6 +1088,7 @@ :allocation allocation :allocation-class allocation-class :type type + 'type-check-function type-check-function :class class :documentation documentation))) @@ -1159,9 +1162,10 @@ (let ((method (get-method generic-function () (list class) nil))) (when method (remove-method generic-function method)))) -;;; MAKE-READER-METHOD-FUNCTION and MAKE-WRITE-METHOD function are NOT -;;; part of the standard protocol. They are however useful, PCL makes -;;; use of them internally and documents them for PCL users. +;;; MAKE-READER-METHOD-FUNCTION and MAKE-WRITER-METHOD-FUNCTION +;;; function are NOT part of the standard protocol. They are however +;;; useful; PCL makes use of them internally and documents them for +;;; PCL users. (FIXME: but SBCL certainly doesn't) ;;; ;;; *** This needs work to make type testing by the writer functions which ;;; *** do type testing faster. The idea would be to have one constructor @@ -1173,13 +1177,13 @@ ;;; *** 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)) + (make-std-reader-method-function class slot-name)) (defmethod make-writer-method-function ((class slot-class) slot-name) - (make-std-writer-method-function (class-name class) slot-name)) + (make-std-writer-method-function class slot-name)) (defmethod make-boundp-method-function ((class slot-class) slot-name) - (make-std-boundp-method-function (class-name class) slot-name)) + (make-std-boundp-method-function class slot-name)) (defmethod compatible-meta-class-change-p (class proto-new-class) (eq (class-of class) (class-of proto-new-class)))