X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=8dd9ea1c06bd2d3c54c58991d6f7e5aeda221a65;hb=63cef087068afc157283c0a05ae1f16b962303aa;hp=969791562bc8d0c8f4fad79a6c571313ef45e093;hpb=683874b497a99cd2c11b6c5d9b47e2785b1ede5f;p=sbcl.git diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 9697915..8dd9ea1 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -282,27 +282,27 @@ (nreverse collect))))))) (defun map-specializers (function) - (map-all-classes #'(lambda (class) - (funcall function (class-eq-specializer class)) - (funcall function class))) - (maphash #'(lambda (object methods) - (declare (ignore methods)) - (intern-eql-specializer object)) + (map-all-classes (lambda (class) + (funcall function (class-eq-specializer class)) + (funcall function class))) + (maphash (lambda (object methods) + (declare (ignore methods)) + (intern-eql-specializer object)) *eql-specializer-methods*) - (maphash #'(lambda (object specl) - (declare (ignore object)) - (funcall function specl)) + (maphash (lambda (object specl) + (declare (ignore object)) + (funcall function specl)) *eql-specializer-table*) nil) (defun map-all-generic-functions (function) (let ((all-generic-functions (make-hash-table :test 'eq))) - (map-specializers #'(lambda (specl) - (dolist (gf (specializer-direct-generic-functions - specl)) - (unless (gethash gf all-generic-functions) - (setf (gethash gf all-generic-functions) t) - (funcall function gf)))))) + (map-specializers (lambda (specl) + (dolist (gf (specializer-direct-generic-functions + specl)) + (unless (gethash gf all-generic-functions) + (setf (gethash gf all-generic-functions) t) + (funcall function gf)))))) nil) (defmethod shared-initialize :after ((specl class-eq-specializer) @@ -338,7 +338,6 @@ (ensure-class-values class args) (setf class (apply #'make-instance meta :name name initargs) (find-class name) class) - (inform-type-system-about-class class name) class)) (defmethod ensure-class-using-class (name (class pcl-class) &rest args &key) @@ -347,7 +346,6 @@ (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) class)) (defmethod class-predicate-name ((class t)) @@ -464,8 +462,8 @@ &rest initargs &key) (map-dependents class - #'(lambda (dependent) - (apply #'update-dependent class dependent initargs)))) + (lambda (dependent) + (apply #'update-dependent class dependent initargs)))) (defmethod shared-initialize :after ((slotd standard-slot-definition) slot-names &key) @@ -556,17 +554,17 @@ (if direct-slots-p (setf (slot-value class 'direct-slots) (setq direct-slots - (mapcar #'(lambda (pl) - (when defstruct-p - (let* ((slot-name (getf pl :name)) - (acc-name - (format nil - "~S structure class ~A" - name slot-name)) - (accessor (intern acc-name))) - (setq pl (list* :defstruct-accessor-symbol - accessor pl)))) - (make-direct-slotd class pl)) + (mapcar (lambda (pl) + (when defstruct-p + (let* ((slot-name (getf pl :name)) + (acc-name + (format nil + "~S structure class ~A" + name slot-name)) + (accessor (intern acc-name))) + (setq pl (list* :defstruct-accessor-symbol + accessor pl)))) + (make-direct-slotd class pl)) direct-slots))) (setq direct-slots (slot-value class 'direct-slots))) (when defstruct-p @@ -574,14 +572,14 @@ (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))) + (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)))) @@ -631,14 +629,14 @@ (dolist (r (slot-definition-readers dslotd)) (fix r slot-name 'r)) (dolist (w (slot-definition-writers dslotd)) (fix w slot-name 'w)))))) -(defun add-direct-subclasses (class new) - (dolist (n new) +(defun add-direct-subclasses (class supers) + (dolist (super supers) (unless (memq class (class-direct-subclasses class)) - (add-direct-subclass n class)))) + (add-direct-subclass super class)))) -(defun remove-direct-subclasses (class new) +(defun remove-direct-subclasses (class supers) (let ((old (class-direct-superclasses class))) - (dolist (o (set-difference old new)) + (dolist (o (set-difference old supers)) (remove-direct-subclass o class)))) (defmethod finalize-inheritance ((class std-class)) @@ -771,9 +769,9 @@ (setf (gethash gf gf-table) t)) (mapc #'collect-gfs (class-direct-superclasses class)))) (collect-gfs class) - (maphash #'(lambda (gf ignore) - (declare (ignore ignore)) - (update-gf-dfun class gf)) + (maphash (lambda (gf ignore) + (declare (ignore ignore)) + (update-gf-dfun class gf)) gf-table))))) (defun update-inits (class inits) @@ -819,9 +817,9 @@ (if entry (push d (cdr entry)) (push (list name d) name-dslotds-alist)))))) - (mapcar #'(lambda (direct) - (compute-effective-slot-definition class - (nreverse (cdr direct)))) + (mapcar (lambda (direct) + (compute-effective-slot-definition class + (nreverse (cdr direct)))) name-dslotds-alist))) (defmethod compute-slots :around ((class std-class)) @@ -845,11 +843,11 @@ eslotds)) (defmethod compute-slots ((class structure-class)) - (mapcan #'(lambda (superclass) - (mapcar #'(lambda (dslotd) - (compute-effective-slot-definition class - (list dslotd))) - (class-direct-slots superclass))) + (mapcan (lambda (superclass) + (mapcar (lambda (dslotd) + (compute-effective-slot-definition class + (list dslotd))) + (class-direct-slots superclass))) (reverse (slot-value class 'class-precedence-list)))) (defmethod compute-slots :around ((class structure-class)) @@ -979,8 +977,7 @@ ;;; ;;; *** This needs work to make type testing by the writer functions which ;;; *** do type testing faster. The idea would be to have one constructor -;;; *** for each possible type test. In order to do this it would be nice -;;; *** to have help from inform-type-system-about-class and friends. +;;; *** for each possible type test. ;;; ;;; *** 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 @@ -996,20 +993,6 @@ (defmethod make-boundp-method-function ((class slot-class) slot-name) (make-std-boundp-method-function (class-name class) slot-name)) -;;;; inform-type-system-about-class -;;; -;;; These are NOT part of the standard protocol. They are internal -;;; mechanism which PCL uses to *try* and tell the type system about -;;; class definitions. In a more fully integrated implementation of -;;; CLOS, the type system would know about class objects and class -;;; names in a more fundamental way and the mechanism used to inform -;;; 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))) @@ -1040,7 +1023,7 @@ (sb-sys:without-interrupts (update-lisp-class-layout class nwrapper) (setf (slot-value class 'wrapper) nwrapper) - (invalidate-wrapper owrapper ':flush nwrapper)))))) + (invalidate-wrapper owrapper :flush nwrapper)))))) (defun flush-cache-trap (owrapper nwrapper instance) (declare (ignore owrapper)) @@ -1060,7 +1043,7 @@ (sb-sys:without-interrupts (update-lisp-class-layout class nwrapper) (setf (slot-value class 'wrapper) nwrapper) - (invalidate-wrapper owrapper ':obsolete nwrapper) + (invalidate-wrapper owrapper :obsolete nwrapper) class))) (defmethod make-instances-obsolete ((class symbol))