diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index 89957c7ab..b9fd251d5 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -64,36 +64,36 @@ (defun quote-plist-keys (plist) (loop for (key . more) on plist by #'cddr - if (null more) do - (error "Not a property list: ~S" plist) - else - collect `(quote ,key) - and collect (car more))) + if (null more) do + (error "Not a property list: ~S" plist) + else + collect `(quote ,key) + and collect (car more))) (defun plist-keys (plist &key test) (loop for (key . more) on plist by #'cddr - if (null more) do - (error "Not a property list: ~S" plist) - else if (or (null test) (funcall test key)) - collect key)) + if (null more) do + (error "Not a property list: ~S" plist) + else if (or (null test) (funcall test key)) + collect key)) (defun plist-values (plist &key test) (loop for (key . more) on plist by #'cddr - if (null more) do - (error "Not a property list: ~S" plist) - else if (or (null test) (funcall test (car more))) - collect (car more))) + if (null more) do + (error "Not a property list: ~S" plist) + else if (or (null test) (funcall test (car more))) + collect (car more))) (defun constant-symbol-p (form) (and (constantp form) (let ((constant (eval form))) - (and (symbolp constant) - (not (null (symbol-package constant))))))) + (and (symbolp constant) + (not (null (symbol-package constant))))))) ;;; somewhat akin to DEFAULT-INITARGS (SLOT-CLASS T T), but just ;;; collecting the defaulted initargs for the call. (defun ctor-default-initkeys (supplied-initargs class-default-initargs) - (loop for (key nil) in class-default-initargs + (loop for (key) in class-default-initargs when (eq (getf supplied-initargs key '.not-there.) '.not-there.) collect key)) @@ -109,7 +109,7 @@ (!defstruct-with-alternate-metaclass ctor :slot-names (function-name class-name class initargs) :boa-constructor %make-ctor - :superclass-name pcl-funcallable-instance + :superclass-name function :metaclass-name random-pcl-classoid :metaclass-constructor make-random-pcl-classoid :dd-type funcallable-structure @@ -128,23 +128,14 @@ (when (or force-p (ctor-class ctor)) (setf (ctor-class ctor) nil) (setf (funcallable-instance-fun ctor) - #'(instance-lambda (&rest args) - (install-optimized-constructor ctor) - (apply ctor args))) + #'(lambda (&rest args) + (install-optimized-constructor ctor) + (apply ctor args))) (setf (%funcallable-instance-info ctor 1) - (ctor-function-name ctor)))) + (ctor-function-name ctor)))) -;;; Keep this a separate function for testing. (defun make-ctor-function-name (class-name initargs) - (let ((*package* *pcl-package*) - (*print-case* :upcase) - (*print-pretty* nil) - (*print-gensym* t)) - (format-symbol *pcl-package* "CTOR ~S::~S ~S ~S" - (package-name (symbol-package class-name)) - (symbol-name class-name) - (plist-keys initargs) - (plist-values initargs :test #'constantp)))) + (list* 'ctor class-name initargs)) ;;; Keep this a separate function for testing. (defun ensure-ctor (function-name class-name initargs) @@ -156,7 +147,7 @@ (without-package-locks ; for (setf symbol-function) (let ((ctor (%make-ctor function-name class-name nil initargs))) (push ctor *all-ctors*) - (setf (symbol-function function-name) ctor) + (setf (fdefinition function-name) ctor) (install-initial-constructor ctor :force-p t) ctor))) @@ -174,66 +165,66 @@ (destructuring-bind (fn class-name &rest args) form (declare (ignore fn)) (flet (;; - ;; Return the name of parameter number I of a constructor - ;; function. - (parameter-name (i) - (let ((ps #(.p0. .p1. .p2. .p3. .p4. .p5.))) - (if (array-in-bounds-p ps i) - (aref ps i) - (format-symbol *pcl-package* ".P~D." i)))) - ;; Check if CLASS-NAME is a constant symbol. Give up if - ;; not. - (check-class () - (unless (and class-name (constant-symbol-p class-name)) - (return-from make-instance->constructor-call nil))) - ;; Check if ARGS are suitable for an optimized constructor. - ;; Return NIL from the outer function if not. - (check-args () - (loop for (key . more) on args by #'cddr do - (when (or (null more) - (not (constant-symbol-p key)) - (eq :allow-other-keys (eval key))) - (return-from make-instance->constructor-call nil))))) + ;; Return the name of parameter number I of a constructor + ;; function. + (parameter-name (i) + (let ((ps #(.p0. .p1. .p2. .p3. .p4. .p5.))) + (if (array-in-bounds-p ps i) + (aref ps i) + (format-symbol *pcl-package* ".P~D." i)))) + ;; Check if CLASS-NAME is a constant symbol. Give up if + ;; not. + (check-class () + (unless (and class-name (constant-symbol-p class-name)) + (return-from make-instance->constructor-call nil))) + ;; Check if ARGS are suitable for an optimized constructor. + ;; Return NIL from the outer function if not. + (check-args () + (loop for (key . more) on args by #'cddr do + (when (or (null more) + (not (constant-symbol-p key)) + (eq :allow-other-keys (eval key))) + (return-from make-instance->constructor-call nil))))) (check-class) (check-args) ;; Collect a plist of initargs and constant values/parameter names ;; in INITARGS. Collect non-constant initialization forms in ;; VALUE-FORMS. (multiple-value-bind (initargs value-forms) - (loop for (key value) on args by #'cddr and i from 0 - collect (eval key) into initargs - if (constantp value) - collect value into initargs - else - collect (parameter-name i) into initargs - and collect value into value-forms - finally - (return (values initargs value-forms))) - (let* ((class-name (eval class-name)) - (function-name (make-ctor-function-name class-name initargs))) - ;; Prevent compiler warnings for calling the ctor. - (proclaim-as-fun-name function-name) - (note-name-defined function-name :function) - (when (eq (info :function :where-from function-name) :assumed) - (setf (info :function :where-from function-name) :defined) - (when (info :function :assumed-type function-name) - (setf (info :function :assumed-type function-name) nil))) - ;; Return code constructing a ctor at load time, which, when - ;; called, will set its funcallable instance function to an - ;; optimized constructor function. - `(locally - (declare (disable-package-locks ,function-name)) - (let ((.x. (load-time-value - (ensure-ctor ',function-name ',class-name ',initargs)))) - (declare (ignore .x.)) - ;; ??? check if this is worth it. - (declare - (ftype (or (function ,(make-list (length value-forms) - :initial-element t) - t) - (function (&rest t) t)) - ,function-name)) - (,function-name ,@value-forms)))))))) + (loop for (key value) on args by #'cddr and i from 0 + collect (eval key) into initargs + if (constantp value) + collect value into initargs + else + collect (parameter-name i) into initargs + and collect value into value-forms + finally + (return (values initargs value-forms))) + (let* ((class-name (eval class-name)) + (function-name (make-ctor-function-name class-name initargs))) + ;; Prevent compiler warnings for calling the ctor. + (proclaim-as-fun-name function-name) + (note-name-defined function-name :function) + (when (eq (info :function :where-from function-name) :assumed) + (setf (info :function :where-from function-name) :defined) + (when (info :function :assumed-type function-name) + (setf (info :function :assumed-type function-name) nil))) + ;; Return code constructing a ctor at load time, which, when + ;; called, will set its funcallable instance function to an + ;; optimized constructor function. + `(locally + (declare (disable-package-locks ,function-name)) + (let ((.x. (load-time-value + (ensure-ctor ',function-name ',class-name ',initargs)))) + (declare (ignore .x.)) + ;; ??? check if this is worth it. + (declare + (ftype (or (function ,(make-list (length value-forms) + :initial-element t) + t) + (function (&rest t) t)) + ,function-name)) + (funcall (function ,function-name) ,@value-forms)))))))) ;;; ************************************************** @@ -254,113 +245,107 @@ (setf (ctor-class ctor) class) (pushnew ctor (plist-value class 'ctors)) (setf (funcallable-instance-fun ctor) - ;; KLUDGE: Gerd here has the equivalent of (COMPILE NIL - ;; (CONSTRUCTOR-FUNCTION-FORM)), but SBCL's COMPILE doesn't - ;; deal with INSTANCE-LAMBDA expressions, only with LAMBDA - ;; expressions. The below should be equivalent, since we - ;; have a compiler-only implementation. - ;; - ;; (except maybe for optimization qualities? -- CSR, - ;; 2004-07-12) - (eval `(function ,(constructor-function-form ctor)))))) - + (multiple-value-bind (form locations names) + (constructor-function-form ctor) + (apply (compile nil `(lambda ,names ,form)) locations))))) + (defun constructor-function-form (ctor) (let* ((class (ctor-class ctor)) - (proto (class-prototype class)) + (proto (class-prototype class)) (make-instance-methods - (compute-applicable-methods #'make-instance (list class))) + (compute-applicable-methods #'make-instance (list class))) (allocate-instance-methods - (compute-applicable-methods #'allocate-instance (list class))) - ;; I stared at this in confusion for a while, thinking - ;; carefully about the possibility of the class prototype not - ;; being of sufficient discrimiating power, given the - ;; possibility of EQL-specialized methods on - ;; INITIALIZE-INSTANCE or SHARED-INITIALIZE. However, given - ;; that this is a constructor optimization, the user doesn't - ;; yet have the instance to create a method with such an EQL - ;; specializer. - ;; - ;; There remains the (theoretical) possibility of someone - ;; coming along with code of the form - ;; - ;; (defmethod initialize-instance :before ((o foo) ...) - ;; (eval `(defmethod shared-initialize :before ((o foo) ...) ...))) - ;; - ;; but probably we can afford not to worry about this too - ;; much for now. -- CSR, 2004-07-12 + (compute-applicable-methods #'allocate-instance (list class))) + ;; I stared at this in confusion for a while, thinking + ;; carefully about the possibility of the class prototype not + ;; being of sufficient discrimiating power, given the + ;; possibility of EQL-specialized methods on + ;; INITIALIZE-INSTANCE or SHARED-INITIALIZE. However, given + ;; that this is a constructor optimization, the user doesn't + ;; yet have the instance to create a method with such an EQL + ;; specializer. + ;; + ;; There remains the (theoretical) possibility of someone + ;; coming along with code of the form + ;; + ;; (defmethod initialize-instance :before ((o foo) ...) + ;; (eval `(defmethod shared-initialize :before ((o foo) ...) ...))) + ;; + ;; but probably we can afford not to worry about this too + ;; much for now. -- CSR, 2004-07-12 (ii-methods - (compute-applicable-methods #'initialize-instance (list proto))) + (compute-applicable-methods #'initialize-instance (list proto))) (si-methods - (compute-applicable-methods #'shared-initialize (list proto t))) - (setf-svuc-slots-methods - (loop for slot in (class-slots class) - collect (compute-applicable-methods - #'(setf slot-value-using-class) - (list nil class proto slot)))) - (sbuc-slots-methods - (loop for slot in (class-slots class) - collect (compute-applicable-methods - #'slot-boundp-using-class - (list class proto slot))))) + (compute-applicable-methods #'shared-initialize (list proto t))) + (setf-svuc-slots-methods + (loop for slot in (class-slots class) + collect (compute-applicable-methods + #'(setf slot-value-using-class) + (list nil class proto slot)))) + (sbuc-slots-methods + (loop for slot in (class-slots class) + collect (compute-applicable-methods + #'slot-boundp-using-class + (list class proto slot))))) ;; Cannot initialize these variables earlier because the generic ;; functions don't exist when PCL is built. (when (null *the-system-si-method*) (setq *the-system-si-method* - (find-method #'shared-initialize - () (list *the-class-slot-object* *the-class-t*))) + (find-method #'shared-initialize + () (list *the-class-slot-object* *the-class-t*))) (setq *the-system-ii-method* - (find-method #'initialize-instance - () (list *the-class-slot-object*)))) + (find-method #'initialize-instance + () (list *the-class-slot-object*)))) ;; Note that when there are user-defined applicable methods on ;; MAKE-INSTANCE and/or ALLOCATE-INSTANCE, these will show up ;; together with the system-defined ones in what ;; COMPUTE-APPLICABLE-METHODS returns. - (or (and (not (structure-class-p class)) - (not (condition-class-p class)) - (null (cdr make-instance-methods)) - (null (cdr allocate-instance-methods)) - (every (lambda (x) - (member (slot-definition-allocation x) - '(:instance :class))) - (class-slots class)) - (null (check-initargs-1 + (if (and (not (structure-class-p class)) + (not (condition-class-p class)) + (null (cdr make-instance-methods)) + (null (cdr allocate-instance-methods)) + (every (lambda (x) + (member (slot-definition-allocation x) + '(:instance :class))) + (class-slots class)) + (null (check-initargs-1 class (append (ctor-default-initkeys (ctor-initargs ctor) (class-default-initargs class)) (plist-keys (ctor-initargs ctor))) (append ii-methods si-methods) nil nil)) - (not (around-or-nonstandard-primary-method-p - ii-methods *the-system-ii-method*)) - (not (around-or-nonstandard-primary-method-p - si-methods *the-system-si-method*)) - ;; the instance structure protocol goes through - ;; slot-value(-using-class) and friends (actually just - ;; (SETF SLOT-VALUE-USING-CLASS) and - ;; SLOT-BOUNDP-USING-CLASS), so if there are non-standard - ;; applicable methods we can't shortcircuit them. - (every (lambda (x) (= (length x) 1)) setf-svuc-slots-methods) - (every (lambda (x) (= (length x) 1)) sbuc-slots-methods) - (optimizing-generator ctor ii-methods si-methods)) - (fallback-generator ctor ii-methods si-methods)))) + (not (around-or-nonstandard-primary-method-p + ii-methods *the-system-ii-method*)) + (not (around-or-nonstandard-primary-method-p + si-methods *the-system-si-method*)) + ;; the instance structure protocol goes through + ;; slot-value(-using-class) and friends (actually just + ;; (SETF SLOT-VALUE-USING-CLASS) and + ;; SLOT-BOUNDP-USING-CLASS), so if there are non-standard + ;; applicable methods we can't shortcircuit them. + (every (lambda (x) (= (length x) 1)) setf-svuc-slots-methods) + (every (lambda (x) (= (length x) 1)) sbuc-slots-methods)) + (optimizing-generator ctor ii-methods si-methods) + (fallback-generator ctor ii-methods si-methods)))) (defun around-or-nonstandard-primary-method-p (methods &optional standard-method) (loop with primary-checked-p = nil - for method in methods - as qualifiers = (method-qualifiers method) - when (or (eq :around (car qualifiers)) - (and (null qualifiers) - (not primary-checked-p) - (not (null standard-method)) - (not (eq standard-method method)))) - return t - when (null qualifiers) do - (setq primary-checked-p t))) + for method in methods + as qualifiers = (method-qualifiers method) + when (or (eq :around (car qualifiers)) + (and (null qualifiers) + (not primary-checked-p) + (not (null standard-method)) + (not (eq standard-method method)))) + return t + when (null qualifiers) do + (setq primary-checked-p t))) (defun fallback-generator (ctor ii-methods si-methods) (declare (ignore ii-methods si-methods)) - `(instance-lambda ,(make-ctor-parameter-list ctor) + `(lambda ,(make-ctor-parameter-list ctor) ;; The CTOR MAKE-INSTANCE optimization only kicks in when the ;; first argument to MAKE-INSTANCE is a constant symbol: by ;; calling it with a class, as here, we inhibit the optimization, @@ -369,11 +354,14 @@ (make-instance ,(ctor-class ctor) ,@(ctor-initargs ctor)))) (defun optimizing-generator (ctor ii-methods si-methods) - (multiple-value-bind (body before-method-p) + (multiple-value-bind (locations names body before-method-p) (fake-initialization-emf ctor ii-methods si-methods) - `(instance-lambda ,(make-ctor-parameter-list ctor) + (values + `(lambda ,(make-ctor-parameter-list ctor) (declare #.*optimize-speed*) - ,(wrap-in-allocate-forms ctor body before-method-p)))) + ,(wrap-in-allocate-forms ctor body before-method-p)) + locations + names))) ;;; Return a form wrapped around BODY that allocates an instance ;;; constructed by CTOR. BEFORE-METHOD-P set means we have to run @@ -383,24 +371,24 @@ ;;; vector around BODY. (defun wrap-in-allocate-forms (ctor body before-method-p) (let* ((class (ctor-class ctor)) - (wrapper (class-wrapper class)) - (allocation-function (raw-instance-allocator class)) - (slots-fetcher (slots-fetcher class))) + (wrapper (class-wrapper class)) + (allocation-function (raw-instance-allocator class)) + (slots-fetcher (slots-fetcher class))) (if (eq allocation-function 'allocate-standard-instance) - `(let ((.instance. (%make-standard-instance nil - (get-instance-hash-code))) - (.slots. (make-array - ,(layout-length wrapper) - ,@(when before-method-p - '(:initial-element +slot-unbound+))))) - (setf (std-instance-wrapper .instance.) ,wrapper) - (setf (std-instance-slots .instance.) .slots.) - ,body - .instance.) - `(let* ((.instance. (,allocation-function ,wrapper)) - (.slots. (,slots-fetcher .instance.))) - ,body - .instance.)))) + `(let ((.instance. (%make-standard-instance nil + (get-instance-hash-code))) + (.slots. (make-array + ,(layout-length wrapper) + ,@(when before-method-p + '(:initial-element +slot-unbound+))))) + (setf (std-instance-wrapper .instance.) ,wrapper) + (setf (std-instance-slots .instance.) .slots.) + ,body + .instance.) + `(let* ((.instance. (,allocation-function ,wrapper)) + (.slots. (,slots-fetcher .instance.))) + ,body + .instance.)))) ;;; Return a form for invoking METHOD with arguments from ARGS. As ;;; can be seen in METHOD-FUNCTION-FROM-FAST-FUNCTION, method @@ -418,31 +406,33 @@ (standard-sort-methods ii-methods) (declare (ignore ii-primary)) (multiple-value-bind (si-around si-before si-primary si-after) - (standard-sort-methods si-methods) + (standard-sort-methods si-methods) (declare (ignore si-primary)) (aver (and (null ii-around) (null si-around))) (let ((initargs (ctor-initargs ctor))) - (multiple-value-bind (bindings vars defaulting-initargs body) - (slot-init-forms ctor (or ii-before si-before)) - (values + (multiple-value-bind (locations names bindings vars defaulting-initargs body) + (slot-init-forms ctor (or ii-before si-before)) + (values + locations + names `(let ,bindings (declare (ignorable ,@vars)) (let (,@(when (or ii-before ii-after) `((.ii-args. (list .instance. ,@(quote-plist-keys initargs) ,@defaulting-initargs)))) ,@(when (or si-before si-after) - `((.si-args. + `((.si-args. (list .instance. t ,@(quote-plist-keys initargs) ,@defaulting-initargs))))) - ,@(loop for method in ii-before - collect `(invoke-method ,method .ii-args.)) - ,@(loop for method in si-before - collect `(invoke-method ,method .si-args.)) - ,@body - ,@(loop for method in si-after - collect `(invoke-method ,method .si-args.)) - ,@(loop for method in ii-after - collect `(invoke-method ,method .ii-args.)))) - (or ii-before si-before))))))) + ,@(loop for method in ii-before + collect `(invoke-method ,method .ii-args.)) + ,@(loop for method in si-before + collect `(invoke-method ,method .si-args.)) + ,@body + ,@(loop for method in si-after + collect `(invoke-method ,method .si-args.)) + ,@(loop for method in ii-after + collect `(invoke-method ,method .ii-args.)))) + (or ii-before si-before))))))) ;;; Return four values from APPLICABLE-METHODS: around methods, before ;;; methods, the applicable primary method, and applicable after @@ -450,17 +440,17 @@ ;;; must be called. (defun standard-sort-methods (applicable-methods) (loop for method in applicable-methods - as qualifiers = (method-qualifiers method) - if (null qualifiers) - collect method into primary - else if (eq :around (car qualifiers)) - collect method into around - else if (eq :after (car qualifiers)) - collect method into after - else if (eq :before (car qualifiers)) - collect method into before - finally - (return (values around before (first primary) (reverse after))))) + as qualifiers = (method-qualifiers method) + if (null qualifiers) + collect method into primary + else if (eq :around (car qualifiers)) + collect method into around + else if (eq :after (car qualifiers)) + collect method into after + else if (eq :before (car qualifiers)) + collect method into before + finally + (return (values around before (first primary) (reverse after))))) ;;; Return as multiple values bindings for default initialization ;;; arguments, variable names, defaulting initargs and a body for @@ -472,151 +462,180 @@ ;;; that we have to check if these before-methods have set slots. (defun slot-init-forms (ctor before-method-p) (let* ((class (ctor-class ctor)) - (initargs (ctor-initargs ctor)) - (initkeys (plist-keys initargs)) - (slot-vector - (make-array (layout-length (class-wrapper class)) - :initial-element nil)) - (class-inits ()) - (default-inits ()) + (initargs (ctor-initargs ctor)) + (initkeys (plist-keys initargs)) + (slot-vector + (make-array (layout-length (class-wrapper class)) + :initial-element nil)) + (class-inits ()) + (default-inits ()) (defaulting-initargs ()) - (default-initargs (class-default-initargs class)) - (initarg-locations - (compute-initarg-locations - class (append initkeys (mapcar #'car default-initargs))))) + (default-initargs (class-default-initargs class)) + (initarg-locations + (compute-initarg-locations + class (append initkeys (mapcar #'car default-initargs))))) (labels ((initarg-locations (initarg) - (cdr (assoc initarg initarg-locations :test #'eq))) - (initializedp (location) - (cond - ((consp location) - (assoc location class-inits :test #'eq)) - ((integerp location) - (not (null (aref slot-vector location)))) - (t (bug "Weird location in ~S" 'slot-init-forms)))) - (class-init (location type val) - (aver (consp location)) - (unless (initializedp location) - (push (list location type val) class-inits))) - (instance-init (location type val) - (aver (integerp location)) - (unless (initializedp location) - (setf (aref slot-vector location) (list type val)))) - (default-init-var-name (i) - (let ((ps #(.d0. .d1. .d2. .d3. .d4. .d5.))) - (if (array-in-bounds-p ps i) - (aref ps i) - (format-symbol *pcl-package* ".D~D." i))))) + (cdr (assoc initarg initarg-locations :test #'eq))) + (initializedp (location) + (cond + ((consp location) + (assoc location class-inits :test #'eq)) + ((integerp location) + (not (null (aref slot-vector location)))) + (t (bug "Weird location in ~S" 'slot-init-forms)))) + (class-init (location kind val type) + (aver (consp location)) + (unless (initializedp location) + (push (list location kind val type) class-inits))) + (instance-init (location kind val type) + (aver (integerp location)) + (unless (initializedp location) + (setf (aref slot-vector location) (list kind val type)))) + (default-init-var-name (i) + (let ((ps #(.d0. .d1. .d2. .d3. .d4. .d5.))) + (if (array-in-bounds-p ps i) + (aref ps i) + (format-symbol *pcl-package* ".D~D." i)))) + (location-var-name (i) + (let ((ls #(.l0. .l1. .l2. .l3. .l4. .l5.))) + (if (array-in-bounds-p ls i) + (aref ls i) + (format-symbol *pcl-package* ".L~D." i))))) ;; Loop over supplied initargs and values and record which ;; instance and class slots they initialize. (loop for (key value) on initargs by #'cddr - as locations = (initarg-locations key) do - (if (constantp value) - (dolist (location locations) - (if (consp location) - (class-init location 'constant value) - (instance-init location 'constant value))) - (dolist (location locations) - (if (consp location) - (class-init location 'param value) - (instance-init location 'param value))))) + as kind = (if (constantp value) 'constant 'param) + as locations = (initarg-locations key) + do (loop for (location . type) in locations + do (if (consp location) + (class-init location kind value type) + (instance-init location kind value type)))) ;; Loop over default initargs of the class, recording ;; initializations of slots that have not been initialized ;; above. Default initargs which are not in the supplied ;; initargs are treated as if they were appended to supplied ;; initargs, that is, their values must be evaluated even ;; if not actually used for initializing a slot. - (loop for (key initfn initform) in default-initargs and i from 0 - unless (member key initkeys :test #'eq) do - (let* ((type (if (constantp initform) 'constant 'var)) - (init (if (eq type 'var) initfn initform))) - (ecase type + (loop for (key initform initfn) in default-initargs and i from 0 + unless (member key initkeys :test #'eq) do + (let* ((kind (if (constantp initform) 'constant 'var)) + (init (if (eq kind 'var) initfn initform))) + (ecase kind (constant (push key defaulting-initargs) (push initform defaulting-initargs)) (var (push key defaulting-initargs) (push (default-init-var-name i) defaulting-initargs))) - (when (eq type 'var) - (let ((init-var (default-init-var-name i))) - (setq init init-var) - (push (cons init-var initfn) default-inits))) - (dolist (location (initarg-locations key)) - (if (consp location) - (class-init location type init) - (instance-init location type init))))) + (when (eq kind 'var) + (let ((init-var (default-init-var-name i))) + (setq init init-var) + (push (cons init-var initfn) default-inits))) + (loop for (location . type) in (initarg-locations key) + do (if (consp location) + (class-init location kind init type) + (instance-init location kind init type))))) ;; Loop over all slots of the class, filling in the rest from ;; slot initforms. (loop for slotd in (class-slots class) - as location = (slot-definition-location slotd) - as allocation = (slot-definition-allocation slotd) - as initfn = (slot-definition-initfunction slotd) - as initform = (slot-definition-initform slotd) do - (unless (or (eq allocation :class) - (null initfn) - (initializedp location)) - (if (constantp initform) - (instance-init location 'initform initform) - (instance-init location 'initform/initfn initfn)))) + as location = (slot-definition-location slotd) + as type = (slot-definition-type slotd) + as allocation = (slot-definition-allocation slotd) + as initfn = (slot-definition-initfunction slotd) + as initform = (slot-definition-initform slotd) do + (unless (or (eq allocation :class) + (null initfn) + (initializedp location)) + (if (constantp initform) + (instance-init location 'initform initform type) + (instance-init location 'initform/initfn initfn type)))) ;; Generate the forms for initializing instance and class slots. (let ((instance-init-forms - (loop for slot-entry across slot-vector and i from 0 - as (type value) = slot-entry collect - (ecase type - ((nil) - (unless before-method-p - `(setf (clos-slots-ref .slots. ,i) +slot-unbound+))) - ((param var) - `(setf (clos-slots-ref .slots. ,i) ,value)) - (initfn - `(setf (clos-slots-ref .slots. ,i) (funcall ,value))) - (initform/initfn - (if before-method-p - `(when (eq (clos-slots-ref .slots. ,i) - +slot-unbound+) - (setf (clos-slots-ref .slots. ,i) - (funcall ,value))) - `(setf (clos-slots-ref .slots. ,i) - (funcall ,value)))) - (initform - (if before-method-p - `(when (eq (clos-slots-ref .slots. ,i) - +slot-unbound+) - (setf (clos-slots-ref .slots. ,i) - ',(eval value))) - `(setf (clos-slots-ref .slots. ,i) - ',(eval value)))) - (constant - `(setf (clos-slots-ref .slots. ,i) ',(eval value)))))) - (class-init-forms - (loop for (location type value) in class-inits collect - `(setf (cdr ',location) - ,(ecase type - (constant `',(eval value)) - ((param var) `,value) - (initfn `(funcall ,value))))))) - (multiple-value-bind (vars bindings) - (loop for (var . initfn) in (nreverse default-inits) - collect var into vars - collect `(,var (funcall ,initfn)) into bindings - finally (return (values vars bindings))) - (values bindings vars (nreverse defaulting-initargs) - `(,@(delete nil instance-init-forms) - ,@class-init-forms))))))) + (loop for slot-entry across slot-vector and i from 0 + as (kind value type) = slot-entry collect + (ecase kind + ((nil) + (unless before-method-p + `(setf (clos-slots-ref .slots. ,i) +slot-unbound+))) + ((param var) + `(setf (clos-slots-ref .slots. ,i) + (locally (declare (optimize (safety 3))) + (the ,type ,value)))) + (initfn + `(setf (clos-slots-ref .slots. ,i) + (locally (declare (optimize (safety 3))) + (the ,type (funcall ,value))))) + (initform/initfn + (if before-method-p + `(when (eq (clos-slots-ref .slots. ,i) + +slot-unbound+) + (setf (clos-slots-ref .slots. ,i) + (locally (declare (optimize (safety 3))) + (the ,type (funcall ,value))))) + `(setf (clos-slots-ref .slots. ,i) + (locally (declare (optimize (safety 3))) + (funcall ,value))))) + (initform + (if before-method-p + `(when (eq (clos-slots-ref .slots. ,i) + +slot-unbound+) + (setf (clos-slots-ref .slots. ,i) + (locally (declare (optimize (safety 3))) + (the ,type ',(eval value))))) + `(setf (clos-slots-ref .slots. ,i) + (locally (declare (optimize (safety 3))) + (the ,type ',(eval value)))))) + (constant + `(setf (clos-slots-ref .slots. ,i) + (locally (declare (optimize (safety 3))) + (the ,type ',(eval value))))))))) + ;; we are not allowed to modify QUOTEd locations, so we can't + ;; generate code like (setf (cdr ',location) arg). Instead, + ;; we have to do (setf (cdr .L0.) arg) and arrange for .L0. to + ;; be bound to the location. + (multiple-value-bind (names locations class-init-forms) + (loop for (location kind value type) in class-inits + for i upfrom 0 + for name = (location-var-name i) + collect name into names + collect location into locations + collect `(setf (cdr ,name) + (locally (declare (optimize (safety 3))) + (the ,type + ,(case kind + (constant `',(eval value)) + ((param var) `,value) + (initfn `(funcall ,value)))))) + into class-init-forms + finally (return (values names locations class-init-forms))) + (multiple-value-bind (vars bindings) + (loop for (var . initfn) in (nreverse default-inits) + collect var into vars + collect `(,var (funcall ,initfn)) into bindings + finally (return (values vars bindings))) + (values locations names + bindings vars + (nreverse defaulting-initargs) + `(,@(delete nil instance-init-forms) + ,@class-init-forms)))))))) -;;; Return an alist of lists (KEY LOCATION ...) telling, for each -;;; key in INITKEYS, which locations the initarg initializes. -;;; CLASS is the class of the instance being initialized. +;;; Return an alist of lists (KEY (LOCATION . TYPE-SPECIFIER) ...) +;;; telling, for each key in INITKEYS, which locations the initarg +;;; initializes and the associated type with the location. CLASS is +;;; the class of the instance being initialized. (defun compute-initarg-locations (class initkeys) (loop with slots = (class-slots class) - for key in initkeys collect - (loop for slot in slots - if (memq key (slot-definition-initargs slot)) - collect (slot-definition-location slot) into locations - else - collect slot into remaining-slots - finally - (setq slots remaining-slots) - (return (cons key locations))))) + for key in initkeys collect + (loop for slot in slots + if (memq key (slot-definition-initargs slot)) + collect (cons (slot-definition-location slot) + (slot-definition-type slot)) + into locations + else + collect slot into remaining-slots + finally + (setq slots remaining-slots) + (return (cons key locations))))) ;;; ******************************* @@ -625,13 +644,13 @@ (defun update-ctors (reason &key class name generic-function method) (labels ((reset (class &optional ri-cache-p (ctorsp t)) - (when ctorsp - (dolist (ctor (plist-value class 'ctors)) - (install-initial-constructor ctor))) - (when ri-cache-p - (setf (plist-value class 'ri-initargs) ())) - (dolist (subclass (class-direct-subclasses class)) - (reset subclass ri-cache-p ctorsp)))) + (when ctorsp + (dolist (ctor (plist-value class 'ctors)) + (install-initial-constructor ctor))) + (when ri-cache-p + (setf (plist-value class 'ri-initargs) ())) + (dolist (subclass (class-direct-subclasses class)) + (reset subclass ri-cache-p ctorsp)))) (ecase reason ;; CLASS must have been specified. (finalize-inheritance @@ -639,56 +658,56 @@ ;; NAME must have been specified. (setf-find-class (loop for ctor in *all-ctors* - when (eq (ctor-class-name ctor) name) do - (when (ctor-class ctor) - (reset (ctor-class ctor))) - (loop-finish))) + when (eq (ctor-class-name ctor) name) do + (when (ctor-class ctor) + (reset (ctor-class ctor))) + (loop-finish))) ;; GENERIC-FUNCTION and METHOD must have been specified. ((add-method remove-method) (flet ((class-of-1st-method-param (method) - (type-class (first (method-specializers method))))) - (case (generic-function-name generic-function) - ((make-instance allocate-instance - initialize-instance shared-initialize) - (reset (class-of-1st-method-param method) t t)) - ((reinitialize-instance) - (reset (class-of-1st-method-param method) t nil)) - (t (when (or (eq (generic-function-name generic-function) - 'slot-boundp-using-class) - (equal (generic-function-name generic-function) - '(setf slot-value-using-class))) - ;; this looks awfully expensive, but given that one - ;; can specialize on the SLOTD argument, nothing is - ;; safe. -- CSR, 2004-07-12 - (reset (find-class 'standard-object)))))))))) + (type-class (first (method-specializers method))))) + (case (generic-function-name generic-function) + ((make-instance allocate-instance + initialize-instance shared-initialize) + (reset (class-of-1st-method-param method) t t)) + ((reinitialize-instance) + (reset (class-of-1st-method-param method) t nil)) + (t (when (or (eq (generic-function-name generic-function) + 'slot-boundp-using-class) + (equal (generic-function-name generic-function) + '(setf slot-value-using-class))) + ;; this looks awfully expensive, but given that one + ;; can specialize on the SLOTD argument, nothing is + ;; safe. -- CSR, 2004-07-12 + (reset (find-class 'standard-object)))))))))) (defun precompile-ctors () (dolist (ctor *all-ctors*) (when (null (ctor-class ctor)) (let ((class (find-class (ctor-class-name ctor) nil))) - (when (and class (class-finalized-p class)) - (install-optimized-constructor ctor)))))) + (when (and class (class-finalized-p class)) + (install-optimized-constructor ctor)))))) (defun check-ri-initargs (instance initargs) (let* ((class (class-of instance)) - (keys (plist-keys initargs)) - (cached (assoc keys (plist-value class 'ri-initargs) - :test #'equal)) - (invalid-keys - (if (consp cached) - (cdr cached) - (let ((invalid - ;; FIXME: give CHECK-INITARGS-1 and friends a - ;; more mnemonic name and (possibly) a nicer, - ;; more orthogonal interface. - (check-initargs-1 - class initargs - (list (list* 'reinitialize-instance instance initargs) - (list* 'shared-initialize instance nil initargs)) - t nil))) - (setf (plist-value class 'ri-initargs) - (acons keys invalid cached)) - invalid)))) + (keys (plist-keys initargs)) + (cached (assoc keys (plist-value class 'ri-initargs) + :test #'equal)) + (invalid-keys + (if (consp cached) + (cdr cached) + (let ((invalid + ;; FIXME: give CHECK-INITARGS-1 and friends a + ;; more mnemonic name and (possibly) a nicer, + ;; more orthogonal interface. + (check-initargs-1 + class initargs + (list (list* 'reinitialize-instance instance initargs) + (list* 'shared-initialize instance nil initargs)) + t nil))) + (setf (plist-value class 'ri-initargs) + (acons keys invalid cached)) + invalid)))) (when invalid-keys (error 'initarg-error :class class :initargs invalid-keys)))) diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 2b84a1856..63a448f21 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -83,88 +83,88 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;;; ( . ( ...)). ;;; Each subentry is of the form ;;; ( ). -(defvar *dfun-constructors* ()) +(defvar *dfun-constructors* ()) ;;; If this is NIL, then the whole mechanism for caching dfun constructors is ;;; turned off. The only time that makes sense is when debugging LAP code. -(defvar *enable-dfun-constructor-caching* t) +(defvar *enable-dfun-constructor-caching* t) (defun show-dfun-constructors () (format t "~&DFUN constructor caching is ~A." - (if *enable-dfun-constructor-caching* - "enabled" "disabled")) + (if *enable-dfun-constructor-caching* + "enabled" "disabled")) (dolist (generator-entry *dfun-constructors*) (dolist (args-entry (cdr generator-entry)) (format t "~&~S ~S" - (cons (car generator-entry) (caar args-entry)) - (caddr args-entry))))) + (cons (car generator-entry) (caar args-entry)) + (caddr args-entry))))) (defvar *raise-metatypes-to-class-p* t) (defun get-dfun-constructor (generator &rest args) (when (and *raise-metatypes-to-class-p* - (member generator '(emit-checking emit-caching - emit-in-checking-cache-p emit-constant-value))) + (member generator '(emit-checking emit-caching + emit-in-checking-cache-p emit-constant-value))) (setq args (cons (mapcar (lambda (mt) - (if (eq mt t) - mt - 'class)) - (car args)) - (cdr args)))) + (if (eq mt t) + mt + 'class)) + (car args)) + (cdr args)))) (let* ((generator-entry (assq generator *dfun-constructors*)) - (args-entry (assoc args (cdr generator-entry) :test #'equal))) + (args-entry (assoc args (cdr generator-entry) :test #'equal))) (if (null *enable-dfun-constructor-caching*) - (apply (fdefinition generator) args) - (or (cadr args-entry) - (multiple-value-bind (new not-best-p) - (apply (symbol-function generator) args) - (let ((entry (list (copy-list args) new (unless not-best-p 'pcl) - not-best-p))) - (if generator-entry - (push entry (cdr generator-entry)) - (push (list generator entry) - *dfun-constructors*))) - (values new not-best-p)))))) + (apply (fdefinition generator) args) + (or (cadr args-entry) + (multiple-value-bind (new not-best-p) + (apply (symbol-function generator) args) + (let ((entry (list (copy-list args) new (unless not-best-p 'pcl) + not-best-p))) + (if generator-entry + (push entry (cdr generator-entry)) + (push (list generator entry) + *dfun-constructors*))) + (values new not-best-p)))))) (defun load-precompiled-dfun-constructor (generator args system constructor) (let* ((generator-entry (assq generator *dfun-constructors*)) - (args-entry (assoc args (cdr generator-entry) :test #'equal))) + (args-entry (assoc args (cdr generator-entry) :test #'equal))) (if args-entry - (when (fourth args-entry) - (let* ((dfun-type (case generator - (emit-checking 'checking) - (emit-caching 'caching) - (emit-constant-value 'constant-value) - (emit-default-only 'default-method-only))) - (metatypes (car args)) - (gfs (when dfun-type (gfs-of-type dfun-type)))) - (dolist (gf gfs) - (when (and (equal metatypes - (arg-info-metatypes (gf-arg-info gf))) - (let ((gf-name (generic-function-name gf))) - (and (not (eq gf-name 'slot-value-using-class)) - (not (equal gf-name - '(setf slot-value-using-class))) - (not (eq gf-name 'slot-boundp-using-class))))) - (update-dfun gf))) - (setf (second args-entry) constructor) - (setf (third args-entry) system) - (setf (fourth args-entry) nil))) - (let ((entry (list args constructor system nil))) - (if generator-entry - (push entry (cdr generator-entry)) - (push (list generator entry) *dfun-constructors*)))))) + (when (fourth args-entry) + (let* ((dfun-type (case generator + (emit-checking 'checking) + (emit-caching 'caching) + (emit-constant-value 'constant-value) + (emit-default-only 'default-method-only))) + (metatypes (car args)) + (gfs (when dfun-type (gfs-of-type dfun-type)))) + (dolist (gf gfs) + (when (and (equal metatypes + (arg-info-metatypes (gf-arg-info gf))) + (let ((gf-name (generic-function-name gf))) + (and (not (eq gf-name 'slot-value-using-class)) + (not (equal gf-name + '(setf slot-value-using-class))) + (not (eq gf-name 'slot-boundp-using-class))))) + (update-dfun gf))) + (setf (second args-entry) constructor) + (setf (third args-entry) system) + (setf (fourth args-entry) nil))) + (let ((entry (list args constructor system nil))) + (if generator-entry + (push entry (cdr generator-entry)) + (push (list generator entry) *dfun-constructors*)))))) (defmacro precompile-dfun-constructors (&optional system) (let ((*precompiling-lap* t)) `(progn ,@(let (collect) - (dolist (generator-entry *dfun-constructors*) - (dolist (args-entry (cdr generator-entry)) - (when (or (null (caddr args-entry)) - (eq (caddr args-entry) system)) - (when system (setf (caddr args-entry) system)) - (push `(load-precompiled-dfun-constructor + (dolist (generator-entry *dfun-constructors*) + (dolist (args-entry (cdr generator-entry)) + (when (or (null (caddr args-entry)) + (eq (caddr args-entry) system)) + (when system (setf (caddr args-entry) system)) + (push `(load-precompiled-dfun-constructor ',(car generator-entry) ',(car args-entry) ',system @@ -191,30 +191,30 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (dolist (class-name *standard-classes*) (let ((class (find-class class-name))) (dolist (slot (class-slots class)) - (setf (gethash (cons class (slot-definition-name slot)) - *standard-slot-locations*) - (slot-definition-location slot)))))) + (setf (gethash (cons class (slot-definition-name slot)) + *standard-slot-locations*) + (slot-definition-location slot)))))) ;;; FIXME: harmonize the names between COMPUTE-STANDARD-SLOT-LOCATIONS ;;; and MAYBE-UPDATE-STANDARD-CLASS-LOCATIONS. (defun maybe-update-standard-class-locations (class) (when (and (eq *boot-state* 'complete) - (memq (class-name class) *standard-classes*)) + (memq (class-name class) *standard-classes*)) (compute-standard-slot-locations))) (defun standard-slot-value (object slot-name class) (let ((location (gethash (cons class slot-name) *standard-slot-locations*))) (if location - (let ((value (if (funcallable-instance-p object) - (funcallable-standard-instance-access object location) - (standard-instance-access object location)))) - (when (eq +slot-unbound+ value) - (error "~@" - slot-name class object)) - value) - (error "~@" + slot-name class object)) + value) + (error "~@" - slot-name class object)))) + slot-name class object)))) (defun standard-slot-value/gf (gf slot-name) (standard-slot-value gf slot-name *the-class-standard-generic-function*)) @@ -224,7 +224,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun standard-slot-value/eslotd (slotd slot-name) (standard-slot-value slotd slot-name - *the-class-standard-effective-slot-definition*)) + *the-class-standard-effective-slot-definition*)) (defun standard-slot-value/class (class slot-name) (standard-slot-value class slot-name *the-class-standard-class*)) @@ -263,28 +263,28 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;;; and corresponding slot indexes. Because each cache line is ;;; more than one element long, a cache lock count is used. (defstruct (dfun-info (:constructor nil) - (:copier nil)) + (:copier nil)) (cache nil)) (defstruct (no-methods (:constructor no-methods-dfun-info ()) - (:include dfun-info) - (:copier nil))) + (:include dfun-info) + (:copier nil))) (defstruct (initial (:constructor initial-dfun-info ()) - (:include dfun-info) - (:copier nil))) + (:include dfun-info) + (:copier nil))) (defstruct (initial-dispatch (:constructor initial-dispatch-dfun-info ()) - (:include dfun-info) - (:copier nil))) + (:include dfun-info) + (:copier nil))) (defstruct (dispatch (:constructor dispatch-dfun-info ()) - (:include dfun-info) - (:copier nil))) + (:include dfun-info) + (:copier nil))) (defstruct (default-method-only (:constructor default-method-only-dfun-info ()) - (:include dfun-info) - (:copier nil))) + (:include dfun-info) + (:copier nil))) ;without caching: ; dispatch one-class two-class default-method-only @@ -295,63 +295,63 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;accessor: ; one-class two-class one-index n-n (defstruct (accessor-dfun-info (:constructor nil) - (:include dfun-info) - (:copier nil)) + (:include dfun-info) + (:copier nil)) accessor-type) ; (member reader writer) (defmacro dfun-info-accessor-type (di) `(accessor-dfun-info-accessor-type ,di)) (defstruct (one-index-dfun-info (:constructor nil) - (:include accessor-dfun-info) - (:copier nil)) + (:include accessor-dfun-info) + (:copier nil)) index) (defmacro dfun-info-index (di) `(one-index-dfun-info-index ,di)) (defstruct (n-n (:constructor n-n-dfun-info (accessor-type cache)) - (:include accessor-dfun-info) - (:copier nil))) + (:include accessor-dfun-info) + (:copier nil))) (defstruct (one-class (:constructor one-class-dfun-info - (accessor-type index wrapper0)) - (:include one-index-dfun-info) - (:copier nil)) + (accessor-type index wrapper0)) + (:include one-index-dfun-info) + (:copier nil)) wrapper0) (defmacro dfun-info-wrapper0 (di) `(one-class-wrapper0 ,di)) (defstruct (two-class (:constructor two-class-dfun-info - (accessor-type index wrapper0 wrapper1)) - (:include one-class) - (:copier nil)) + (accessor-type index wrapper0 wrapper1)) + (:include one-class) + (:copier nil)) wrapper1) (defmacro dfun-info-wrapper1 (di) `(two-class-wrapper1 ,di)) (defstruct (one-index (:constructor one-index-dfun-info - (accessor-type index cache)) - (:include one-index-dfun-info) - (:copier nil))) + (accessor-type index cache)) + (:include one-index-dfun-info) + (:copier nil))) (defstruct (checking (:constructor checking-dfun-info (function cache)) - (:include dfun-info) - (:copier nil)) + (:include dfun-info) + (:copier nil)) function) (defmacro dfun-info-function (di) `(checking-function ,di)) (defstruct (caching (:constructor caching-dfun-info (cache)) - (:include dfun-info) - (:copier nil))) + (:include dfun-info) + (:copier nil))) (defstruct (constant-value (:constructor constant-value-dfun-info (cache)) - (:include dfun-info) - (:copier nil))) + (:include dfun-info) + (:copier nil))) (defmacro dfun-update (generic-function function &rest args) `(multiple-value-bind (dfun cache info) @@ -371,44 +371,44 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun make-one-class-accessor-dfun (gf type wrapper index) (let ((emit (ecase type - (reader 'emit-one-class-reader) - (boundp 'emit-one-class-boundp) - (writer 'emit-one-class-writer))) - (dfun-info (one-class-dfun-info type index wrapper))) + (reader 'emit-one-class-reader) + (boundp 'emit-one-class-boundp) + (writer 'emit-one-class-writer))) + (dfun-info (one-class-dfun-info type index wrapper))) (values (funcall (get-dfun-constructor emit (consp index)) - wrapper index - (accessor-miss-function gf dfun-info)) + wrapper index + (accessor-miss-function gf dfun-info)) nil dfun-info))) (defun make-two-class-accessor-dfun (gf type w0 w1 index) (let ((emit (ecase type - (reader 'emit-two-class-reader) - (boundp 'emit-two-class-boundp) - (writer 'emit-two-class-writer))) - (dfun-info (two-class-dfun-info type index w0 w1))) + (reader 'emit-two-class-reader) + (boundp 'emit-two-class-boundp) + (writer 'emit-two-class-writer))) + (dfun-info (two-class-dfun-info type index w0 w1))) (values (funcall (get-dfun-constructor emit (consp index)) - w0 w1 index - (accessor-miss-function gf dfun-info)) + w0 w1 index + (accessor-miss-function gf dfun-info)) nil dfun-info))) ;;; std accessors same index dfun (defun make-one-index-accessor-dfun (gf type index &optional cache) (let* ((emit (ecase type - (reader 'emit-one-index-readers) - (boundp 'emit-one-index-boundps) - (writer 'emit-one-index-writers))) - (cache (or cache (get-cache 1 nil #'one-index-limit-fn 4))) - (dfun-info (one-index-dfun-info type index cache))) + (reader 'emit-one-index-readers) + (boundp 'emit-one-index-boundps) + (writer 'emit-one-index-writers))) + (cache (or cache (get-cache 1 nil #'one-index-limit-fn 4))) + (dfun-info (one-index-dfun-info type index cache))) (declare (type cache cache)) (values (funcall (get-dfun-constructor emit (consp index)) - cache - index - (accessor-miss-function gf dfun-info)) + cache + index + (accessor-miss-function gf dfun-info)) cache dfun-info))) @@ -421,16 +421,16 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun make-n-n-accessor-dfun (gf type &optional cache) (let* ((emit (ecase type - (reader 'emit-n-n-readers) - (boundp 'emit-n-n-boundps) - (writer 'emit-n-n-writers))) - (cache (or cache (get-cache 1 t #'n-n-accessors-limit-fn 2))) - (dfun-info (n-n-dfun-info type cache))) + (reader 'emit-n-n-readers) + (boundp 'emit-n-n-boundps) + (writer 'emit-n-n-writers))) + (cache (or cache (get-cache 1 t #'n-n-accessors-limit-fn 2))) + (dfun-info (n-n-dfun-info type cache))) (declare (type cache cache)) (values (funcall (get-dfun-constructor emit) - cache - (accessor-miss-function gf dfun-info)) + cache + (accessor-miss-function gf dfun-info)) cache dfun-info))) @@ -451,34 +451,36 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (get-generic-fun-info generic-function) (declare (ignore nreq)) (if (every (lambda (mt) (eq mt t)) metatypes) - (let ((dfun-info (default-method-only-dfun-info))) - (values - (funcall (get-dfun-constructor 'emit-default-only metatypes applyp) - function) - nil - dfun-info)) - (let* ((cache (or cache (get-cache nkeys nil #'checking-limit-fn 2))) - (dfun-info (checking-dfun-info function cache))) - (values - (funcall (get-dfun-constructor 'emit-checking metatypes applyp) - cache - function - (lambda (&rest args) - (checking-miss generic-function args dfun-info))) - cache - dfun-info))))) + (let ((dfun-info (default-method-only-dfun-info))) + (values + (funcall (get-dfun-constructor 'emit-default-only metatypes applyp) + function) + nil + dfun-info)) + (let* ((cache (or cache (get-cache nkeys nil #'checking-limit-fn 2))) + (dfun-info (checking-dfun-info function cache))) + (values + (funcall (get-dfun-constructor 'emit-checking metatypes applyp) + cache + function + (lambda (&rest args) + (checking-miss generic-function args dfun-info))) + cache + dfun-info))))) (defun make-final-checking-dfun (generic-function function - classes-list new-class) - (let ((metatypes (arg-info-metatypes (gf-arg-info generic-function)))) + classes-list new-class) + (multiple-value-bind (nreq applyp metatypes nkeys) + (get-generic-fun-info generic-function) + (declare (ignore nreq applyp nkeys)) (if (every (lambda (mt) (eq mt t)) metatypes) - (values (lambda (&rest args) - (invoke-emf function args)) - nil (default-method-only-dfun-info)) - (let ((cache (make-final-ordinary-dfun-internal - generic-function nil #'checking-limit-fn - classes-list new-class))) - (make-checking-dfun generic-function function cache))))) + (values (lambda (&rest args) + (invoke-emf function args)) + nil (default-method-only-dfun-info)) + (let ((cache (make-final-ordinary-dfun-internal + generic-function nil #'checking-limit-fn + classes-list new-class))) + (make-checking-dfun generic-function function cache))))) (defun use-default-method-only-dfun-p (generic-function) (multiple-value-bind (nreq applyp metatypes nkeys) @@ -488,20 +490,20 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun use-caching-dfun-p (generic-function) (some (lambda (method) - (let ((fmf (if (listp method) - (third method) - (method-fast-function method)))) - (method-function-get fmf :slot-name-lists))) - ;; KLUDGE: As of sbcl-0.6.4, it's very important for - ;; efficiency to know the type of the sequence argument to - ;; quantifiers (SOME/NOTANY/etc.) at compile time, but - ;; the compiler isn't smart enough to understand the :TYPE - ;; slot option for DEFCLASS, so we just tell - ;; it the type by hand here. - (the list - (if (early-gf-p generic-function) - (early-gf-methods generic-function) - (generic-function-methods generic-function))))) + (let ((fmf (if (listp method) + (third method) + (method-fast-function method)))) + (method-function-get fmf :slot-name-lists))) + ;; KLUDGE: As of sbcl-0.6.4, it's very important for + ;; efficiency to know the type of the sequence argument to + ;; quantifiers (SOME/NOTANY/etc.) at compile time, but + ;; the compiler isn't smart enough to understand the :TYPE + ;; slot option for DEFCLASS, so we just tell + ;; it the type by hand here. + (the list + (if (early-gf-p generic-function) + (early-gf-methods generic-function) + (generic-function-methods generic-function))))) (defun checking-limit-fn (nlines) (default-limit-fn nlines)) @@ -510,27 +512,27 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (unless cache (when (use-constant-value-dfun-p generic-function) (return-from make-caching-dfun - (make-constant-value-dfun generic-function))) + (make-constant-value-dfun generic-function))) (when (use-dispatch-dfun-p generic-function) (return-from make-caching-dfun - (make-dispatch-dfun generic-function)))) + (make-dispatch-dfun generic-function)))) (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-fun-info generic-function) (declare (ignore nreq)) (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2))) - (dfun-info (caching-dfun-info cache))) + (dfun-info (caching-dfun-info cache))) (values (funcall (get-dfun-constructor 'emit-caching metatypes applyp) - cache - (lambda (&rest args) - (caching-miss generic-function args dfun-info))) + cache + (lambda (&rest args) + (caching-miss generic-function args dfun-info))) cache dfun-info)))) (defun make-final-caching-dfun (generic-function classes-list new-class) (let ((cache (make-final-ordinary-dfun-internal - generic-function t #'caching-limit-fn - classes-list new-class))) + generic-function t #'caching-limit-fn + classes-list new-class))) (make-caching-dfun generic-function cache))) (defun caching-limit-fn (nlines) @@ -541,9 +543,9 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (get-generic-fun-info gf) (declare (ignore nreq nkeys)) (when (and metatypes - (not (null (car metatypes))) - (dolist (mt metatypes nil) - (unless (eq mt t) (return t)))) + (not (null (car metatypes))) + (dolist (mt metatypes nil) + (unless (eq mt t) (return t)))) (get-dfun-constructor 'emit-caching metatypes applyp)))) (defun use-constant-value-dfun-p (gf &optional boolean-values-p) @@ -551,71 +553,72 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (get-generic-fun-info gf) (declare (ignore nreq metatypes nkeys)) (let* ((early-p (early-gf-p gf)) - (methods (if early-p - (early-gf-methods gf) - (generic-function-methods gf))) - (default '(unknown))) + (methods (if early-p + (early-gf-methods gf) + (generic-function-methods gf))) + (default '(unknown))) (and (null applyp) - (or (not (eq *boot-state* 'complete)) - ;; If COMPUTE-APPLICABLE-METHODS is specialized, we - ;; can't use this, of course, because we can't tell - ;; which methods will be considered applicable. - ;; - ;; Also, don't use this dfun method if the generic - ;; function has a non-standard method combination, - ;; because if it has, it's not sure that method - ;; functions are used directly as effective methods, - ;; which CONSTANT-VALUE-MISS depends on. The - ;; pre-defined method combinations like LIST are - ;; examples of that. - (and (compute-applicable-methods-emf-std-p gf) - (eq (generic-function-method-combination gf) - *standard-method-combination*))) - ;; Check that no method is eql-specialized, and that all - ;; methods return a constant value. If BOOLEAN-VALUES-P, - ;; check that all return T or NIL. Also, check that no - ;; method has qualifiers, to make sure that emfs are really - ;; method functions; see above. - (dolist (method methods t) - (when (eq *boot-state* 'complete) - (when (or (some #'eql-specializer-p - (method-specializers method)) - (method-qualifiers method)) - (return nil))) - (let ((value (method-function-get - (if early-p - (or (third method) (second method)) - (or (method-fast-function method) - (method-function method))) - :constant-value default))) - (when (or (eq value default) - (and boolean-values-p - (not (member value '(t nil))))) - (return nil)))))))) + (or (not (eq *boot-state* 'complete)) + ;; If COMPUTE-APPLICABLE-METHODS is specialized, we + ;; can't use this, of course, because we can't tell + ;; which methods will be considered applicable. + ;; + ;; Also, don't use this dfun method if the generic + ;; function has a non-standard method combination, + ;; because if it has, it's not sure that method + ;; functions are used directly as effective methods, + ;; which CONSTANT-VALUE-MISS depends on. The + ;; pre-defined method combinations like LIST are + ;; examples of that. + (and (compute-applicable-methods-emf-std-p gf) + (eq (generic-function-method-combination gf) + *standard-method-combination*))) + ;; Check that no method is eql-specialized, and that all + ;; methods return a constant value. If BOOLEAN-VALUES-P, + ;; check that all return T or NIL. Also, check that no + ;; method has qualifiers, to make sure that emfs are really + ;; method functions; see above. + (dolist (method methods t) + (when (eq *boot-state* 'complete) + (when (or (some #'eql-specializer-p + (method-specializers method)) + (method-qualifiers method)) + (return nil))) + (let ((value (method-function-get + (if early-p + (or (third method) (second method)) + (or (method-fast-function method) + (method-function method))) + :constant-value default))) + (when (or (eq value default) + (and boolean-values-p + (not (member value '(t nil))))) + (return nil)))))))) (defun make-constant-value-dfun (generic-function &optional cache) (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-fun-info generic-function) (declare (ignore nreq applyp)) (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2))) - (dfun-info (constant-value-dfun-info cache))) + (dfun-info (constant-value-dfun-info cache))) (values (funcall (get-dfun-constructor 'emit-constant-value metatypes) - cache - (lambda (&rest args) - (constant-value-miss generic-function args dfun-info))) + cache + (lambda (&rest args) + (constant-value-miss generic-function args dfun-info))) cache dfun-info)))) (defun make-final-constant-value-dfun (generic-function classes-list new-class) (let ((cache (make-final-ordinary-dfun-internal - generic-function :constant-value #'caching-limit-fn - classes-list new-class))) + generic-function :constant-value #'caching-limit-fn + classes-list new-class))) (make-constant-value-dfun generic-function cache))) (defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf))) (when (eq *boot-state* 'complete) - (unless (or caching-p (gf-requires-emf-keyword-checks gf)) + (unless (or caching-p + (gf-requires-emf-keyword-checks gf)) ;; This should return T when almost all dispatching is by ;; eql specializers or built-in classes. In other words, ;; return NIL if we might ever need to do more than @@ -628,7 +631,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ||# ;; This uses improved dispatch-dfun-cost below (let ((cdc (caching-dfun-cost gf))) ; fast - (> cdc (dispatch-dfun-cost gf cdc)))))) + (> cdc (dispatch-dfun-cost gf cdc)))))) (defparameter *non-built-in-typep-cost* 1) (defparameter *structure-typep-cost* 1) @@ -646,20 +649,20 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (lambda (position type true-value false-value) (declare (ignore position)) (let* ((type-test-cost - (if (eq 'class (car type)) - (let* ((metaclass (class-of (cadr type))) - (mcpl (class-precedence-list metaclass))) - (cond ((memq *the-class-built-in-class* mcpl) - *built-in-typep-cost*) - ((memq *the-class-structure-class* mcpl) - *structure-typep-cost*) - (t - *non-built-in-typep-cost*))) - 0)) - (max-cost-so-far - (+ (max true-value false-value) type-test-cost))) + (if (eq 'class (car type)) + (let* ((metaclass (class-of (cadr type))) + (mcpl (class-precedence-list metaclass))) + (cond ((memq *the-class-built-in-class* mcpl) + *built-in-typep-cost*) + ((memq *the-class-structure-class* mcpl) + *structure-typep-cost*) + (t + *non-built-in-typep-cost*))) + 0)) + (max-cost-so-far + (+ (max true-value false-value) type-test-cost))) (when (and limit (<= limit max-cost-so-far)) - (return-from dispatch-dfun-cost max-cost-so-far)) + (return-from dispatch-dfun-cost max-cost-so-far)) max-cost-so-far)) #'identity)) @@ -668,14 +671,13 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defparameter *secondary-dfun-call-cost* 1) (defun caching-dfun-cost (gf) - (let* ((arg-info (gf-arg-info gf)) - (nreq (length (arg-info-metatypes arg-info)))) + (let ((nreq (get-generic-fun-info gf))) (+ *cache-lookup-cost* (* *wrapper-of-cost* nreq) (if (methods-contain-eql-specializer-p - (generic-function-methods gf)) - *secondary-dfun-call-cost* - 0)))) + (generic-function-methods gf)) + *secondary-dfun-call-cost* + 0)))) (setq *non-built-in-typep-cost* 100) (setq *structure-typep-cost* 15) @@ -687,7 +689,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (declaim (inline make-callable)) (defun make-callable (gf methods generator method-alist wrappers) (let* ((*applicable-methods* methods) - (callable (function-funcall generator method-alist wrappers))) + (callable (function-funcall generator method-alist wrappers))) callable)) (defun make-dispatch-dfun (gf) @@ -695,8 +697,8 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun get-dispatch-function (gf) (let* ((methods (generic-function-methods gf)) - (generator (get-secondary-dispatch-function1 - gf methods nil nil nil nil nil t))) + (generator (get-secondary-dispatch-function1 + gf methods nil nil nil nil nil t))) (make-callable gf methods generator nil nil))) (defun make-final-dispatch-dfun (gf) @@ -708,53 +710,53 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun fill-dfun-cache (table valuep nkeys limit-fn &optional cache) (let ((cache (or cache (get-cache nkeys valuep limit-fn - (+ (hash-table-count table) 3))))) + (+ (hash-table-count table) 3))))) (maphash (lambda (classes value) - (setq cache (fill-cache cache - (class-wrapper classes) - value))) - table) + (setq cache (fill-cache cache + (class-wrapper classes) + value))) + table) cache)) (defun make-final-ordinary-dfun-internal (generic-function valuep limit-fn - classes-list new-class) + classes-list new-class) (let* ((arg-info (gf-arg-info generic-function)) - (nkeys (arg-info-nkeys arg-info)) - (new-class (and new-class - (equal (type-of (gf-dfun-info generic-function)) - (cond ((eq valuep t) 'caching) - ((eq valuep :constant-value) 'constant-value) - ((null valuep) 'checking))) - new-class)) - (cache (if new-class - (copy-cache (gf-dfun-cache generic-function)) - (get-cache nkeys (not (null valuep)) limit-fn 4)))) + (nkeys (arg-info-nkeys arg-info)) + (new-class (and new-class + (equal (type-of (gf-dfun-info generic-function)) + (cond ((eq valuep t) 'caching) + ((eq valuep :constant-value) 'constant-value) + ((null valuep) 'checking))) + new-class)) + (cache (if new-class + (copy-cache (gf-dfun-cache generic-function)) + (get-cache nkeys (not (null valuep)) limit-fn 4)))) (make-emf-cache generic-function valuep cache classes-list new-class))) (defvar *dfun-miss-gfs-on-stack* ()) (defmacro dfun-miss ((gf args wrappers invalidp nemf - &optional type index caching-p applicable) - &body body) + &optional type index caching-p applicable) + &body body) (unless applicable (setq applicable (gensym))) `(multiple-value-bind (,nemf ,applicable ,wrappers ,invalidp - ,@(when type `(,type ,index))) + ,@(when type `(,type ,index))) (cache-miss-values ,gf ,args ',(cond (caching-p 'caching) - (type 'accessor) - (t 'checking))) + (type 'accessor) + (t 'checking))) (when (and ,applicable (not (memq ,gf *dfun-miss-gfs-on-stack*))) (let ((*dfun-miss-gfs-on-stack* (cons ,gf *dfun-miss-gfs-on-stack*))) - ,@body)) + ,@body)) ;; Create a FAST-INSTANCE-BOUNDP structure instance for a cached ;; SLOT-BOUNDP so that INVOKE-EMF does the right thing, that is, ;; does not signal a SLOT-UNBOUND error for a boundp test. ,@(if type - ;; FIXME: could the NEMF not be a CONS (for :CLASS-allocated - ;; slots?) - `((if (and (eq ,type 'boundp) (integerp ,nemf)) - (invoke-emf (make-fast-instance-boundp :index ,nemf) ,args) - (invoke-emf ,nemf ,args))) - `((invoke-emf ,nemf ,args))))) + ;; FIXME: could the NEMF not be a CONS (for :CLASS-allocated + ;; slots?) + `((if (and (eq ,type 'boundp) (integerp ,nemf)) + (invoke-emf (make-fast-instance-boundp :index ,nemf) ,args) + (invoke-emf ,nemf ,args))) + `((invoke-emf ,nemf ,args))))) ;;; The dynamically adaptive method lookup algorithm is implemented is ;;; implemented as a kind of state machine. The kinds of @@ -776,91 +778,91 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun finalize-specializers (gf) (let ((methods (generic-function-methods gf))) (when (or (null *max-emf-precomputation-methods*) - (<= (length methods) *max-emf-precomputation-methods*)) + (<= (length methods) *max-emf-precomputation-methods*)) (let ((all-finalized t)) - (dolist (method methods all-finalized) - (dolist (specializer (method-specializers method)) - (when (and (classp specializer) - (not (class-finalized-p specializer))) - (if (class-has-a-forward-referenced-superclass-p specializer) - (setq all-finalized nil) - (finalize-inheritance specializer))))))))) + (dolist (method methods all-finalized) + (dolist (specializer (method-specializers method)) + (when (and (classp specializer) + (not (class-finalized-p specializer))) + (if (class-has-a-forward-referenced-superclass-p specializer) + (setq all-finalized nil) + (finalize-inheritance specializer))))))))) (defun make-initial-dfun (gf) (let ((initial-dfun - #'(instance-lambda (&rest args) - (initial-dfun gf args)))) + #'(lambda (&rest args) + (initial-dfun gf args)))) (multiple-value-bind (dfun cache info) - (cond - ((and (eq *boot-state* 'complete) - (not (finalize-specializers gf))) - (values initial-dfun nil (initial-dfun-info))) - ((and (eq *boot-state* 'complete) - (compute-applicable-methods-emf-std-p gf)) - (let* ((caching-p (use-caching-dfun-p gf)) - ;; KLUDGE: the only effect of this (when - ;; *LAZY-DFUN-COMPUTE-P* is true, as it usually is) - ;; is to signal an error when we try to add methods - ;; with the wrong qualifiers to a generic function. - (classes-list (precompute-effective-methods - gf caching-p - (not *lazy-dfun-compute-p*)))) - (if *lazy-dfun-compute-p* - (cond ((use-dispatch-dfun-p gf caching-p) - (values initial-dfun - nil - (initial-dispatch-dfun-info))) - (caching-p - (insure-caching-dfun gf) - (values initial-dfun nil (initial-dfun-info))) - (t - (values initial-dfun nil (initial-dfun-info)))) - (make-final-dfun-internal gf classes-list)))) - (t - (let ((arg-info (if (early-gf-p gf) - (early-gf-arg-info gf) - (gf-arg-info gf))) - (type nil)) - (if (and (gf-precompute-dfun-and-emf-p arg-info) - (setq type (final-accessor-dfun-type gf))) - (if *early-p* - (values (make-early-accessor gf type) nil nil) - (make-final-accessor-dfun gf type)) - (values initial-dfun nil (initial-dfun-info)))))) + (cond + ((and (eq *boot-state* 'complete) + (not (finalize-specializers gf))) + (values initial-dfun nil (initial-dfun-info))) + ((and (eq *boot-state* 'complete) + (compute-applicable-methods-emf-std-p gf)) + (let* ((caching-p (use-caching-dfun-p gf)) + ;; KLUDGE: the only effect of this (when + ;; *LAZY-DFUN-COMPUTE-P* is true, as it usually is) + ;; is to signal an error when we try to add methods + ;; with the wrong qualifiers to a generic function. + (classes-list (precompute-effective-methods + gf caching-p + (not *lazy-dfun-compute-p*)))) + (if *lazy-dfun-compute-p* + (cond ((use-dispatch-dfun-p gf caching-p) + (values initial-dfun + nil + (initial-dispatch-dfun-info))) + (caching-p + (insure-caching-dfun gf) + (values initial-dfun nil (initial-dfun-info))) + (t + (values initial-dfun nil (initial-dfun-info)))) + (make-final-dfun-internal gf classes-list)))) + (t + (let ((arg-info (if (early-gf-p gf) + (early-gf-arg-info gf) + (gf-arg-info gf))) + (type nil)) + (if (and (gf-precompute-dfun-and-emf-p arg-info) + (setq type (final-accessor-dfun-type gf))) + (if *early-p* + (values (make-early-accessor gf type) nil nil) + (make-final-accessor-dfun gf type)) + (values initial-dfun nil (initial-dfun-info)))))) (set-dfun gf dfun cache info)))) (defun make-early-accessor (gf type) (let* ((methods (early-gf-methods gf)) - (slot-name (early-method-standard-accessor-slot-name (car methods)))) + (slot-name (early-method-standard-accessor-slot-name (car methods)))) (ecase type - (reader #'(instance-lambda (instance) - (let* ((class (class-of instance)) - (class-name (!bootstrap-get-slot 'class class 'name))) - (!bootstrap-get-slot class-name instance slot-name)))) - (boundp #'(instance-lambda (instance) - (let* ((class (class-of instance)) - (class-name (!bootstrap-get-slot 'class class 'name))) - (not (eq +slot-unbound+ - (!bootstrap-get-slot class-name - instance slot-name)))))) - (writer #'(instance-lambda (new-value instance) - (let* ((class (class-of instance)) - (class-name (!bootstrap-get-slot 'class class 'name))) - (!bootstrap-set-slot class-name instance slot-name new-value))))))) + (reader #'(lambda (instance) + (let* ((class (class-of instance)) + (class-name (!bootstrap-get-slot 'class class 'name))) + (!bootstrap-get-slot class-name instance slot-name)))) + (boundp #'(lambda (instance) + (let* ((class (class-of instance)) + (class-name (!bootstrap-get-slot 'class class 'name))) + (not (eq +slot-unbound+ + (!bootstrap-get-slot class-name + instance slot-name)))))) + (writer #'(lambda (new-value instance) + (let* ((class (class-of instance)) + (class-name (!bootstrap-get-slot 'class class 'name))) + (!bootstrap-set-slot class-name instance slot-name new-value))))))) (defun initial-dfun (gf args) (dfun-miss (gf args wrappers invalidp nemf ntype nindex) (cond (invalidp) - ((and ntype nindex) - (dfun-update - gf #'make-one-class-accessor-dfun ntype wrappers nindex)) - ((use-caching-dfun-p gf) - (dfun-update gf #'make-caching-dfun)) - (t - (dfun-update - gf #'make-checking-dfun - ;; nemf is suitable only for caching, have to do this: - (cache-miss-values gf args 'checking)))))) + ((and ntype nindex) + (dfun-update + gf #'make-one-class-accessor-dfun ntype wrappers nindex)) + ((use-caching-dfun-p gf) + (dfun-update gf #'make-caching-dfun)) + (t + (dfun-update + gf #'make-checking-dfun + ;; nemf is suitable only for caching, have to do this: + (cache-miss-values gf args 'checking)))))) (defun make-final-dfun (gf &optional classes-list) (multiple-value-bind (dfun cache info) @@ -873,11 +875,11 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defmacro with-hash-table ((table test) &body forms) `(let* ((.free. (assoc ',test *free-hash-tables*)) - (,table (if (cdr .free.) - (pop (cdr .free.)) - (make-hash-table :test ',test)))) + (,table (if (cdr .free.) + (pop (cdr .free.)) + (make-hash-table :test ',test)))) (multiple-value-prog1 - (progn ,@forms) + (progn ,@forms) (clrhash ,table) (push ,table (cdr .free.))))) @@ -886,231 +888,242 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun final-accessor-dfun-type (gf) (let ((methods (if (early-gf-p gf) - (early-gf-methods gf) - (generic-function-methods gf)))) + (early-gf-methods gf) + (generic-function-methods gf)))) (cond ((every (lambda (method) - (if (consp method) - (eq *the-class-standard-reader-method* - (early-method-class method)) - (standard-reader-method-p method))) - methods) - 'reader) - ((every (lambda (method) - (if (consp method) - (eq *the-class-standard-boundp-method* - (early-method-class method)) - (standard-boundp-method-p method))) - methods) - 'boundp) - ((every (lambda (method) - (if (consp method) - (eq *the-class-standard-writer-method* - (early-method-class method)) - (standard-writer-method-p method))) - methods) - 'writer)))) + (if (consp method) + (eq *the-class-standard-reader-method* + (early-method-class method)) + (standard-reader-method-p method))) + methods) + 'reader) + ((every (lambda (method) + (if (consp method) + (eq *the-class-standard-boundp-method* + (early-method-class method)) + (standard-boundp-method-p method))) + methods) + 'boundp) + ((every (lambda (method) + (if (consp method) + (eq *the-class-standard-writer-method* + (early-method-class method)) + (and + (standard-writer-method-p method) + (eq (slot-definition-type + (accessor-method-slot-definition method)) + t)))) + methods) + 'writer)))) (defun make-final-accessor-dfun (gf type &optional classes-list new-class) (with-eq-hash-table (table) (multiple-value-bind (table all-index first second size no-class-slots-p) - (make-accessor-table gf type table) + (make-accessor-table gf type table) (if table - (cond ((= size 1) - (let ((w (class-wrapper first))) - (make-one-class-accessor-dfun gf type w all-index))) - ((and (= size 2) (or (integerp all-index) (consp all-index))) - (let ((w0 (class-wrapper first)) - (w1 (class-wrapper second))) - (make-two-class-accessor-dfun gf type w0 w1 all-index))) - ((or (integerp all-index) (consp all-index)) - (make-final-one-index-accessor-dfun - gf type all-index table)) - (no-class-slots-p - (make-final-n-n-accessor-dfun gf type table)) - (t - (make-final-caching-dfun gf classes-list new-class))) - (make-final-caching-dfun gf classes-list new-class))))) + (cond ((= size 1) + (let ((w (class-wrapper first))) + (make-one-class-accessor-dfun gf type w all-index))) + ((and (= size 2) (or (integerp all-index) (consp all-index))) + (let ((w0 (class-wrapper first)) + (w1 (class-wrapper second))) + (make-two-class-accessor-dfun gf type w0 w1 all-index))) + ((or (integerp all-index) (consp all-index)) + (make-final-one-index-accessor-dfun + gf type all-index table)) + (no-class-slots-p + (make-final-n-n-accessor-dfun gf type table)) + (t + (make-final-caching-dfun gf classes-list new-class))) + (make-final-caching-dfun gf classes-list new-class))))) (defun make-final-dfun-internal (gf &optional classes-list) (let ((methods (generic-function-methods gf)) type - (new-class *new-class*) (*new-class* nil) - specls all-same-p) + (new-class *new-class*) (*new-class* nil) + specls all-same-p) (cond ((null methods) - (values - #'(instance-lambda (&rest args) - (apply #'no-applicable-method gf args)) - nil - (no-methods-dfun-info))) - ((setq type (final-accessor-dfun-type gf)) - (make-final-accessor-dfun gf type classes-list new-class)) - ((and (not (and (every (lambda (specl) (eq specl *the-class-t*)) - (setq specls - (method-specializers (car methods)))) - (setq all-same-p - (every (lambda (method) - (and (equal specls - (method-specializers - method)))) - methods)))) - (use-constant-value-dfun-p gf)) - (make-final-constant-value-dfun gf classes-list new-class)) - ((use-dispatch-dfun-p gf) - (make-final-dispatch-dfun gf)) - ((and all-same-p (not (use-caching-dfun-p gf))) - (let ((emf (get-secondary-dispatch-function gf methods nil))) - (make-final-checking-dfun gf emf classes-list new-class))) - (t - (make-final-caching-dfun gf classes-list new-class))))) + (values + #'(lambda (&rest args) + (apply #'no-applicable-method gf args)) + nil + (no-methods-dfun-info))) + ((setq type (final-accessor-dfun-type gf)) + (make-final-accessor-dfun gf type classes-list new-class)) + ((and (not (and (every (lambda (specl) (eq specl *the-class-t*)) + (setq specls + (method-specializers (car methods)))) + (setq all-same-p + (every (lambda (method) + (and (equal specls + (method-specializers + method)))) + methods)))) + (use-constant-value-dfun-p gf)) + (make-final-constant-value-dfun gf classes-list new-class)) + ((use-dispatch-dfun-p gf) + (make-final-dispatch-dfun gf)) + ((and all-same-p (not (use-caching-dfun-p gf))) + (let ((emf (get-secondary-dispatch-function gf methods nil))) + (make-final-checking-dfun gf emf classes-list new-class))) + (t + (make-final-caching-dfun gf classes-list new-class))))) + +(defvar *accessor-miss-history* nil) (defun accessor-miss (gf new object dfun-info) - (let* ((ostate (type-of dfun-info)) - (otype (dfun-info-accessor-type dfun-info)) - oindex ow0 ow1 cache - (args (ecase otype - ;; The congruence rules ensure that this is safe - ;; despite not knowing the new type yet. - ((reader boundp) (list object)) - (writer (list new object))))) - (dfun-miss (gf args wrappers invalidp nemf ntype nindex) + (let ((wrapper (wrapper-of object)) + (previous-miss (assq gf *accessor-miss-history*))) + (when (eq wrapper (cdr previous-miss)) + (error "~@" + gf object)) + (let* ((*accessor-miss-history* (acons gf wrapper *accessor-miss-history*)) + (ostate (type-of dfun-info)) + (otype (dfun-info-accessor-type dfun-info)) + oindex ow0 ow1 cache + (args (ecase otype + ((reader boundp) (list object)) + (writer (list new object))))) + (dfun-miss (gf args wrappers invalidp nemf ntype nindex) + ;; The following lexical functions change the state of the + ;; dfun to that which is their name. They accept arguments + ;; which are the parameters of the new state, and get other + ;; information from the lexical variables bound above. + (flet ((two-class (index w0 w1) + (when (zerop (random 2)) (psetf w0 w1 w1 w0)) + (dfun-update gf + #'make-two-class-accessor-dfun + ntype + w0 + w1 + index)) + (one-index (index &optional cache) + (dfun-update gf + #'make-one-index-accessor-dfun + ntype + index + cache)) + (n-n (&optional cache) + (if (consp nindex) + (dfun-update gf #'make-checking-dfun nemf) + (dfun-update gf #'make-n-n-accessor-dfun ntype cache))) + (caching () ; because cached accessor emfs are much faster + ; for accessors + (dfun-update gf #'make-caching-dfun)) + (do-fill (update-fn) + (let ((ncache (fill-cache cache wrappers nindex))) + (unless (eq ncache cache) + (funcall update-fn ncache))))) - ;; The following lexical functions change the state of the - ;; dfun to that which is their name. They accept arguments - ;; which are the parameters of the new state, and get other - ;; information from the lexical variables bound above. - (flet ((two-class (index w0 w1) - (when (zerop (random 2)) (psetf w0 w1 w1 w0)) - (dfun-update gf - #'make-two-class-accessor-dfun - ntype - w0 - w1 - index)) - (one-index (index &optional cache) - (dfun-update gf - #'make-one-index-accessor-dfun - ntype - index - cache)) - (n-n (&optional cache) - (if (consp nindex) - (dfun-update gf #'make-checking-dfun nemf) - (dfun-update gf #'make-n-n-accessor-dfun ntype cache))) - (caching () ; because cached accessor emfs are much faster - ; for accessors - (dfun-update gf #'make-caching-dfun)) - (do-fill (update-fn) - (let ((ncache (fill-cache cache wrappers nindex))) - (unless (eq ncache cache) - (funcall update-fn ncache))))) - - (cond ((null ntype) - (caching)) - ((or invalidp - (null nindex))) - ((not (pcl-instance-p object)) - (caching)) - ((or (neq ntype otype) (listp wrappers)) - (caching)) - (t - (ecase ostate - (one-class - (setq oindex (dfun-info-index dfun-info)) - (setq ow0 (dfun-info-wrapper0 dfun-info)) - (unless (eq ow0 wrappers) - (if (eql nindex oindex) - (two-class nindex ow0 wrappers) - (n-n)))) - (two-class - (setq oindex (dfun-info-index dfun-info)) - (setq ow0 (dfun-info-wrapper0 dfun-info)) - (setq ow1 (dfun-info-wrapper1 dfun-info)) - (unless (or (eq ow0 wrappers) (eq ow1 wrappers)) - (if (eql nindex oindex) - (one-index nindex) - (n-n)))) - (one-index - (setq oindex (dfun-info-index dfun-info)) - (setq cache (dfun-info-cache dfun-info)) - (if (eql nindex oindex) - (do-fill (lambda (ncache) - (one-index nindex ncache))) - (n-n))) - (n-n - (setq cache (dfun-info-cache dfun-info)) - (if (consp nindex) - (caching) - (do-fill #'n-n)))))))))) + (cond ((null ntype) + (caching)) + ((or invalidp + (null nindex))) + ((not (pcl-instance-p object)) + (caching)) + ((or (neq ntype otype) (listp wrappers)) + (caching)) + (t + (ecase ostate + (one-class + (setq oindex (dfun-info-index dfun-info)) + (setq ow0 (dfun-info-wrapper0 dfun-info)) + (unless (eq ow0 wrappers) + (if (eql nindex oindex) + (two-class nindex ow0 wrappers) + (n-n)))) + (two-class + (setq oindex (dfun-info-index dfun-info)) + (setq ow0 (dfun-info-wrapper0 dfun-info)) + (setq ow1 (dfun-info-wrapper1 dfun-info)) + (unless (or (eq ow0 wrappers) (eq ow1 wrappers)) + (if (eql nindex oindex) + (one-index nindex) + (n-n)))) + (one-index + (setq oindex (dfun-info-index dfun-info)) + (setq cache (dfun-info-cache dfun-info)) + (if (eql nindex oindex) + (do-fill (lambda (ncache) + (one-index nindex ncache))) + (n-n))) + (n-n + (setq cache (dfun-info-cache dfun-info)) + (if (consp nindex) + (caching) + (do-fill #'n-n))))))))))) (defun checking-miss (generic-function args dfun-info) (let ((oemf (dfun-info-function dfun-info)) - (cache (dfun-info-cache dfun-info))) + (cache (dfun-info-cache dfun-info))) (dfun-miss (generic-function args wrappers invalidp nemf) (cond (invalidp) - ((eq oemf nemf) - (let ((ncache (fill-cache cache wrappers nil))) - (unless (eq ncache cache) - (dfun-update generic-function #'make-checking-dfun - nemf ncache)))) - (t - (dfun-update generic-function #'make-caching-dfun)))))) + ((eq oemf nemf) + (let ((ncache (fill-cache cache wrappers nil))) + (unless (eq ncache cache) + (dfun-update generic-function #'make-checking-dfun + nemf ncache)))) + (t + (dfun-update generic-function #'make-caching-dfun)))))) (defun caching-miss (generic-function args dfun-info) (let ((ocache (dfun-info-cache dfun-info))) (dfun-miss (generic-function args wrappers invalidp emf nil nil t) (cond (invalidp) - (t - (let ((ncache (fill-cache ocache wrappers emf))) - (unless (eq ncache ocache) - (dfun-update generic-function - #'make-caching-dfun ncache)))))))) + (t + (let ((ncache (fill-cache ocache wrappers emf))) + (unless (eq ncache ocache) + (dfun-update generic-function + #'make-caching-dfun ncache)))))))) (defun constant-value-miss (generic-function args dfun-info) (let ((ocache (dfun-info-cache dfun-info))) (dfun-miss (generic-function args wrappers invalidp emf nil nil t) (unless invalidp - (let* ((function - (typecase emf - (fast-method-call (fast-method-call-function emf)) - (method-call (method-call-function emf)))) - (value (let ((val (method-function-get - function :constant-value '.not-found.))) - (aver (not (eq val '.not-found.))) - val)) - (ncache (fill-cache ocache wrappers value))) - (unless (eq ncache ocache) - (dfun-update generic-function - #'make-constant-value-dfun ncache))))))) + (let* ((function + (typecase emf + (fast-method-call (fast-method-call-function emf)) + (method-call (method-call-function emf)))) + (value (let ((val (method-function-get + function :constant-value '.not-found.))) + (aver (not (eq val '.not-found.))) + val)) + (ncache (fill-cache ocache wrappers value))) + (unless (eq ncache ocache) + (dfun-update generic-function + #'make-constant-value-dfun ncache))))))) ;;; Given a generic function and a set of arguments to that generic ;;; function, return a mess of values. ;;; ;;; The compiled effective method function for this set of -;;; arguments. +;;; arguments. ;;; ;;; Sorted list of applicable methods. ;;; ;;; Is a single wrapper if the generic function has only -;;; one key, that is arg-info-nkeys of the arg-info is 1. -;;; Otherwise a list of the wrappers of the specialized -;;; arguments to the generic function. +;;; one key, that is arg-info-nkeys of the arg-info is 1. +;;; Otherwise a list of the wrappers of the specialized +;;; arguments to the generic function. ;;; -;;; Note that all these wrappers are valid. This function -;;; does invalid wrapper traps when it finds an invalid -;;; wrapper and then returns the new, valid wrapper. +;;; Note that all these wrappers are valid. This function +;;; does invalid wrapper traps when it finds an invalid +;;; wrapper and then returns the new, valid wrapper. ;;; ;;; True if any of the specialized arguments had an invalid -;;; wrapper, false otherwise. +;;; wrapper, false otherwise. ;;; ;;; READER or WRITER when the only method that would be run -;;; is a standard reader or writer method. To be specific, -;;; the value is READER when the method combination is eq to -;;; *standard-method-combination*; there are no applicable -;;; :before, :after or :around methods; and the most specific -;;; primary method is a standard reader method. +;;; is a standard reader or writer method. To be specific, +;;; the value is READER when the method combination is eq to +;;; *standard-method-combination*; there are no applicable +;;; :before, :after or :around methods; and the most specific +;;; primary method is a standard reader method. ;;; ;;; If is READER or WRITER, and the slot accessed is -;;; an :instance slot, this is the index number of that slot -;;; in the object argument. +;;; an :instance slot, this is the index number of that slot +;;; in the object argument. (defvar *cache-miss-values-stack* ()) (defun cache-miss-values (gf args state) @@ -1132,29 +1145,29 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (if (and classes (equal classes (cdr (assq gf *cache-miss-values-stack*)))) (break-vicious-metacircle gf classes arg-info) (let ((*cache-miss-values-stack* - (acons gf classes *cache-miss-values-stack*)) - (cam-std-p (or (null arg-info) - (gf-info-c-a-m-emf-std-p arg-info)))) - (multiple-value-bind (methods all-applicable-and-sorted-p) - (if cam-std-p - (compute-applicable-methods-using-types gf types) - (compute-applicable-methods-using-classes gf classes)) - + (acons gf classes *cache-miss-values-stack*)) + (cam-std-p (or (null arg-info) + (gf-info-c-a-m-emf-std-p arg-info)))) + (multiple-value-bind (methods all-applicable-and-sorted-p) + (if cam-std-p + (compute-applicable-methods-using-types gf types) + (compute-applicable-methods-using-classes gf classes)) + (let* ((for-accessor-p (eq state 'accessor)) - (for-cache-p (or (eq state 'caching) (eq state 'accessor))) - (emf (if (or cam-std-p all-applicable-and-sorted-p) - (let ((generator - (get-secondary-dispatch-function1 - gf methods types nil (and for-cache-p wrappers) - all-applicable-and-sorted-p))) - (make-callable gf methods generator - nil (and for-cache-p wrappers))) - (default-secondary-dispatch-function gf)))) + (for-cache-p (or (eq state 'caching) (eq state 'accessor))) + (emf (if (or cam-std-p all-applicable-and-sorted-p) + (let ((generator + (get-secondary-dispatch-function1 + gf methods types nil (and for-cache-p wrappers) + all-applicable-and-sorted-p))) + (make-callable gf methods generator + nil (and for-cache-p wrappers))) + (default-secondary-dispatch-function gf)))) (multiple-value-bind (index accessor-type) - (and for-accessor-p all-applicable-and-sorted-p methods - (accessor-values gf arg-info classes methods)) + (and for-accessor-p all-applicable-and-sorted-p methods + (accessor-values gf arg-info classes methods)) (values (if (integerp index) index emf) - methods accessor-type index))))))) + methods accessor-type index))))))) ;;; Try to break a vicious circle while computing a cache miss. ;;; GF is the generic function, CLASSES are the classes of actual @@ -1169,23 +1182,23 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun break-vicious-metacircle (gf classes arg-info) (when (typep gf 'standard-generic-function) (multiple-value-bind (class slotd accessor-type) - (accesses-standard-class-slot-p gf) + (accesses-standard-class-slot-p gf) (when class - (let ((method (find-standard-class-accessor-method - gf class accessor-type)) - (index (standard-slot-value/eslotd slotd 'location)) - (type (gf-info-simple-accessor-type arg-info))) - (when (and method - (subtypep (ecase accessor-type - ((reader) (car classes)) - ((writer) (cadr classes))) - class)) - (return-from break-vicious-metacircle - (values index (list method) type index))))))) + (let ((method (find-standard-class-accessor-method + gf class accessor-type)) + (index (standard-slot-value/eslotd slotd 'location)) + (type (gf-info-simple-accessor-type arg-info))) + (when (and method + (subtypep (ecase accessor-type + ((reader) (car classes)) + ((writer) (cadr classes))) + class)) + (return-from break-vicious-metacircle + (values index (list method) type index))))))) (error "~@" - gf classes)) + effective method of ~s for arguments of types ~s uses ~ + the effective method being computed.~@:>" + gf classes)) ;;; Return (CLASS SLOTD ACCESSOR-TYPE) if some method of generic ;;; function GF accesses a slot of some class in *STANDARD-CLASSES*. @@ -1194,297 +1207,303 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;;; READER or WRITER describing the slot access. (defun accesses-standard-class-slot-p (gf) (flet ((standard-class-slot-access (gf class) - (loop with gf-name = (standard-slot-value/gf gf 'name) - for slotd in (standard-slot-value/class class 'slots) - ;; FIXME: where does BOUNDP fit in here? Is it - ;; relevant? - as readers = (standard-slot-value/eslotd slotd 'readers) - as writers = (standard-slot-value/eslotd slotd 'writers) - if (member gf-name readers :test #'equal) - return (values slotd 'reader) - else if (member gf-name writers :test #'equal) - return (values slotd 'writer)))) + (loop with gf-name = (standard-slot-value/gf gf 'name) + for slotd in (standard-slot-value/class class 'slots) + ;; FIXME: where does BOUNDP fit in here? Is it + ;; relevant? + as readers = (standard-slot-value/eslotd slotd 'readers) + as writers = (standard-slot-value/eslotd slotd 'writers) + if (member gf-name readers :test #'equal) + return (values slotd 'reader) + else if (member gf-name writers :test #'equal) + return (values slotd 'writer)))) (dolist (class-name *standard-classes*) (let ((class (find-class class-name))) - (multiple-value-bind (slotd accessor-type) - (standard-class-slot-access gf class) - (when slotd - (return (values class slotd accessor-type)))))))) + (multiple-value-bind (slotd accessor-type) + (standard-class-slot-access gf class) + (when slotd + (return (values class slotd accessor-type)))))))) ;;; Find a slot reader/writer method among the methods of generic ;;; function GF which reads/writes instances of class CLASS. ;;; TYPE is one of the symbols READER or WRITER. (defun find-standard-class-accessor-method (gf class type) (let ((cpl (standard-slot-value/class class 'class-precedence-list)) - (found-specializer *the-class-t*) - (found-method nil)) + (found-specializer *the-class-t*) + (found-method nil)) (dolist (method (standard-slot-value/gf gf 'methods) found-method) (let ((specializers (standard-slot-value/method method 'specializers)) - (qualifiers (plist-value method 'qualifiers))) - (when (and (null qualifiers) - (let ((subcpl (member (ecase type - (reader (car specializers)) - (writer (cadr specializers))) - cpl))) - (and subcpl (member found-specializer subcpl)))) - (setf found-specializer (ecase type - (reader (car specializers)) - (writer (cadr specializers)))) - (setf found-method method)))))) + (qualifiers (plist-value method 'qualifiers))) + (when (and (null qualifiers) + (let ((subcpl (member (ecase type + (reader (car specializers)) + (writer (cadr specializers))) + cpl))) + (and subcpl (member found-specializer subcpl)))) + (setf found-specializer (ecase type + (reader (car specializers)) + (writer (cadr specializers)))) + (setf found-method method)))))) (defun accessor-values (gf arg-info classes methods) (declare (ignore gf)) (let* ((accessor-type (gf-info-simple-accessor-type arg-info)) - (accessor-class (case accessor-type - ((reader boundp) (car classes)) - (writer (cadr classes))))) + (accessor-class (case accessor-type + ((reader boundp) (car classes)) + (writer (cadr classes))))) (accessor-values-internal accessor-type accessor-class methods))) (defun accessor-values1 (gf accessor-type accessor-class) (let* ((type `(class-eq ,accessor-class)) - (types (ecase accessor-type - ((reader boundp) `(,type)) - (writer `(t ,type)))) - (methods (compute-applicable-methods-using-types gf types))) + (types (ecase accessor-type + ((reader boundp) `(,type)) + (writer `(t ,type)))) + (methods (compute-applicable-methods-using-types gf types))) (accessor-values-internal accessor-type accessor-class methods))) (defun accessor-values-internal (accessor-type accessor-class methods) (dolist (meth methods) (when (if (consp meth) - (early-method-qualifiers meth) - (method-qualifiers meth)) + (early-method-qualifiers meth) + (method-qualifiers meth)) (return-from accessor-values-internal (values nil nil)))) (let* ((meth (car methods)) - (early-p (not (eq *boot-state* 'complete))) - (slot-name (when accessor-class - (if (consp meth) - (and (early-method-standard-accessor-p meth) - (early-method-standard-accessor-slot-name meth)) - (and (member *the-class-std-object* - (if early-p - (early-class-precedence-list - accessor-class) - (class-precedence-list - accessor-class))) - (if early-p - (not (eq *the-class-standard-method* - (early-method-class meth))) - (standard-accessor-method-p meth)) - (if early-p - (early-accessor-method-slot-name meth) - (accessor-method-slot-name meth)))))) - (slotd (and accessor-class - (if early-p - (dolist (slot (early-class-slotds accessor-class) nil) - (when (eql slot-name - (early-slot-definition-name slot)) - (return slot))) - (find-slot-definition accessor-class slot-name))))) + (early-p (not (eq *boot-state* 'complete))) + (slot-name (when accessor-class + (if (consp meth) + (and (early-method-standard-accessor-p meth) + (early-method-standard-accessor-slot-name meth)) + (and (member *the-class-standard-object* + (if early-p + (early-class-precedence-list + accessor-class) + (class-precedence-list + accessor-class))) + (if early-p + (not (eq *the-class-standard-method* + (early-method-class meth))) + (standard-accessor-method-p meth)) + (if early-p + (early-accessor-method-slot-name meth) + (accessor-method-slot-name meth)))))) + (slotd (and accessor-class + (if early-p + (dolist (slot (early-class-slotds accessor-class) nil) + (when (eql slot-name + (early-slot-definition-name slot)) + (return slot))) + (find-slot-definition accessor-class slot-name))))) (when (and slotd - (or early-p - (slot-accessor-std-p slotd accessor-type))) + (or early-p + (slot-accessor-std-p slotd accessor-type)) + (or early-p + (eq (slot-definition-type slotd) t))) (values (if early-p - (early-slot-definition-location slotd) - (slot-definition-location slotd)) - accessor-type)))) + (early-slot-definition-location slotd) + (slot-definition-location slotd)) + accessor-type)))) (defun make-accessor-table (gf type &optional table) (unless table (setq table (make-hash-table :test 'eq))) (let ((methods (if (early-gf-p gf) - (early-gf-methods gf) - (generic-function-methods gf))) - (all-index nil) - (no-class-slots-p t) - (early-p (not (eq *boot-state* 'complete))) - first second (size 0)) + (early-gf-methods gf) + (generic-function-methods gf))) + (all-index nil) + (no-class-slots-p t) + (early-p (not (eq *boot-state* 'complete))) + first second (size 0)) (declare (fixnum size)) ;; class -> {(specl slotd)} (dolist (method methods) (let* ((specializers (if (consp method) - (early-method-specializers method t) - (method-specializers method))) - (specl (ecase type - ((reader boundp) (car specializers)) - (writer (cadr specializers)))) - (specl-cpl (if early-p - (early-class-precedence-list specl) - (and (class-finalized-p specl) - (class-precedence-list specl)))) - (so-p (member *the-class-std-object* specl-cpl)) - (slot-name (if (consp method) - (and (early-method-standard-accessor-p method) - (early-method-standard-accessor-slot-name - method)) - (accessor-method-slot-name method)))) - (when (or (null specl-cpl) - (member *the-class-structure-object* specl-cpl)) - (return-from make-accessor-table nil)) - (maphash (lambda (class slotd) - (let ((cpl (if early-p - (early-class-precedence-list class) - (class-precedence-list class)))) - (when (memq specl cpl) - (unless (and (or so-p - (member *the-class-std-object* cpl)) - (or early-p - (slot-accessor-std-p slotd type))) - (return-from make-accessor-table nil)) - (push (cons specl slotd) (gethash class table))))) - (gethash slot-name *name->class->slotd-table*)))) + (early-method-specializers method t) + (method-specializers method))) + (specl (ecase type + ((reader boundp) (car specializers)) + (writer (cadr specializers)))) + (specl-cpl (if early-p + (early-class-precedence-list specl) + (and (class-finalized-p specl) + (class-precedence-list specl)))) + (so-p (member *the-class-standard-object* specl-cpl)) + (slot-name (if (consp method) + (and (early-method-standard-accessor-p method) + (early-method-standard-accessor-slot-name + method)) + (accessor-method-slot-name method)))) + (when (or (null specl-cpl) + (member *the-class-structure-object* specl-cpl)) + (return-from make-accessor-table nil)) + (maphash (lambda (class slotd) + (let ((cpl (if early-p + (early-class-precedence-list class) + (class-precedence-list class)))) + (when (memq specl cpl) + (unless (and (or so-p + (member *the-class-standard-object* + cpl)) + (or early-p + (slot-accessor-std-p slotd type))) + (return-from make-accessor-table nil)) + (push (cons specl slotd) (gethash class table))))) + (gethash slot-name *name->class->slotd-table*)))) (maphash (lambda (class specl+slotd-list) - (dolist (sclass (if early-p - (early-class-precedence-list class) - (class-precedence-list class)) - (error "This can't happen.")) - (let ((a (assq sclass specl+slotd-list))) - (when a - (let* ((slotd (cdr a)) - (index (if early-p - (early-slot-definition-location slotd) - (slot-definition-location slotd)))) - (unless index (return-from make-accessor-table nil)) - (setf (gethash class table) index) - (when (consp index) (setq no-class-slots-p nil)) - (setq all-index (if (or (null all-index) - (eql all-index index)) - index t)) - (incf size) - (cond ((= size 1) (setq first class)) - ((= size 2) (setq second class))) - (return nil)))))) - table) + (dolist (sclass (if early-p + (early-class-precedence-list class) + (class-precedence-list class)) + (error "This can't happen.")) + (let ((a (assq sclass specl+slotd-list))) + (when a + (let* ((slotd (cdr a)) + (index (if early-p + (early-slot-definition-location slotd) + (slot-definition-location slotd)))) + (unless index (return-from make-accessor-table nil)) + (setf (gethash class table) index) + (when (consp index) (setq no-class-slots-p nil)) + (setq all-index (if (or (null all-index) + (eql all-index index)) + index t)) + (incf size) + (cond ((= size 1) (setq first class)) + ((= size 2) (setq second class))) + (return nil)))))) + table) (values table all-index first second size no-class-slots-p))) (defun compute-applicable-methods-using-types (generic-function types) (let ((definite-p t) (possibly-applicable-methods nil)) (dolist (method (if (early-gf-p generic-function) - (early-gf-methods generic-function) - (generic-function-methods generic-function))) + (early-gf-methods generic-function) + (if (eq (class-of generic-function) + *the-class-standard-generic-function*) + ;; KLUDGE: see comment by GET-GENERIC-FUN-INFO + (clos-slots-ref (fsc-instance-slots generic-function) *sgf-methods-index*) + (generic-function-methods generic-function)))) (let ((specls (if (consp method) - (early-method-specializers method t) - (method-specializers method))) - (types types) - (possibly-applicable-p t) (applicable-p t)) - (dolist (specl specls) - (multiple-value-bind (specl-applicable-p specl-possibly-applicable-p) - (specializer-applicable-using-type-p specl (pop types)) - (unless specl-applicable-p - (setq applicable-p nil)) - (unless specl-possibly-applicable-p - (setq possibly-applicable-p nil) - (return nil)))) - (when possibly-applicable-p - (unless applicable-p (setq definite-p nil)) - (push method possibly-applicable-methods)))) - (let ((precedence (arg-info-precedence (if (early-gf-p generic-function) - (early-gf-arg-info - generic-function) - (gf-arg-info - generic-function))))) - (values (sort-applicable-methods precedence - (nreverse possibly-applicable-methods) - types) - definite-p)))) + (early-method-specializers method t) + (method-specializers method))) + (types types) + (possibly-applicable-p t) (applicable-p t)) + (dolist (specl specls) + (multiple-value-bind (specl-applicable-p specl-possibly-applicable-p) + (specializer-applicable-using-type-p specl (pop types)) + (unless specl-applicable-p + (setq applicable-p nil)) + (unless specl-possibly-applicable-p + (setq possibly-applicable-p nil) + (return nil)))) + (when possibly-applicable-p + (unless applicable-p (setq definite-p nil)) + (push method possibly-applicable-methods)))) + (multiple-value-bind (nreq applyp metatypes nkeys arg-info) + (get-generic-fun-info generic-function) + (declare (ignore nreq applyp metatypes nkeys)) + (let* ((precedence (arg-info-precedence arg-info))) + (values (sort-applicable-methods precedence + (nreverse possibly-applicable-methods) + types) + definite-p))))) (defun sort-applicable-methods (precedence methods types) (sort-methods methods - precedence - (lambda (class1 class2 index) - (let* ((class (type-class (nth index types))) - (cpl (if (eq *boot-state* 'complete) - (class-precedence-list class) - (early-class-precedence-list class)))) - (if (memq class2 (memq class1 cpl)) - class1 class2))))) + precedence + (lambda (class1 class2 index) + (let* ((class (type-class (nth index types))) + (cpl (if (eq *boot-state* 'complete) + (class-precedence-list class) + (early-class-precedence-list class)))) + (if (memq class2 (memq class1 cpl)) + class1 class2))))) (defun sort-methods (methods precedence compare-classes-function) (flet ((sorter (method1 method2) - (dolist (index precedence) - (let* ((specl1 (nth index (if (listp method1) - (early-method-specializers method1 - t) - (method-specializers method1)))) - (specl2 (nth index (if (listp method2) - (early-method-specializers method2 - t) - (method-specializers method2)))) - (order (order-specializers - specl1 specl2 index compare-classes-function))) - (when order - (return-from sorter (eq order specl1))))))) + (dolist (index precedence) + (let* ((specl1 (nth index (if (listp method1) + (early-method-specializers method1 + t) + (method-specializers method1)))) + (specl2 (nth index (if (listp method2) + (early-method-specializers method2 + t) + (method-specializers method2)))) + (order (order-specializers + specl1 specl2 index compare-classes-function))) + (when order + (return-from sorter (eq order specl1))))))) (stable-sort methods #'sorter))) (defun order-specializers (specl1 specl2 index compare-classes-function) (let ((type1 (if (eq *boot-state* 'complete) - (specializer-type specl1) - (!bootstrap-get-slot 'specializer specl1 'type))) - (type2 (if (eq *boot-state* 'complete) - (specializer-type specl2) - (!bootstrap-get-slot 'specializer specl2 'type)))) + (specializer-type specl1) + (!bootstrap-get-slot 'specializer specl1 'type))) + (type2 (if (eq *boot-state* 'complete) + (specializer-type specl2) + (!bootstrap-get-slot 'specializer specl2 'type)))) (cond ((eq specl1 specl2) - nil) - ((atom type1) - specl2) - ((atom type2) - specl1) - (t - (case (car type1) - (class (case (car type2) - (class (funcall compare-classes-function - specl1 specl2 index)) - (t specl2))) - (prototype (case (car type2) - (class (funcall compare-classes-function - specl1 specl2 index)) - (t specl2))) - (class-eq (case (car type2) - (eql specl2) - (class-eq nil) - (class type1))) - (eql (case (car type2) - (eql nil) - (t specl1)))))))) + nil) + ((atom type1) + specl2) + ((atom type2) + specl1) + (t + (case (car type1) + (class (case (car type2) + (class (funcall compare-classes-function + specl1 specl2 index)) + (t specl2))) + (prototype (case (car type2) + (class (funcall compare-classes-function + specl1 specl2 index)) + (t specl2))) + (class-eq (case (car type2) + (eql specl2) + (class-eq nil) + (class type1))) + (eql (case (car type2) + (eql nil) + (t specl1)))))))) (defun map-all-orders (methods precedence function) (let ((choices nil)) (flet ((compare-classes-function (class1 class2 index) - (declare (ignore index)) - (let ((choice nil)) - (dolist (c choices nil) - (when (or (and (eq (first c) class1) - (eq (second c) class2)) - (and (eq (first c) class2) - (eq (second c) class1))) - (return (setq choice c)))) - (unless choice - (setq choice - (if (class-might-precede-p class1 class2) - (if (class-might-precede-p class2 class1) - (list class1 class2 nil t) - (list class1 class2 t)) - (if (class-might-precede-p class2 class1) - (list class2 class1 t) - (let ((name1 (class-name class1)) - (name2 (class-name class2))) - (if (and name1 - name2 - (symbolp name1) - (symbolp name2) - (string< (symbol-name name1) - (symbol-name name2))) - (list class1 class2 t) - (list class2 class1 t)))))) - (push choice choices)) - (car choice)))) + (declare (ignore index)) + (let ((choice nil)) + (dolist (c choices nil) + (when (or (and (eq (first c) class1) + (eq (second c) class2)) + (and (eq (first c) class2) + (eq (second c) class1))) + (return (setq choice c)))) + (unless choice + (setq choice + (if (class-might-precede-p class1 class2) + (if (class-might-precede-p class2 class1) + (list class1 class2 nil t) + (list class1 class2 t)) + (if (class-might-precede-p class2 class1) + (list class2 class1 t) + (let ((name1 (class-name class1)) + (name2 (class-name class2))) + (if (and name1 + name2 + (symbolp name1) + (symbolp name2) + (string< (symbol-name name1) + (symbol-name name2))) + (list class1 class2 t) + (list class2 class1 t)))))) + (push choice choices)) + (car choice)))) (loop (funcall function - (sort-methods methods - precedence - #'compare-classes-function)) - (unless (dolist (c choices nil) - (unless (third c) - (rotatef (car c) (cadr c)) - (return (setf (third c) t)))) - (return nil)))))) + (sort-methods methods + precedence + #'compare-classes-function)) + (unless (dolist (c choices nil) + (unless (third c) + (rotatef (car c) (cadr c)) + (return (setf (third c) t)))) + (return nil)))))) ;;; CMUCL comment: used only in map-all-orders (defun class-might-precede-p (class1 class2) @@ -1495,9 +1514,9 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun compute-precedence (lambda-list nreq argument-precedence-order) (if (null argument-precedence-order) (let ((list nil)) - (dotimes-fixnum (i nreq list) (push (- (1- nreq) i) list))) + (dotimes-fixnum (i nreq list) (push (- (1- nreq) i) list))) (mapcar (lambda (x) (position x lambda-list)) - argument-precedence-order))) + argument-precedence-order))) (defun cpl-or-nil (class) (if (eq *boot-state* 'complete) @@ -1520,43 +1539,43 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun saut-and (specl type) (let ((applicable nil) - (possibly-applicable t)) + (possibly-applicable t)) (dolist (type (cdr type)) (multiple-value-bind (appl poss-appl) - (specializer-applicable-using-type-p specl type) - (when appl (return (setq applicable t))) - (unless poss-appl (return (setq possibly-applicable nil))))) + (specializer-applicable-using-type-p specl type) + (when appl (return (setq applicable t))) + (unless poss-appl (return (setq possibly-applicable nil))))) (values applicable possibly-applicable))) (defun saut-not (specl type) (let ((ntype (cadr type))) (values nil - (case (car ntype) - (class (saut-not-class specl ntype)) - (class-eq (saut-not-class-eq specl ntype)) - (prototype (saut-not-prototype specl ntype)) - (eql (saut-not-eql specl ntype)) - (t (error "~S cannot handle the second argument ~S" - 'specializer-applicable-using-type-p type)))))) + (case (car ntype) + (class (saut-not-class specl ntype)) + (class-eq (saut-not-class-eq specl ntype)) + (prototype (saut-not-prototype specl ntype)) + (eql (saut-not-eql specl ntype)) + (t (error "~S cannot handle the second argument ~S" + 'specializer-applicable-using-type-p type)))))) (defun saut-not-class (specl ntype) (let* ((class (type-class specl)) - (cpl (cpl-or-nil class))) + (cpl (cpl-or-nil class))) (not (memq (cadr ntype) cpl)))) (defun saut-not-prototype (specl ntype) (let* ((class (case (car specl) - (eql (class-of (cadr specl))) - (class-eq (cadr specl)) - (prototype (cadr specl)) - (class (cadr specl)))) - (cpl (cpl-or-nil class))) + (eql (class-of (cadr specl))) + (class-eq (cadr specl)) + (prototype (cadr specl)) + (class (cadr specl)))) + (cpl (cpl-or-nil class))) (not (memq (cadr ntype) cpl)))) (defun saut-not-class-eq (specl ntype) (let ((class (case (car specl) - (eql (class-of (cadr specl))) - (class-eq (cadr specl))))) + (eql (class-of (cadr specl))) + (class-eq (cadr specl))))) (not (eq class (cadr ntype))))) (defun saut-not-eql (specl ntype) @@ -1567,38 +1586,38 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun class-applicable-using-class-p (specl type) (let ((pred (memq specl (cpl-or-nil type)))) (values pred - (or pred - (if (not *in-precompute-effective-methods-p*) - ;; classes might get common subclass - (superclasses-compatible-p specl type) - ;; worry only about existing classes - (classes-have-common-subclass-p specl type)))))) + (or pred + (if (not *in-precompute-effective-methods-p*) + ;; classes might get common subclass + (superclasses-compatible-p specl type) + ;; worry only about existing classes + (classes-have-common-subclass-p specl type)))))) (defun classes-have-common-subclass-p (class1 class2) (or (eq class1 class2) (let ((class1-subs (class-direct-subclasses class1))) - (or (memq class2 class1-subs) - (dolist (class1-sub class1-subs nil) - (when (classes-have-common-subclass-p class1-sub class2) - (return t))))))) + (or (memq class2 class1-subs) + (dolist (class1-sub class1-subs nil) + (when (classes-have-common-subclass-p class1-sub class2) + (return t))))))) (defun saut-class (specl type) (case (car specl) (class (class-applicable-using-class-p (cadr specl) (cadr type))) (t (values nil (let ((class (type-class specl))) - (memq (cadr type) - (cpl-or-nil class))))))) + (memq (cadr type) + (cpl-or-nil class))))))) (defun saut-class-eq (specl type) (if (eq (car specl) 'eql) (values nil (eq (class-of (cadr specl)) (cadr type))) (let ((pred (case (car specl) - (class-eq - (eq (cadr specl) (cadr type))) - (class - (or (eq (cadr specl) (cadr type)) - (memq (cadr specl) (cpl-or-nil (cadr type)))))))) - (values pred pred)))) + (class-eq + (eq (cadr specl) (cadr type))) + (class + (or (eq (cadr specl) (cadr type)) + (memq (cadr specl) (cpl-or-nil (cadr type)))))))) + (values pred pred)))) (defun saut-prototype (specl type) (declare (ignore specl type)) @@ -1606,11 +1625,11 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun saut-eql (specl type) (let ((pred (case (car specl) - (eql (eql (cadr specl) (cadr type))) - (class-eq (eq (cadr specl) (class-of (cadr type)))) - (class (memq (cadr specl) - (let ((class (class-of (cadr type)))) - (cpl-or-nil class))))))) + (eql (eql (cadr specl) (cadr type))) + (class-eq (eq (cadr specl) (class-of (cadr type)))) + (class (memq (cadr specl) + (let ((class (class-of (cadr type)))) + (cpl-or-nil class))))))) (values pred pred))) (defun specializer-applicable-using-type-p (specl type) @@ -1622,28 +1641,28 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (if (or (atom type) (eq (car type) t)) (values nil t) (case (car type) - (and (saut-and specl type)) - (not (saut-not specl type)) - (class (saut-class specl type)) - (prototype (saut-prototype specl type)) - (class-eq (saut-class-eq specl type)) - (eql (saut-eql specl type)) - (t (error "~S cannot handle the second argument ~S." - 'specializer-applicable-using-type-p - type))))) + (and (saut-and specl type)) + (not (saut-not specl type)) + (class (saut-class specl type)) + (prototype (saut-prototype specl type)) + (class-eq (saut-class-eq specl type)) + (eql (saut-eql specl type)) + (t (error "~S cannot handle the second argument ~S." + 'specializer-applicable-using-type-p + type))))) (defun map-all-classes (function &optional (root t)) (let ((braid-p (or (eq *boot-state* 'braid) - (eq *boot-state* 'complete)))) + (eq *boot-state* 'complete)))) (labels ((do-class (class) - (mapc #'do-class - (if braid-p - (class-direct-subclasses class) - (early-class-direct-subclasses class))) - (funcall function class))) + (mapc #'do-class + (if braid-p + (class-direct-subclasses class) + (early-class-direct-subclasses class))) + (funcall function class))) (do-class (if (symbolp root) - (find-class root) - root))))) + (find-class root) + root))))) (defvar *effective-method-cache* (make-hash-table :test 'eq)) @@ -1652,71 +1671,71 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (remhash method *effective-method-cache*))) (defun get-secondary-dispatch-function (gf methods types - &optional method-alist wrappers) + &optional method-alist wrappers) (let ((generator - (get-secondary-dispatch-function1 - gf methods types (not (null method-alist)) (not (null wrappers)) - (not (methods-contain-eql-specializer-p methods))))) + (get-secondary-dispatch-function1 + gf methods types (not (null method-alist)) (not (null wrappers)) + (not (methods-contain-eql-specializer-p methods))))) (make-callable gf methods generator method-alist wrappers))) (defun get-secondary-dispatch-function1 (gf methods types method-alist-p - wrappers-p - &optional - all-applicable-p - (all-sorted-p t) - function-p) + wrappers-p + &optional + all-applicable-p + (all-sorted-p t) + function-p) (if (null methods) (if function-p - (lambda (method-alist wrappers) - (declare (ignore method-alist wrappers)) - #'(instance-lambda (&rest args) - (apply #'no-applicable-method gf args))) - (lambda (method-alist wrappers) - (declare (ignore method-alist wrappers)) - (lambda (&rest args) - (apply #'no-applicable-method gf args)))) + (lambda (method-alist wrappers) + (declare (ignore method-alist wrappers)) + #'(lambda (&rest args) + (apply #'no-applicable-method gf args))) + (lambda (method-alist wrappers) + (declare (ignore method-alist wrappers)) + (lambda (&rest args) + (apply #'no-applicable-method gf args)))) (let* ((key (car methods)) - (ht-value (or (gethash key *effective-method-cache*) - (setf (gethash key *effective-method-cache*) - (cons nil nil))))) - (if (and (null (cdr methods)) all-applicable-p ; the most common case - (null method-alist-p) wrappers-p (not function-p)) - (or (car ht-value) - (setf (car ht-value) - (get-secondary-dispatch-function2 - gf methods types method-alist-p wrappers-p - all-applicable-p all-sorted-p function-p))) - (let ((akey (list methods - (if all-applicable-p 'all-applicable types) - method-alist-p wrappers-p function-p))) - (or (cdr (assoc akey (cdr ht-value) :test #'equal)) - (let ((value (get-secondary-dispatch-function2 - gf methods types method-alist-p wrappers-p - all-applicable-p all-sorted-p function-p))) - (push (cons akey value) (cdr ht-value)) - value))))))) + (ht-value (or (gethash key *effective-method-cache*) + (setf (gethash key *effective-method-cache*) + (cons nil nil))))) + (if (and (null (cdr methods)) all-applicable-p ; the most common case + (null method-alist-p) wrappers-p (not function-p)) + (or (car ht-value) + (setf (car ht-value) + (get-secondary-dispatch-function2 + gf methods types method-alist-p wrappers-p + all-applicable-p all-sorted-p function-p))) + (let ((akey (list methods + (if all-applicable-p 'all-applicable types) + method-alist-p wrappers-p function-p))) + (or (cdr (assoc akey (cdr ht-value) :test #'equal)) + (let ((value (get-secondary-dispatch-function2 + gf methods types method-alist-p wrappers-p + all-applicable-p all-sorted-p function-p))) + (push (cons akey value) (cdr ht-value)) + value))))))) (defun get-secondary-dispatch-function2 (gf methods types method-alist-p - wrappers-p all-applicable-p - all-sorted-p function-p) + wrappers-p all-applicable-p + all-sorted-p function-p) (if (and all-applicable-p all-sorted-p (not function-p)) (if (eq *boot-state* 'complete) - (let* ((combin (generic-function-method-combination gf)) - (effective (compute-effective-method gf combin methods))) - (make-effective-method-function1 gf effective method-alist-p - wrappers-p)) - (let ((effective (standard-compute-effective-method gf nil methods))) - (make-effective-method-function1 gf effective method-alist-p - wrappers-p))) + (let* ((combin (generic-function-method-combination gf)) + (effective (compute-effective-method gf combin methods))) + (make-effective-method-function1 gf effective method-alist-p + wrappers-p)) + (let ((effective (standard-compute-effective-method gf nil methods))) + (make-effective-method-function1 gf effective method-alist-p + wrappers-p))) (let ((net (generate-discrimination-net - gf methods types all-sorted-p))) - (compute-secondary-dispatch-function1 gf net function-p)))) + gf methods types all-sorted-p))) + (compute-secondary-dispatch-function1 gf net function-p)))) (defun get-effective-method-function (gf methods - &optional method-alist wrappers) + &optional method-alist wrappers) (let ((generator - (get-secondary-dispatch-function1 - gf methods nil (not (null method-alist)) (not (null wrappers)) t))) + (get-secondary-dispatch-function1 + gf methods nil (not (null method-alist)) (not (null wrappers)) t))) (make-callable gf methods generator method-alist wrappers))) (defun get-effective-method-function1 (gf methods &optional (sorted-p t)) @@ -1725,22 +1744,22 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun methods-contain-eql-specializer-p (methods) (and (eq *boot-state* 'complete) (dolist (method methods nil) - (when (dolist (spec (method-specializers method) nil) - (when (eql-specializer-p spec) (return t))) - (return t))))) + (when (dolist (spec (method-specializers method) nil) + (when (eql-specializer-p spec) (return t))) + (return t))))) (defun update-dfun (generic-function &optional dfun cache info) - (let* ((early-p (early-gf-p generic-function)) - (gf-name (if early-p - (!early-gf-name generic-function) - (generic-function-name generic-function)))) + (let* ((early-p (early-gf-p generic-function))) (set-dfun generic-function dfun cache info) (let ((dfun (if early-p - (or dfun (make-initial-dfun generic-function)) - (compute-discriminating-function generic-function)))) + (or dfun (make-initial-dfun generic-function)) + (compute-discriminating-function generic-function)))) (set-funcallable-instance-function generic-function dfun) - (set-fun-name generic-function gf-name) - dfun))) + (let ((gf-name (if early-p + (!early-gf-name generic-function) + (generic-function-name generic-function)))) + (set-fun-name generic-function gf-name) + dfun)))) (defvar *dfun-count* nil) (defvar *dfun-list* nil) @@ -1753,7 +1772,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 #| (defun list-dfun (gf) (let* ((sym (type-of (gf-dfun-info gf))) - (a (assq sym *dfun-list*))) + (a (assq sym *dfun-list*))) (unless a (push (setq a (list sym)) *dfun-list*)) (push (generic-function-name gf) (cdr a)))) @@ -1765,16 +1784,16 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun list-large-cache (gf) (let* ((sym (type-of (gf-dfun-info gf))) - (cache (gf-dfun-cache gf))) + (cache (gf-dfun-cache gf))) (when cache (let ((size (cache-size cache))) - (when (>= size *minimum-cache-size-to-list*) - (let ((a (assoc size *dfun-list*))) - (unless a - (push (setq a (list size)) *dfun-list*)) - (push (let ((name (generic-function-name gf))) - (if (eq sym 'caching) name (list name sym))) - (cdr a)))))))) + (when (>= size *minimum-cache-size-to-list*) + (let ((a (assoc size *dfun-list*))) + (unless a + (push (setq a (list size)) *dfun-list*)) + (push (let ((name (generic-function-name gf))) + (if (eq sym 'caching) name (list name sym))) + (cdr a)))))))) (defun list-large-caches (&optional (*minimum-cache-size-to-list* 130)) (setq *dfun-list* nil) @@ -1785,33 +1804,33 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun count-dfun (gf) (let* ((sym (type-of (gf-dfun-info gf))) - (cache (gf-dfun-cache gf)) - (a (assq sym *dfun-count*))) + (cache (gf-dfun-cache gf)) + (a (assq sym *dfun-count*))) (unless a (push (setq a (list sym 0 nil)) *dfun-count*)) (incf (cadr a)) (when cache (let* ((size (cache-size cache)) - (b (assoc size (third a)))) - (unless b - (push (setq b (cons size 0)) (third a))) - (incf (cdr b)))))) + (b (assoc size (third a)))) + (unless b + (push (setq b (cons size 0)) (third a))) + (incf (cdr b)))))) (defun count-all-dfuns () (setq *dfun-count* (mapcar (lambda (type) (list type 0 nil)) - '(ONE-CLASS TWO-CLASS DEFAULT-METHOD-ONLY - ONE-INDEX N-N CHECKING CACHING - DISPATCH))) + '(ONE-CLASS TWO-CLASS DEFAULT-METHOD-ONLY + ONE-INDEX N-N CHECKING CACHING + DISPATCH))) (map-all-generic-functions #'count-dfun) (mapc (lambda (type+count+sizes) - (setf (third type+count+sizes) - (sort (third type+count+sizes) #'< :key #'car))) - *dfun-count*) + (setf (third type+count+sizes) + (sort (third type+count+sizes) #'< :key #'car))) + *dfun-count*) (mapc (lambda (type+count+sizes) - (format t "~&There are ~W dfuns of type ~S." - (cadr type+count+sizes) (car type+count+sizes)) - (format t "~% ~S~%" (caddr type+count+sizes))) - *dfun-count*) + (format t "~&There are ~W dfuns of type ~S." + (cadr type+count+sizes) (car type+count+sizes)) + (format t "~% ~S~%" (caddr type+count+sizes))) + *dfun-count*) (values)) |# @@ -1819,7 +1838,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (unless (consp type) (setq type (list type))) (let ((gf-list nil)) (map-all-generic-functions (lambda (gf) - (when (memq (type-of (gf-dfun-info gf)) - type) - (push gf gf-list)))) + (when (memq (type-of (gf-dfun-info gf)) + type) + (push gf gf-list)))) gf-list)) diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index dc7b804b2..d458ce3e2 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -25,39 +25,39 @@ (defun ensure-accessor (type fun-name slot-name) (labels ((slot-missing-fun (slot-name type) - (let* ((method-type (ecase type - (slot-value 'reader-method) - (setf 'writer-method) - (slot-boundp 'boundp-method))) - (initargs - (copy-tree - (ecase type - (slot-value - (make-method-function - (lambda (obj) - (values - (slot-missing (class-of obj) obj slot-name - 'slot-value))))) - (slot-boundp - (make-method-function - (lambda (obj) - (not (not - (slot-missing (class-of obj) obj slot-name - 'slot-boundp)))))) - (setf - (make-method-function - (lambda (val obj) - (slot-missing (class-of obj) obj slot-name - 'setf val) - val))))))) - (setf (getf (getf initargs :plist) :slot-name-lists) - (list (list nil slot-name))) - (setf (getf (getf initargs :plist) :pv-table-symbol) + (let* ((method-type (ecase type + (slot-value 'reader-method) + (setf 'writer-method) + (slot-boundp 'boundp-method))) + (initargs + (copy-tree + (ecase type + (slot-value + (make-method-function + (lambda (obj) + (values + (slot-missing (class-of obj) obj slot-name + 'slot-value))))) + (slot-boundp + (make-method-function + (lambda (obj) + (not (not + (slot-missing (class-of obj) obj slot-name + 'slot-boundp)))))) + (setf + (make-method-function + (lambda (val obj) + (slot-missing (class-of obj) obj slot-name + 'setf val) + val))))))) + (setf (getf (getf initargs :plist) :slot-name-lists) + (list (list nil slot-name))) + (setf (getf (getf initargs :plist) :pv-table-symbol) (gensym)) - (list* :method-spec (list method-type 'slot-object slot-name) + (list* :method-spec (list method-type 'slot-object slot-name) initargs))) - (add-slot-missing-method (gf slot-name type) - (multiple-value-bind (class lambda-list specializers) + (add-slot-missing-method (gf slot-name type) + (multiple-value-bind (class lambda-list specializers) (ecase type (slot-value (values 'standard-reader-method @@ -80,10 +80,10 @@ slot-name))))) (unless (fboundp fun-name) (let ((gf (ensure-generic-function - fun-name - :lambda-list (ecase type - ((reader boundp) '(object)) - (writer '(new-value object)))))) + fun-name + :lambda-list (ecase type + ((reader boundp) '(object)) + (writer '(new-value object)))))) (ecase type (reader (add-slot-missing-method gf slot-name 'slot-value)) (boundp (add-slot-missing-method gf slot-name 'slot-boundp)) @@ -94,9 +94,9 @@ (defmacro accessor-slot-value (object slot-name) (aver (constantp slot-name)) (let* ((slot-name (eval slot-name)) - (reader-name (slot-reader-name slot-name))) + (reader-name (slot-reader-name slot-name))) `(let ((.ignore. (load-time-value - (ensure-accessor 'reader ',reader-name ',slot-name)))) + (ensure-accessor 'reader ',reader-name ',slot-name)))) (declare (ignore .ignore.)) (truly-the (values t &optional) (funcall #',reader-name ,object))))) @@ -106,29 +106,29 @@ (setq object (macroexpand object env)) (setq slot-name (macroexpand slot-name env)) (let* ((slot-name (eval slot-name)) - (bindings (unless (or (constantp new-value) (atom new-value)) - (let ((object-var (gensym))) - (prog1 `((,object-var ,object)) - (setq object object-var))))) - (writer-name (slot-writer-name slot-name)) - (form - `(let ((.ignore. - (load-time-value - (ensure-accessor 'writer ',writer-name ',slot-name))) - (.new-value. ,new-value)) - (declare (ignore .ignore.)) - (funcall #',writer-name .new-value. ,object) - .new-value.))) + (bindings (unless (or (constantp new-value) (atom new-value)) + (let ((object-var (gensym))) + (prog1 `((,object-var ,object)) + (setq object object-var))))) + (writer-name (slot-writer-name slot-name)) + (form + `(let ((.ignore. + (load-time-value + (ensure-accessor 'writer ',writer-name ',slot-name))) + (.new-value. ,new-value)) + (declare (ignore .ignore.)) + (funcall #',writer-name .new-value. ,object) + .new-value.))) (if bindings - `(let ,bindings ,form) - form))) + `(let ,bindings ,form) + form))) (defmacro accessor-slot-boundp (object slot-name) (aver (constantp slot-name)) (let* ((slot-name (eval slot-name)) - (boundp-name (slot-boundp-name slot-name))) + (boundp-name (slot-boundp-name slot-name))) `(let ((.ignore. (load-time-value - (ensure-accessor 'boundp ',boundp-name ',slot-name)))) + (ensure-accessor 'boundp ',boundp-name ',slot-name)))) (declare (ignore .ignore.)) (funcall #',boundp-name ,object)))) @@ -147,20 +147,20 @@ (format s "~@" - (instance-structure-protocol-error-slotd c) - :instance :class - (cond - ((member (instance-structure-protocol-error-fun c) - '(slot-value-using-class slot-boundp-using-class)) - "read") - (t "written")) - (instance-structure-protocol-error-fun c))))) + (instance-structure-protocol-error-slotd c) + :instance :class + (cond + ((member (instance-structure-protocol-error-fun c) + '(slot-value-using-class slot-boundp-using-class)) + "read") + (t "written")) + (instance-structure-protocol-error-fun c))))) (defun instance-structure-protocol-error (slotd fun) (error 'instance-structure-protocol-error - :slotd slotd :fun fun - :references (list `(:amop :generic-function ,fun) - '(:amop :section (5 5 3))))) + :slotd slotd :fun fun + :references (list `(:amop :generic-function ,fun) + '(:amop :section (5 5 3))))) (defun get-optimized-std-accessor-method-function (class slotd name) (cond @@ -176,25 +176,25 @@ (boundp (slot-definition-boundp-function slotd)))) (t (let* ((fsc-p (cond ((standard-class-p class) nil) - ((funcallable-standard-class-p class) t) - ((std-class-p class) - ;; Shouldn't be using the optimized-std-accessors - ;; in this case. - #+nil (format t "* warning: ~S ~S~% ~S~%" - name slotd class) - nil) - (t (error "~S is not a STANDARD-CLASS." class)))) - (slot-name (slot-definition-name slotd)) - (location (slot-definition-location slotd)) - (function (ecase name - (reader #'make-optimized-std-reader-method-function) - (writer #'make-optimized-std-writer-method-function) - (boundp #'make-optimized-std-boundp-method-function))) - ;; KLUDGE: we need this slightly hacky calling convention - ;; for these functions for bootstrapping reasons: see - ;; !BOOTSTRAP-MAKE-SLOT-DEFINITION in braid.lisp. -- CSR, - ;; 2004-07-12 - (value (funcall function fsc-p slotd slot-name location))) + ((funcallable-standard-class-p class) t) + ((std-class-p class) + ;; Shouldn't be using the optimized-std-accessors + ;; in this case. + #+nil (format t "* warning: ~S ~S~% ~S~%" + name slotd class) + nil) + (t (error "~S is not a STANDARD-CLASS." class)))) + (slot-name (slot-definition-name slotd)) + (location (slot-definition-location slotd)) + (function (ecase name + (reader #'make-optimized-std-reader-method-function) + (writer #'make-optimized-std-writer-method-function) + (boundp #'make-optimized-std-boundp-method-function))) + ;; KLUDGE: we need this slightly hacky calling convention + ;; for these functions for bootstrapping reasons: see + ;; !BOOTSTRAP-MAKE-SLOT-DEFINITION in braid.lisp. -- CSR, + ;; 2004-07-12 + (value (funcall function fsc-p slotd slot-name location))) (declare (type function function)) (values value (slot-definition-location slotd)))))) @@ -205,59 +205,82 @@ (etypecase location (fixnum (if fsc-p - (lambda (instance) - (check-obsolete-instance instance) - (let ((value (clos-slots-ref (fsc-instance-slots instance) - location))) - (if (eq value +slot-unbound+) - (values - (slot-unbound (class-of instance) instance slot-name)) - value))) - (lambda (instance) - (check-obsolete-instance instance) - (let ((value (clos-slots-ref (std-instance-slots instance) - location))) - (if (eq value +slot-unbound+) - (values - (slot-unbound (class-of instance) instance slot-name)) - value))))) + (lambda (instance) + (check-obsolete-instance instance) + (let ((value (clos-slots-ref (fsc-instance-slots instance) + location))) + (if (eq value +slot-unbound+) + (values + (slot-unbound (class-of instance) instance slot-name)) + value))) + (lambda (instance) + (check-obsolete-instance instance) + (let ((value (clos-slots-ref (std-instance-slots instance) + location))) + (if (eq value +slot-unbound+) + (values + (slot-unbound (class-of instance) instance slot-name)) + value))))) (cons (lambda (instance) - (check-obsolete-instance instance) - (let ((value (cdr location))) - (if (eq value +slot-unbound+) - (values (slot-unbound (class-of instance) instance slot-name)) - value)))) + (check-obsolete-instance instance) + (let ((value (cdr location))) + (if (eq value +slot-unbound+) + (values (slot-unbound (class-of instance) instance slot-name)) + value)))) (null (lambda (instance) - (instance-structure-protocol-error slotd 'slot-value-using-class)))) + (instance-structure-protocol-error slotd 'slot-value-using-class)))) `(reader ,slot-name))) (defun make-optimized-std-writer-method-function (fsc-p slotd slot-name location) (declare #.*optimize-speed*) - (set-fun-name - (etypecase location - (fixnum (if fsc-p - (lambda (nv instance) - (check-obsolete-instance instance) - (setf (clos-slots-ref (fsc-instance-slots instance) - location) - nv)) - (lambda (nv instance) - (check-obsolete-instance instance) - (setf (clos-slots-ref (std-instance-slots instance) - location) - nv)))) - (cons (lambda (nv instance) - (check-obsolete-instance instance) - (setf (cdr location) nv))) - (null - (lambda (nv instance) - (declare (ignore nv)) - (instance-structure-protocol-error slotd - '(setf slot-value-using-class))))) - `(writer ,slot-name))) + (let ((type (or (not slotd) (slot-definition-type slotd)))) + (set-fun-name + (etypecase location + (fixnum (if fsc-p + (if (eq type t) + (lambda (nv instance) + (check-obsolete-instance instance) + (setf (clos-slots-ref (fsc-instance-slots instance) + location) + nv)) + (lambda (nv instance) + (check-obsolete-instance instance) + (unless (typep nv type) + (error 'type-error :datum nv :expected-type type)) + (setf (clos-slots-ref (fsc-instance-slots instance) + location) + nv))) + (if (eq type t) + (lambda (nv instance) + (check-obsolete-instance instance) + (setf (clos-slots-ref (std-instance-slots instance) + location) + nv)) + (lambda (nv instance) + (check-obsolete-instance instance) + (unless (typep nv type) + (error 'type-error :datum nv :expected-type type)) + (setf (clos-slots-ref (std-instance-slots instance) + location) + nv))))) + (cons (if (eq type t) + (lambda (nv instance) + (check-obsolete-instance instance) + (setf (cdr location) nv)) + (lambda (nv instance) + (check-obsolete-instance instance) + (unless (typep nv type) + (error 'type-error :datum nv :expected-type type)) + (setf (cdr location) nv)))) + (null + (lambda (nv instance) + (declare (ignore nv)) + (instance-structure-protocol-error slotd + '(setf slot-value-using-class))))) + `(writer ,slot-name)))) (defun make-optimized-std-boundp-method-function (fsc-p slotd slot-name location) @@ -265,22 +288,22 @@ (set-fun-name (etypecase location (fixnum (if fsc-p - (lambda (instance) - (check-obsolete-instance instance) - (not (eq (clos-slots-ref (fsc-instance-slots instance) - location) - +slot-unbound+))) - (lambda (instance) - (check-obsolete-instance instance) - (not (eq (clos-slots-ref (std-instance-slots instance) - location) - +slot-unbound+))))) + (lambda (instance) + (check-obsolete-instance instance) + (not (eq (clos-slots-ref (fsc-instance-slots instance) + location) + +slot-unbound+))) + (lambda (instance) + (check-obsolete-instance instance) + (not (eq (clos-slots-ref (std-instance-slots instance) + location) + +slot-unbound+))))) (cons (lambda (instance) - (check-obsolete-instance instance) - (not (eq (cdr location) +slot-unbound+)))) + (check-obsolete-instance instance) + (not (eq (cdr location) +slot-unbound+)))) (null (lambda (instance) - (instance-structure-protocol-error slotd 'slot-boundp-using-class)))) + (instance-structure-protocol-error slotd 'slot-boundp-using-class)))) `(boundp ,slot-name))) (defun make-optimized-structure-slot-value-using-class-method-function @@ -308,105 +331,132 @@ ((structure-class-p class) (ecase name (reader (make-optimized-structure-slot-value-using-class-method-function - (slot-definition-internal-reader-function slotd))) + (slot-definition-internal-reader-function slotd))) (writer (make-optimized-structure-setf-slot-value-using-class-method-function - (slot-definition-internal-writer-function slotd))) + (slot-definition-internal-writer-function slotd))) (boundp (make-optimized-structure-slot-boundp-using-class-method-function)))) ((condition-class-p class) (ecase name (reader - (let ((fun (slot-definition-reader-function slotd))) - (declare (type function fun)) - (lambda (class object slotd) - (declare (ignore class slotd)) - (funcall fun object)))) + (let ((fun (slot-definition-reader-function slotd))) + (declare (type function fun)) + (lambda (class object slotd) + (declare (ignore class slotd)) + (funcall fun object)))) (writer - (let ((fun (slot-definition-writer-function slotd))) - (declare (type function fun)) - (lambda (new-value class object slotd) - (declare (ignore class slotd)) - (funcall fun new-value object)))) + (let ((fun (slot-definition-writer-function slotd))) + (declare (type function fun)) + (lambda (new-value class object slotd) + (declare (ignore class slotd)) + (funcall fun new-value object)))) (boundp - (let ((fun (slot-definition-boundp-function slotd))) - (declare (type function fun)) - (lambda (class object slotd) - (declare (ignore class slotd)) - (funcall fun object)))))) + (let ((fun (slot-definition-boundp-function slotd))) + (declare (type function fun)) + (lambda (class object slotd) + (declare (ignore class slotd)) + (funcall fun object)))))) (t (let* ((fsc-p (cond ((standard-class-p class) nil) - ((funcallable-standard-class-p class) t) - (t (error "~S is not a standard-class" class)))) - (function - (ecase name - (reader - #'make-optimized-std-slot-value-using-class-method-function) - (writer - #'make-optimized-std-setf-slot-value-using-class-method-function) - (boundp - #'make-optimized-std-slot-boundp-using-class-method-function)))) + ((funcallable-standard-class-p class) t) + (t (error "~S is not a standard-class" class)))) + (function + (ecase name + (reader + #'make-optimized-std-slot-value-using-class-method-function) + (writer + #'make-optimized-std-setf-slot-value-using-class-method-function) + (boundp + #'make-optimized-std-slot-boundp-using-class-method-function)))) (declare (type function function)) (values (funcall function fsc-p slotd) - (slot-definition-location slotd)))))) + (slot-definition-location slotd)))))) (defun make-optimized-std-slot-value-using-class-method-function (fsc-p slotd) (declare #.*optimize-speed*) (let ((location (slot-definition-location slotd)) - (slot-name (slot-definition-name slotd))) + (slot-name (slot-definition-name slotd))) (etypecase location (fixnum (if fsc-p - (lambda (class instance slotd) - (declare (ignore slotd)) - (check-obsolete-instance instance) - (let ((value (clos-slots-ref (fsc-instance-slots instance) - location))) - (if (eq value +slot-unbound+) - (values (slot-unbound class instance slot-name)) - value))) - (lambda (class instance slotd) - (declare (ignore slotd)) - (check-obsolete-instance instance) - (let ((value (clos-slots-ref (std-instance-slots instance) - location))) - (if (eq value +slot-unbound+) - (values (slot-unbound class instance slot-name)) - value))))) + (lambda (class instance slotd) + (declare (ignore slotd)) + (check-obsolete-instance instance) + (let ((value (clos-slots-ref (fsc-instance-slots instance) + location))) + (if (eq value +slot-unbound+) + (values (slot-unbound class instance slot-name)) + value))) + (lambda (class instance slotd) + (declare (ignore slotd)) + (check-obsolete-instance instance) + (let ((value (clos-slots-ref (std-instance-slots instance) + location))) + (if (eq value +slot-unbound+) + (values (slot-unbound class instance slot-name)) + value))))) (cons (lambda (class instance slotd) - (declare (ignore slotd)) - (check-obsolete-instance instance) - (let ((value (cdr location))) - (if (eq value +slot-unbound+) - (values (slot-unbound class instance slot-name)) - value)))) + (declare (ignore slotd)) + (check-obsolete-instance instance) + (let ((value (cdr location))) + (if (eq value +slot-unbound+) + (values (slot-unbound class instance slot-name)) + value)))) (null (lambda (class instance slotd) - (declare (ignore class instance)) - (instance-structure-protocol-error slotd 'slot-value-using-class)))))) + (declare (ignore class instance)) + (instance-structure-protocol-error slotd 'slot-value-using-class)))))) (defun make-optimized-std-setf-slot-value-using-class-method-function (fsc-p slotd) (declare #.*optimize-speed*) - (let ((location (slot-definition-location slotd))) + (let ((location (slot-definition-location slotd)) + (type (slot-definition-type slotd))) (etypecase location (fixnum (if fsc-p - (lambda (nv class instance slotd) - (declare (ignore class slotd)) - (check-obsolete-instance instance) - (setf (clos-slots-ref (fsc-instance-slots instance) location) - nv)) - (lambda (nv class instance slotd) - (declare (ignore class slotd)) - (check-obsolete-instance instance) - (setf (clos-slots-ref (std-instance-slots instance) location) - nv)))) - (cons (lambda (nv class instance slotd) - (declare (ignore class slotd)) - (check-obsolete-instance instance) - (setf (cdr location) nv))) + (if (eq type t) + (lambda (nv class instance slotd) + (declare (ignore class slotd)) + (check-obsolete-instance instance) + (setf (clos-slots-ref (fsc-instance-slots instance) location) + nv)) + (lambda (nv class instance slotd) + (declare (ignore class slotd)) + (check-obsolete-instance instance) + ;; FIXME: this is going to make a mockery of the + ;; "optimized" bit. Full call to typep on every slot + ;; write? Still, let's see if it works... + (unless (typep nv type) + (error 'type-error :datum nv :expected-type type)) + (setf (clos-slots-ref (fsc-instance-slots instance) location) + nv))) + (if (eq type t) + (lambda (nv class instance slotd) + (declare (ignore class slotd)) + (check-obsolete-instance instance) + (setf (clos-slots-ref (std-instance-slots instance) location) + nv)) + (lambda (nv class instance slotd) + (declare (ignore class slotd)) + (check-obsolete-instance instance) + (unless (typep nv type) + (error 'type-error :datum nv :expected-type type)) + (setf (clos-slots-ref (std-instance-slots instance) location) + nv))))) + (cons (if (eq type t) + (lambda (nv class instance slotd) + (declare (ignore class slotd)) + (check-obsolete-instance instance) + (setf (cdr location) nv)) + (lambda (nv class instance slotd) + (declare (ignore class slotd)) + (check-obsolete-instance instance) + (unless (typep nv type) + (error 'type-error :datum nv :expected-type type)) + (setf (cdr location) nv)))) (null (lambda (nv class instance slotd) - (declare (ignore nv class instance)) - (instance-structure-protocol-error - slotd '(setf slot-value-using-class))))))) + (declare (ignore nv class instance)) + (instance-structure-protocol-error + slotd '(setf slot-value-using-class))))))) (defun make-optimized-std-slot-boundp-using-class-method-function (fsc-p slotd) @@ -415,133 +465,150 @@ (etypecase location (fixnum (if fsc-p - (lambda (class instance slotd) - (declare (ignore class slotd)) - (check-obsolete-instance instance) - (not (eq (clos-slots-ref (fsc-instance-slots instance) location) - +slot-unbound+))) - (lambda (class instance slotd) - (declare (ignore class slotd)) - (check-obsolete-instance instance) - (not (eq (clos-slots-ref (std-instance-slots instance) location) - +slot-unbound+))))) + (lambda (class instance slotd) + (declare (ignore class slotd)) + (check-obsolete-instance instance) + (not (eq (clos-slots-ref (fsc-instance-slots instance) location) + +slot-unbound+))) + (lambda (class instance slotd) + (declare (ignore class slotd)) + (check-obsolete-instance instance) + (not (eq (clos-slots-ref (std-instance-slots instance) location) + +slot-unbound+))))) (cons (lambda (class instance slotd) - (declare (ignore class slotd)) - (check-obsolete-instance instance) - (not (eq (cdr location) +slot-unbound+)))) + (declare (ignore class slotd)) + (check-obsolete-instance instance) + (not (eq (cdr location) +slot-unbound+)))) (null (lambda (class instance slotd) - (declare (ignore class instance)) - (instance-structure-protocol-error slotd - 'slot-boundp-using-class)))))) + (declare (ignore class instance)) + (instance-structure-protocol-error slotd + 'slot-boundp-using-class)))))) (defun get-accessor-from-svuc-method-function (class slotd sdfun name) (macrolet ((emf-funcall (emf &rest args) - `(invoke-effective-method-function ,emf nil ,@args))) + `(invoke-effective-method-function ,emf nil ,@args))) (set-fun-name (case name (reader (lambda (instance) - (emf-funcall sdfun class instance slotd))) + (emf-funcall sdfun class instance slotd))) (writer (lambda (nv instance) - (emf-funcall sdfun nv class instance slotd))) + (emf-funcall sdfun nv class instance slotd))) (boundp (lambda (instance) - (emf-funcall sdfun class instance slotd)))) + (emf-funcall sdfun class instance slotd)))) `(,name ,(class-name class) ,(slot-definition-name slotd))))) (defun make-internal-reader-method-function (class-name slot-name) (list* :method-spec `(internal-reader-method ,class-name ,slot-name) - (make-method-function - (lambda (instance) - (let ((wrapper (get-instance-wrapper-or-nil instance))) - (if wrapper - (let* ((class (wrapper-class* wrapper)) - (index (or (instance-slot-index wrapper slot-name) - (assq slot-name - (wrapper-class-slots wrapper))))) - (typecase index - (fixnum - (let ((value (clos-slots-ref (get-slots instance) - index))) - (if (eq value +slot-unbound+) - (values (slot-unbound (class-of instance) - instance - slot-name)) - value))) - (cons - (let ((value (cdr index))) - (if (eq value +slot-unbound+) - (values (slot-unbound (class-of instance) - instance - slot-name)) - value))) - (t - (error "~@" - class slot-name)))) - (slot-value instance slot-name))))))) + class slot-name)))) + (slot-value instance slot-name))))))) (defun make-std-reader-method-function (class-name slot-name) (let* ((pv-table-symbol (gensym)) - (initargs (copy-tree - (make-method-function - (lambda (instance) - (pv-binding1 (.pv. .calls. - (symbol-value pv-table-symbol) - (instance) (instance-slots)) - (instance-read-internal - .pv. instance-slots 1 - (slot-value instance slot-name)))))))) + (initargs (copy-tree + (make-method-function + (lambda (instance) + (pv-binding1 (.pv. .calls. + (symbol-value pv-table-symbol) + (instance) (instance-slots)) + (instance-read-internal + .pv. instance-slots 1 + (slot-value instance slot-name)))))))) (setf (getf (getf initargs :plist) :slot-name-lists) - (list (list nil slot-name))) + (list (list nil slot-name))) (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol) (list* :method-spec `(reader-method ,class-name ,slot-name) - initargs))) + initargs))) (defun make-std-writer-method-function (class-name slot-name) (let* ((pv-table-symbol (gensym)) - (initargs (copy-tree - (make-method-function - (lambda (nv instance) - (pv-binding1 (.pv. .calls. - (symbol-value pv-table-symbol) - (instance) (instance-slots)) - (instance-write-internal - .pv. instance-slots 1 nv - (setf (slot-value instance slot-name) nv)))))))) + (type (or (not (eq *boot-state* 'complete)) + (let ((slotd (find-slot-definition (find-class class-name) slot-name))) + (or (not slotd) (slot-definition-type slotd))))) + ;; FIXME: how expensive is this? + (typecheckfun (lambda (nv) (unless (typep nv type) + (error 'type-error + :datum nv :expected-type type)))) + (initargs (copy-tree + (if (eq type t) + (make-method-function + (lambda (nv instance) + (pv-binding1 (.pv. .calls. + (symbol-value pv-table-symbol) + (instance) (instance-slots)) + (instance-write-internal + .pv. instance-slots 1 nv + (setf (slot-value instance slot-name) nv))))) + (make-method-function + (lambda (nv instance) + (funcall typecheckfun nv) + (pv-binding1 (.pv. .calls. + (symbol-value pv-table-symbol) + (instance) (instance-slots)) + (instance-write-internal + .pv. instance-slots 1 nv + (setf (slot-value instance slot-name) nv))))))))) (setf (getf (getf initargs :plist) :slot-name-lists) - (list nil (list nil slot-name))) + (list nil (list nil slot-name))) (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol) (list* :method-spec `(writer-method ,class-name ,slot-name) - initargs))) + initargs))) (defun make-std-boundp-method-function (class-name slot-name) (let* ((pv-table-symbol (gensym)) - (initargs (copy-tree - (make-method-function - (lambda (instance) - (pv-binding1 (.pv. .calls. - (symbol-value pv-table-symbol) - (instance) (instance-slots)) - (instance-boundp-internal - .pv. instance-slots 1 - (slot-boundp instance slot-name)))))))) + (initargs (copy-tree + (make-method-function + (lambda (instance) + (pv-binding1 (.pv. .calls. + (symbol-value pv-table-symbol) + (instance) (instance-slots)) + (instance-boundp-internal + .pv. instance-slots 1 + (slot-boundp instance slot-name)))))))) (setf (getf (getf initargs :plist) :slot-name-lists) - (list (list nil slot-name))) + (list (list nil slot-name))) (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol) (list* :method-spec `(boundp-method ,class-name ,slot-name) - initargs))) + initargs))) (defun initialize-internal-slot-gfs (slot-name &optional type) (macrolet ((frob (type name-fun add-fun ll) - `(when (or (null type) (eq type ',type)) - (let* ((name (,name-fun slot-name)) - (gf (ensure-generic-function name - :lambda-list ',ll)) - (methods (generic-function-methods gf))) - (when (or (null methods) - (plist-value gf 'slot-missing-method)) - (setf (plist-value gf 'slot-missing-method) nil) - (,add-fun *the-class-slot-object* gf slot-name)))))) + `(when (or (null type) (eq type ',type)) + (let* ((name (,name-fun slot-name)) + (gf (ensure-generic-function name + :lambda-list ',ll)) + (methods (generic-function-methods gf))) + (when (or (null methods) + (plist-value gf 'slot-missing-method)) + (setf (plist-value gf 'slot-missing-method) nil) + (,add-fun *the-class-slot-object* gf slot-name)))))) (frob reader slot-reader-name add-reader-method (object)) (frob writer slot-writer-name add-writer-method (new-value object)) (frob boundp slot-boundp-name add-boundp-method (object)))) diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index 24de706ea..54cf9188a 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -28,9 +28,9 @@ (define-condition unbound-slot (cell-error) ((instance :reader unbound-slot-instance :initarg :instance)) (:report (lambda (condition stream) - (format stream "The slot ~S is unbound in the object ~S." - (cell-error-name condition) - (unbound-slot-instance condition))))) + (format stream "The slot ~S is unbound in the object ~S." + (cell-error-name condition) + (unbound-slot-instance condition))))) (defmethod wrapper-fetcher ((class standard-class)) 'std-instance-wrapper) @@ -50,30 +50,30 @@ (defun set-wrapper (inst new) (cond ((std-instance-p inst) - (setf (std-instance-wrapper inst) new)) - ((fsc-instance-p inst) - (setf (fsc-instance-wrapper inst) new)) - (t - (error "unrecognized instance type")))) + (setf (std-instance-wrapper inst) new)) + ((fsc-instance-p inst) + (setf (fsc-instance-wrapper inst) new)) + (t + (error "unrecognized instance type")))) (defun swap-wrappers-and-slots (i1 i2) - (with-pcl-lock ;FIXME is this sufficient? + (with-pcl-lock ;FIXME is this sufficient? (cond ((std-instance-p i1) - (let ((w1 (std-instance-wrapper i1)) - (s1 (std-instance-slots i1))) - (setf (std-instance-wrapper i1) (std-instance-wrapper i2)) - (setf (std-instance-slots i1) (std-instance-slots i2)) - (setf (std-instance-wrapper i2) w1) - (setf (std-instance-slots i2) s1))) - ((fsc-instance-p i1) - (let ((w1 (fsc-instance-wrapper i1)) - (s1 (fsc-instance-slots i1))) - (setf (fsc-instance-wrapper i1) (fsc-instance-wrapper i2)) - (setf (fsc-instance-slots i1) (fsc-instance-slots i2)) - (setf (fsc-instance-wrapper i2) w1) - (setf (fsc-instance-slots i2) s1))) - (t - (error "unrecognized instance type"))))) + (let ((w1 (std-instance-wrapper i1)) + (s1 (std-instance-slots i1))) + (setf (std-instance-wrapper i1) (std-instance-wrapper i2)) + (setf (std-instance-slots i1) (std-instance-slots i2)) + (setf (std-instance-wrapper i2) w1) + (setf (std-instance-slots i2) s1))) + ((fsc-instance-p i1) + (let ((w1 (fsc-instance-wrapper i1)) + (s1 (fsc-instance-slots i1))) + (setf (fsc-instance-wrapper i1) (fsc-instance-wrapper i2)) + (setf (fsc-instance-slots i1) (fsc-instance-slots i2)) + (setf (fsc-instance-wrapper i2) w1) + (setf (fsc-instance-slots i2) s1))) + (t + (error "unrecognized instance type"))))) (defun find-slot-definition (class slot-name) (dolist (slot (class-slots class) nil) @@ -83,53 +83,53 @@ (declaim (ftype (sfunction (t symbol) t) slot-value)) (defun slot-value (object slot-name) (let* ((class (class-of object)) - (slot-definition (find-slot-definition class slot-name))) + (slot-definition (find-slot-definition class slot-name))) (if (null slot-definition) - (values (slot-missing class object slot-name 'slot-value)) - (slot-value-using-class class object slot-definition)))) + (values (slot-missing class object slot-name 'slot-value)) + (slot-value-using-class class object slot-definition)))) (define-compiler-macro slot-value (&whole form object slot-name) (if (and (constantp slot-name) - (interned-symbol-p (eval slot-name))) + (interned-symbol-p (eval slot-name))) `(accessor-slot-value ,object ,slot-name) form)) (defun set-slot-value (object slot-name new-value) (let* ((class (class-of object)) - (slot-definition (find-slot-definition class slot-name))) + (slot-definition (find-slot-definition class slot-name))) (if (null slot-definition) - (progn (slot-missing class object slot-name 'setf new-value) - new-value) - (setf (slot-value-using-class class object slot-definition) - new-value)))) + (progn (slot-missing class object slot-name 'setf new-value) + new-value) + (setf (slot-value-using-class class object slot-definition) + new-value)))) (define-compiler-macro set-slot-value (&whole form object slot-name new-value) (if (and (constantp slot-name) - (interned-symbol-p (eval slot-name))) + (interned-symbol-p (eval slot-name))) `(accessor-set-slot-value ,object ,slot-name ,new-value) form)) (defun slot-boundp (object slot-name) (let* ((class (class-of object)) - (slot-definition (find-slot-definition class slot-name))) + (slot-definition (find-slot-definition class slot-name))) (if (null slot-definition) - (not (not (slot-missing class object slot-name 'slot-boundp))) - (slot-boundp-using-class class object slot-definition)))) + (not (not (slot-missing class object slot-name 'slot-boundp))) + (slot-boundp-using-class class object slot-definition)))) (setf (gdefinition 'slot-boundp-normal) #'slot-boundp) (define-compiler-macro slot-boundp (&whole form object slot-name) (if (and (constantp slot-name) - (interned-symbol-p (eval slot-name))) + (interned-symbol-p (eval slot-name))) `(accessor-slot-boundp ,object ,slot-name) form)) (defun slot-makunbound (object slot-name) (let* ((class (class-of object)) - (slot-definition (find-slot-definition class slot-name))) + (slot-definition (find-slot-definition class slot-name))) (if (null slot-definition) - (slot-missing class object slot-name 'slot-makunbound) - (slot-makunbound-using-class class object slot-definition)) + (slot-missing class object slot-name 'slot-makunbound) + (slot-makunbound-using-class class object slot-definition)) object)) (defun slot-exists-p (object slot-name) @@ -150,97 +150,105 @@ (clos-slots-ref (fsc-instance-slots instance) location)) (defmethod slot-value-using-class ((class std-class) - (object std-object) - (slotd standard-effective-slot-definition)) + (object standard-object) + (slotd standard-effective-slot-definition)) (check-obsolete-instance object) (let* ((location (slot-definition-location slotd)) - (value - (typecase location - (fixnum - (cond ((std-instance-p object) - (clos-slots-ref (std-instance-slots object) - location)) - ((fsc-instance-p object) - (clos-slots-ref (fsc-instance-slots object) - location)) - (t (bug "unrecognized instance type in ~S" - 'slot-value-using-class)))) - (cons - (cdr location)) - (t - (instance-structure-protocol-error slotd - 'slot-value-using-class))))) + (value + (typecase location + (fixnum + (cond ((std-instance-p object) + (clos-slots-ref (std-instance-slots object) + location)) + ((fsc-instance-p object) + (clos-slots-ref (fsc-instance-slots object) + location)) + (t (bug "unrecognized instance type in ~S" + 'slot-value-using-class)))) + (cons + (cdr location)) + (t + (instance-structure-protocol-error slotd + 'slot-value-using-class))))) (if (eq value +slot-unbound+) - (values (slot-unbound class object (slot-definition-name slotd))) - value))) + (values (slot-unbound class object (slot-definition-name slotd))) + value))) (defmethod (setf slot-value-using-class) - (new-value (class std-class) - (object std-object) - (slotd standard-effective-slot-definition)) + (new-value (class std-class) + (object standard-object) + (slotd standard-effective-slot-definition)) (check-obsolete-instance object) - (let ((location (slot-definition-location slotd))) - (typecase location - (fixnum - (cond ((std-instance-p object) - (setf (clos-slots-ref (std-instance-slots object) location) - new-value)) - ((fsc-instance-p object) - (setf (clos-slots-ref (fsc-instance-slots object) location) - new-value)) - (t (bug "unrecognized instance type in ~S" - '(setf slot-value-using-class))))) - (cons - (setf (cdr location) new-value)) - (t - (instance-structure-protocol-error slotd - '(setf slot-value-using-class)))))) + (let ((location (slot-definition-location slotd)) + (type (slot-definition-type slotd))) + (flet ((check (new-value type) + (cond + ((eq type t) new-value) + (t (if (typep new-value type) + new-value + (error 'type-error + :datum new-value :expected-type type)))))) + (typecase location + (fixnum + (cond ((std-instance-p object) + (setf (clos-slots-ref (std-instance-slots object) location) + (check new-value type))) + ((fsc-instance-p object) + (setf (clos-slots-ref (fsc-instance-slots object) location) + (check new-value type))) + (t (bug "unrecognized instance type in ~S" + '(setf slot-value-using-class))))) + (cons + (setf (cdr location) (check new-value type))) + (t + (instance-structure-protocol-error + slotd '(setf slot-value-using-class))))))) (defmethod slot-boundp-using-class - ((class std-class) - (object std-object) - (slotd standard-effective-slot-definition)) + ((class std-class) + (object standard-object) + (slotd standard-effective-slot-definition)) (check-obsolete-instance object) (let* ((location (slot-definition-location slotd)) - (value - (typecase location - (fixnum - (cond ((std-instance-p object) - (clos-slots-ref (std-instance-slots object) - location)) - ((fsc-instance-p object) - (clos-slots-ref (fsc-instance-slots object) - location)) - (t (bug "unrecognized instance type in ~S" - 'slot-boundp-using-class)))) - (cons - (cdr location)) - (t - (instance-structure-protocol-error slotd - 'slot-boundp-using-class))))) + (value + (typecase location + (fixnum + (cond ((std-instance-p object) + (clos-slots-ref (std-instance-slots object) + location)) + ((fsc-instance-p object) + (clos-slots-ref (fsc-instance-slots object) + location)) + (t (bug "unrecognized instance type in ~S" + 'slot-boundp-using-class)))) + (cons + (cdr location)) + (t + (instance-structure-protocol-error slotd + 'slot-boundp-using-class))))) (not (eq value +slot-unbound+)))) (defmethod slot-makunbound-using-class - ((class std-class) - (object std-object) - (slotd standard-effective-slot-definition)) + ((class std-class) + (object standard-object) + (slotd standard-effective-slot-definition)) (check-obsolete-instance object) (let ((location (slot-definition-location slotd))) (typecase location (fixnum (cond ((std-instance-p object) - (setf (clos-slots-ref (std-instance-slots object) location) - +slot-unbound+)) - ((fsc-instance-p object) - (setf (clos-slots-ref (fsc-instance-slots object) location) - +slot-unbound+)) - (t (bug "unrecognized instance type in ~S" - 'slot-makunbound-using-class)))) + (setf (clos-slots-ref (std-instance-slots object) location) + +slot-unbound+)) + ((fsc-instance-p object) + (setf (clos-slots-ref (fsc-instance-slots object) location) + +slot-unbound+)) + (t (bug "unrecognized instance type in ~S" + 'slot-makunbound-using-class)))) (cons (setf (cdr location) +slot-unbound+)) (t (instance-structure-protocol-error slotd - 'slot-makunbound-using-class)))) + 'slot-makunbound-using-class)))) object) (defmethod slot-value-using-class @@ -270,52 +278,52 @@ (defmethod slot-makunbound-using-class ((class condition-class) object slot) (error "attempt to unbind slot ~S in condition object ~S." - slot object)) + slot object)) (defmethod slot-value-using-class ((class structure-class) (object structure-object) (slotd structure-effective-slot-definition)) (let* ((function (slot-definition-internal-reader-function slotd)) - (value (funcall function object))) + (value (funcall function object))) (declare (type function function)) (if (eq value +slot-unbound+) - (values (slot-unbound class object (slot-definition-name slotd))) - value))) + (values (slot-unbound class object (slot-definition-name slotd))) + value))) (defmethod (setf slot-value-using-class) (new-value (class structure-class) - (object structure-object) - (slotd structure-effective-slot-definition)) + (object structure-object) + (slotd structure-effective-slot-definition)) (let ((function (slot-definition-internal-writer-function slotd))) (declare (type function function)) (funcall function new-value object))) (defmethod slot-boundp-using-class - ((class structure-class) - (object structure-object) - (slotd structure-effective-slot-definition)) + ((class structure-class) + (object structure-object) + (slotd structure-effective-slot-definition)) t) (defmethod slot-makunbound-using-class - ((class structure-class) - (object structure-object) - (slotd structure-effective-slot-definition)) + ((class structure-class) + (object structure-object) + (slotd structure-effective-slot-definition)) (error "Structure slots can't be unbound.")) (defmethod slot-missing - ((class t) instance slot-name operation &optional new-value) + ((class t) instance slot-name operation &optional new-value) (error "~@" - (ecase operation - (slot-value "read the slot's value (slot-value)") - (setf (format nil - "set the slot's value to ~S (SETF of SLOT-VALUE)" - new-value)) - (slot-boundp "test to see whether slot is bound (SLOT-BOUNDP)") - (slot-makunbound "make the slot unbound (SLOT-MAKUNBOUND)")) - slot-name - instance)) + (ecase operation + (slot-value "read the slot's value (slot-value)") + (setf (format nil + "set the slot's value to ~S (SETF of SLOT-VALUE)" + new-value)) + (slot-boundp "test to see whether slot is bound (SLOT-BOUNDP)") + (slot-makunbound "make the slot unbound (SLOT-MAKUNBOUND)")) + slot-name + instance)) (defmethod slot-unbound ((class t) instance slot-name) (error 'unbound-slot :name slot-name :instance instance)) @@ -336,7 +344,7 @@ ;;; care of this for non-standard-classes.x (defmethod allocate-instance ((class standard-class) &rest initargs) (declare (ignore initargs)) - (unless (class-finalized-p class) + (unless (class-finalized-p class) (finalize-inheritance class)) (allocate-standard-instance (class-wrapper class))) @@ -344,7 +352,7 @@ (declare (ignore initargs)) (let ((constructor (class-defstruct-constructor class))) (if constructor - (funcall constructor) + (funcall constructor) (allocate-standard-instance (class-wrapper class))))) ;;; FIXME: It would be nicer to have allocate-instance return diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 3a6b3b98f..5ba2c8584 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -30,8 +30,8 @@ (boundp (slot-definition-boundp-function slotd)))) (defmethod (setf slot-accessor-function) (function - (slotd effective-slot-definition) - type) + (slotd effective-slot-definition) + type) (ecase type (reader (setf (slot-definition-reader-function slotd) function)) (writer (setf (slot-definition-writer-function slotd) function)) @@ -46,44 +46,44 @@ (let ((flags (slot-value slotd 'accessor-flags))) (declare (type fixnum flags)) (if (eq type 'all) - (eql +slotd-all-function-std-p+ flags) - (let ((mask (ecase type - (reader +slotd-reader-function-std-p+) - (writer +slotd-writer-function-std-p+) - (boundp +slotd-boundp-function-std-p+)))) - (declare (type fixnum mask)) - (not (zerop (the fixnum (logand mask flags)))))))) + (eql +slotd-all-function-std-p+ flags) + (let ((mask (ecase type + (reader +slotd-reader-function-std-p+) + (writer +slotd-writer-function-std-p+) + (boundp +slotd-boundp-function-std-p+)))) + (declare (type fixnum mask)) + (not (zerop (the fixnum (logand mask flags)))))))) (defmethod (setf slot-accessor-std-p) (value - (slotd effective-slot-definition) - type) + (slotd effective-slot-definition) + type) (let ((mask (ecase type - (reader +slotd-reader-function-std-p+) - (writer +slotd-writer-function-std-p+) - (boundp +slotd-boundp-function-std-p+))) - (flags (slot-value slotd 'accessor-flags))) + (reader +slotd-reader-function-std-p+) + (writer +slotd-writer-function-std-p+) + (boundp +slotd-boundp-function-std-p+))) + (flags (slot-value slotd 'accessor-flags))) (declare (type fixnum mask flags)) (setf (slot-value slotd 'accessor-flags) - (if value - (the fixnum (logior mask flags)) - (the fixnum (logand (the fixnum (lognot mask)) flags))))) + (if value + (the fixnum (logior mask flags)) + (the fixnum (logand (the fixnum (lognot mask)) flags))))) value) (defmethod initialize-internal-slot-functions ((slotd - effective-slot-definition)) + effective-slot-definition)) (let* ((name (slot-value slotd 'name)) - (class (slot-value slotd 'class))) + (class (slot-value slotd 'class))) (let ((table (or (gethash name *name->class->slotd-table*) - (setf (gethash name *name->class->slotd-table*) - (make-hash-table :test 'eq :size 5))))) + (setf (gethash name *name->class->slotd-table*) + (make-hash-table :test 'eq :size 5))))) (setf (gethash class table) slotd)) (dolist (type '(reader writer boundp)) (let* ((gf-name (ecase type - (reader 'slot-value-using-class) - (writer '(setf slot-value-using-class)) - (boundp 'slot-boundp-using-class))) - (gf (gdefinition gf-name))) - (compute-slot-accessor-info slotd type gf))) + (reader 'slot-value-using-class) + (writer '(setf slot-value-using-class)) + (boundp 'slot-boundp-using-class))) + (gf (gdefinition gf-name))) + (compute-slot-accessor-info slotd type gf))) (initialize-internal-slot-gfs name))) ;;; CMUCL (Gerd PCL 2003-04-25) comment: @@ -101,15 +101,15 @@ ;;; FIXME: Change the function name to COMPUTE-SVUC-SLOTD-FUNCTION, ;;; or some such. (defmethod compute-slot-accessor-info ((slotd effective-slot-definition) - type gf) + type gf) (let* ((name (slot-value slotd 'name)) - (class (slot-value slotd 'class)) - (old-slotd (find-slot-definition class name)) - (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all)))) + (class (slot-value slotd 'class)) + (old-slotd (find-slot-definition class name)) + (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all)))) (multiple-value-bind (function std-p) - (if (eq *boot-state* 'complete) - (get-accessor-method-function gf type class slotd) - (get-optimized-std-accessor-method-function class slotd type)) + (if (eq *boot-state* 'complete) + (get-accessor-method-function gf type class slotd) + (get-optimized-std-accessor-method-function class slotd type)) (setf (slot-accessor-std-p slotd type) std-p) (setf (slot-accessor-function slotd type) function)) (when (and old-slotd (not (eq old-std-p (slot-accessor-std-p slotd 'all)))) @@ -123,7 +123,7 @@ (defmethod class-prototype :before (class) (unless (class-finalized-p class) - (error "~S not yet finalized, cannot allocate a prototype." class))) + (error "~@<~S is not finalized.~:@>" class))) ;;; KLUDGE: For some reason factoring the common body into a function ;;; breaks PCL bootstrapping, so just generate it with a macrolet for @@ -131,7 +131,7 @@ (macrolet ((def (class) `(defmethod class-prototype ((class ,class)) (with-slots (prototype) class - (or prototype + (or prototype (setf prototype (allocate-instance class))))))) (def std-class) (def condition-class) @@ -180,13 +180,13 @@ ;;; computed lazily. (defmethod add-direct-method ((specializer class) (method method)) (with-slots (direct-methods) specializer - (setf (car direct-methods) (adjoin method (car direct-methods)) ;PUSH - (cdr direct-methods) ())) + (setf (car direct-methods) (adjoin method (car direct-methods)) ;PUSH + (cdr direct-methods) ())) method) (defmethod remove-direct-method ((specializer class) (method method)) (with-slots (direct-methods) specializer (setf (car direct-methods) (remove method (car direct-methods)) - (cdr direct-methods) ())) + (cdr direct-methods) ())) method) (defmethod specializer-direct-methods ((specializer class)) @@ -196,12 +196,12 @@ (defmethod specializer-direct-generic-functions ((specializer class)) (with-slots (direct-methods) specializer (or (cdr direct-methods) - (setf (cdr direct-methods) - (let (collect) - (dolist (m (car direct-methods)) + (setf (cdr direct-methods) + (let (collect) + (dolist (m (car direct-methods)) ;; the old PCL code used COLLECTING-ONCE which used ;; #'EQ to check for newness - (pushnew (method-generic-function m) collect :test #'eq)) + (pushnew (method-generic-function m) collect :test #'eq)) (nreverse collect)))))) ;;; This hash table is used to store the direct methods and direct generic @@ -216,70 +216,70 @@ *class-eq-specializer-methods*) (defmethod add-direct-method ((specializer specializer-with-object) - (method method)) + (method method)) (let* ((object (specializer-object specializer)) - (table (specializer-method-table specializer)) - (entry (gethash object table))) + (table (specializer-method-table specializer)) + (entry (gethash object table))) (unless entry (setq entry - (setf (gethash object table) - (cons nil nil)))) + (setf (gethash object table) + (cons nil nil)))) (setf (car entry) (adjoin method (car entry)) - (cdr entry) ()) + (cdr entry) ()) method)) (defmethod remove-direct-method ((specializer specializer-with-object) - (method method)) + (method method)) (let* ((object (specializer-object specializer)) - (entry (gethash object (specializer-method-table specializer)))) + (entry (gethash object (specializer-method-table specializer)))) (when entry (setf (car entry) (remove method (car entry)) - (cdr entry) ())) + (cdr entry) ())) method)) (defmethod specializer-direct-methods ((specializer specializer-with-object)) (car (gethash (specializer-object specializer) - (specializer-method-table specializer)))) + (specializer-method-table specializer)))) (defmethod specializer-direct-generic-functions ((specializer - specializer-with-object)) + specializer-with-object)) (let* ((object (specializer-object specializer)) - (entry (gethash object (specializer-method-table specializer)))) + (entry (gethash object (specializer-method-table specializer)))) (when entry (or (cdr entry) - (setf (cdr entry) - (let (collect) - (dolist (m (car entry)) - (pushnew (method-generic-function m) collect :test #'eq)) + (setf (cdr entry) + (let (collect) + (dolist (m (car entry)) + (pushnew (method-generic-function m) collect :test #'eq)) (nreverse collect))))))) (defun map-specializers (function) (map-all-classes (lambda (class) - (funcall function (class-eq-specializer class)) - (funcall function class))) + (funcall function (class-eq-specializer class)) + (funcall function class))) (maphash (lambda (object methods) - (declare (ignore methods)) - (intern-eql-specializer object)) - *eql-specializer-methods*) + (declare (ignore methods)) + (intern-eql-specializer object)) + *eql-specializer-methods*) (maphash (lambda (object specl) - (declare (ignore object)) - (funcall function specl)) - *eql-specializer-table*) + (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)))))) + (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) - slot-names - &key) + slot-names + &key) (declare (ignore slot-names)) (setf (slot-value specl 'type) `(class-eq ,(specializer-class specl)))) @@ -291,14 +291,13 @@ (constantly (make-member-type :members (list (specializer-object specl)))))) (defun real-load-defclass (name metaclass-name supers slots other - readers writers slot-names) + readers writers slot-names source-location) (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 `((defclass ,name) - ,*load-pathname*) + :definition-source source-location other))) res))) @@ -306,12 +305,12 @@ (defun ensure-class (name &rest args) (apply #'ensure-class-using-class - (let ((class (find-class name nil))) - (when (and class (eq name (class-name class))) - ;; NAME is the proper name of CLASS, so redefine it - class)) - name - args)) + (let ((class (find-class name nil))) + (when (and class (eq name (class-name class))) + ;; NAME is the proper name of CLASS, so redefine it + class)) + name + args)) (defmethod ensure-class-using-class ((class null) name &rest args &key) (multiple-value-bind (meta initargs) @@ -340,24 +339,26 @@ (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)) + (error "~S is not a class or a legal class name." s)) (t - (or (find-class s nil) - (make-instance 'forward-referenced-class - :name s))))) + (or (find-class s nil) + (make-instance 'forward-referenced-class + :name s))))) (defun ensure-class-values (class initargs) (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))))) + (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 - (find-class metaclass)) + (if (classp metaclass) + metaclass + (find-class metaclass))) ((or (null class) (forward-referenced-class-p class)) *the-class-standard-class*) (t @@ -366,93 +367,93 @@ (defmethod shared-initialize :after - ((class std-class) - slot-names - &key (direct-superclasses nil direct-superclasses-p) - (direct-slots nil direct-slots-p) - (direct-default-initargs nil direct-default-initargs-p) - (predicate-name nil predicate-name-p)) + ((class std-class) + slot-names + &key (direct-superclasses nil direct-superclasses-p) + (direct-slots nil direct-slots-p) + (direct-default-initargs nil direct-default-initargs-p) + (predicate-name nil predicate-name-p)) (cond (direct-superclasses-p - (setq direct-superclasses - (or direct-superclasses - (list (if (funcallable-standard-class-p class) - *the-class-funcallable-standard-object* - *the-class-standard-object*)))) - (dolist (superclass direct-superclasses) - (unless (validate-superclass class superclass) - (error "The class ~S was specified as a~% - super-class of the class ~S;~%~ - but the meta-classes ~S and~%~S are incompatible.~@ - Define a method for ~S to avoid this error." - superclass class (class-of superclass) (class-of class) - 'validate-superclass))) - (setf (slot-value class 'direct-superclasses) direct-superclasses)) - (t - (setq direct-superclasses (slot-value class 'direct-superclasses)))) + (setq direct-superclasses + (or direct-superclasses + (list (if (funcallable-standard-class-p class) + *the-class-funcallable-standard-object* + *the-class-standard-object*)))) + (dolist (superclass direct-superclasses) + (unless (validate-superclass class superclass) + (error "~@" + superclass class (class-of superclass) (class-of class) + 'validate-superclass))) + (setf (slot-value class 'direct-superclasses) direct-superclasses)) + (t + (setq direct-superclasses (slot-value class 'direct-superclasses)))) (setq direct-slots - (if direct-slots-p - (setf (slot-value class 'direct-slots) - (mapcar (lambda (pl) (make-direct-slotd class pl)) - direct-slots)) - (slot-value class 'direct-slots))) + (if direct-slots-p + (setf (slot-value class 'direct-slots) + (mapcar (lambda (pl) (make-direct-slotd class pl)) + direct-slots)) + (slot-value class 'direct-slots))) (if direct-default-initargs-p (setf (plist-value class 'direct-default-initargs) - direct-default-initargs) + direct-default-initargs) (setq direct-default-initargs - (plist-value class 'direct-default-initargs))) + (plist-value class 'direct-default-initargs))) (setf (plist-value class 'class-slot-cells) - (let ((old-class-slot-cells (plist-value class 'class-slot-cells)) - (collect '())) - (dolist (dslotd direct-slots) - (when (eq :class (slot-definition-allocation dslotd)) - ;; see CLHS 4.3.6 - (let* ((name (slot-definition-name dslotd)) - (old (assoc name old-class-slot-cells))) - (if (or (not old) - (eq t slot-names) - (member name slot-names)) - (let* ((initfunction (slot-definition-initfunction dslotd)) - (value (if initfunction - (funcall initfunction) - +slot-unbound+))) - (push (cons name value) collect)) - (push old collect))))) + (let ((old-class-slot-cells (plist-value class 'class-slot-cells)) + (collect '())) + (dolist (dslotd direct-slots) + (when (eq :class (slot-definition-allocation dslotd)) + ;; see CLHS 4.3.6 + (let* ((name (slot-definition-name dslotd)) + (old (assoc name old-class-slot-cells))) + (if (or (not old) + (eq t slot-names) + (member name slot-names)) + (let* ((initfunction (slot-definition-initfunction dslotd)) + (value (if initfunction + (funcall initfunction) + +slot-unbound+))) + (push (cons name value) collect)) + (push old collect))))) (nreverse collect))) (setq predicate-name (if predicate-name-p - (setf (slot-value class 'predicate-name) - (car predicate-name)) - (or (slot-value class 'predicate-name) - (setf (slot-value class 'predicate-name) - (make-class-predicate-name (class-name - class)))))) + (setf (slot-value class 'predicate-name) + (car predicate-name)) + (or (slot-value class 'predicate-name) + (setf (slot-value class 'predicate-name) + (make-class-predicate-name (class-name + class)))))) (add-direct-subclasses class direct-superclasses) (make-class-predicate class predicate-name) (update-class class nil) (do* ((slots (slot-value class 'slots) (cdr slots)) - (dupes nil)) + (dupes nil)) ((null slots) (when dupes - (style-warn - ;; FIXME: the indentation request ("~4I") - ;; below appears not to do anything. Finding - ;; out why would be nice. -- CSR, 2003-04-24 - "~@~@:>" - class - dupes))) + class + dupes))) (let* ((slot (car slots)) - (oslots (remove (slot-definition-name slot) (cdr slots) - :test #'string/= :key #'slot-definition-name))) + (oslots (remove (slot-definition-name slot) (cdr slots) + :test #'string/= :key #'slot-definition-name))) (when oslots - (pushnew (cons (slot-definition-name slot) - (mapcar #'slot-definition-name oslots)) - dupes - :test #'string= :key #'car)))) + (pushnew (cons (slot-definition-name slot) + (mapcar #'slot-definition-name oslots)) + dupes + :test #'string= :key #'car)))) (add-slot-accessors class direct-slots) (make-preliminary-layout class)) (defmethod shared-initialize :after ((class forward-referenced-class) - slot-names &key &allow-other-keys) + slot-names &key &allow-other-keys) (declare (ignore slot-names)) (make-preliminary-layout class)) @@ -462,35 +463,35 @@ ;;; make it known to the type system. (defun make-preliminary-layout (class) (flet ((compute-preliminary-cpl (root) - (let ((*allow-forward-referenced-classes-in-cpl-p* t)) - (compute-class-precedence-list root)))) + (let ((*allow-forward-referenced-classes-in-cpl-p* t)) + (compute-class-precedence-list root)))) (without-package-locks (unless (class-finalized-p class) (let ((name (class-name class))) - (setf (find-class name) class) - ;; KLUDGE: This is fairly horrible. We need to make a - ;; full-fledged CLASSOID here, not just tell the compiler that - ;; some class is forthcoming, because there are legitimate - ;; questions one can ask of the type system, implemented in - ;; terms of CLASSOIDs, involving forward-referenced classes. So. - (when (and (eq *boot-state* 'complete) - (null (find-classoid name nil))) - (setf (find-classoid name) - (make-standard-classoid :name name))) - (set-class-type-translation class name) - (let ((layout (make-wrapper 0 class)) - (classoid (find-classoid name))) - (setf (layout-classoid layout) classoid) - (setf (classoid-pcl-class classoid) class) - (setf (slot-value class 'wrapper) layout) - (let ((cpl (compute-preliminary-cpl class))) - (setf (layout-inherits layout) - (order-layout-inherits - (map 'simple-vector #'class-wrapper - (reverse (rest cpl)))))) - (register-layout layout :invalidate t) - (setf (classoid-layout classoid) layout) - (mapc #'make-preliminary-layout (class-direct-subclasses class)))))))) + (setf (find-class name) class) + ;; KLUDGE: This is fairly horrible. We need to make a + ;; full-fledged CLASSOID here, not just tell the compiler that + ;; some class is forthcoming, because there are legitimate + ;; questions one can ask of the type system, implemented in + ;; terms of CLASSOIDs, involving forward-referenced classes. So. + (when (and (eq *boot-state* 'complete) + (null (find-classoid name nil))) + (setf (find-classoid name) + (make-standard-classoid :name name))) + (set-class-type-translation class name) + (let ((layout (make-wrapper 0 class)) + (classoid (find-classoid name))) + (setf (layout-classoid layout) classoid) + (setf (classoid-pcl-class classoid) class) + (setf (slot-value class 'wrapper) layout) + (let ((cpl (compute-preliminary-cpl class))) + (setf (layout-inherits layout) + (order-layout-inherits + (map 'simple-vector #'class-wrapper + (reverse (rest cpl)))))) + (register-layout layout :invalidate t) + (setf (classoid-layout classoid) layout) + (mapc #'make-preliminary-layout (class-direct-subclasses class)))))))) (defmethod shared-initialize :before ((class class) slot-names &key name) @@ -499,7 +500,7 @@ ;; why not? (See also similar expression in !BOOTSTRAP-INITIALIZE-CLASS.) (setf (slot-value class 'type) `(class ,class)) (setf (slot-value class 'class-eq-specializer) - (make-instance 'class-eq-specializer :class class))) + (make-instance 'class-eq-specializer :class class))) (defmethod reinitialize-instance :before ((class slot-class) &key direct-superclasses) (dolist (old-super (set-difference (class-direct-superclasses class) direct-superclasses)) @@ -507,23 +508,38 @@ (remove-slot-accessors class (class-direct-slots class))) (defmethod reinitialize-instance :after ((class slot-class) - &rest initargs - &key) + &rest initargs + &key) (map-dependents class - (lambda (dependent) - (apply #'update-dependent class dependent initargs)))) + (lambda (dependent) + (apply #'update-dependent class dependent initargs)))) + +(defmethod reinitialize-instance :after ((class condition-class) &key) + (let* ((name (class-name class)) + (classoid (find-classoid name)) + (slots (condition-classoid-slots classoid))) + ;; to balance the REMOVE-SLOT-ACCESSORS call in + ;; REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS). + (dolist (slot slots) + (let ((slot-name (condition-slot-name slot))) + (dolist (reader (condition-slot-readers slot)) + ;; FIXME: see comment in SHARED-INITIALIZE :AFTER + ;; (CONDITION-CLASS T), below. -- CSR, 2005-11-18 + (sb-kernel::install-condition-slot-reader reader name slot-name)) + (dolist (writer (condition-slot-writers slot)) + (sb-kernel::install-condition-slot-writer writer name slot-name)))))) (defmethod shared-initialize :after ((class condition-class) slot-names - &key direct-slots direct-superclasses) + &key direct-slots direct-superclasses) (declare (ignore slot-names)) (let ((classoid (find-classoid (class-name class)))) (with-slots (wrapper class-precedence-list cpl-available-p prototype predicate-name - (direct-supers direct-superclasses)) - class + (direct-supers direct-superclasses)) + class (setf (slot-value class 'direct-slots) - (mapcar (lambda (pl) (make-direct-slotd class pl)) - direct-slots)) + (mapcar (lambda (pl) (make-direct-slotd class pl)) + direct-slots)) (setf (slot-value class 'finalized-p) t) (setf (classoid-pcl-class classoid) class) (setq direct-supers direct-superclasses) @@ -539,15 +555,23 @@ ;; We don't ADD-SLOT-ACCESSORS here because we don't want to ;; override condition accessors with generic functions. We do this ;; differently. + ;; + ;; ??? What does the above comment mean and why is it a good idea? + ;; CMUCL (which still as of 2005-11-18 uses this code and has this + ;; comment) loses slot information in its condition classes: + ;; DIRECT-SLOTS is always NIL. We have the right information, so we + ;; remove slot accessors but never put them back. I've added a + ;; REINITIALIZE-INSTANCE :AFTER (CONDITION-CLASS) method, but what + ;; was meant to happen? -- CSR, 2005-11-18 (update-pv-table-cache-info class)) (defmethod direct-slot-definition-class ((class condition-class) - &rest initargs) + &rest initargs) (declare (ignore initargs)) (find-class 'condition-direct-slot-definition)) (defmethod effective-slot-definition-class ((class condition-class) - &rest initargs) + &rest initargs) (declare (ignore initargs)) (find-class 'condition-effective-slot-definition)) @@ -559,30 +583,30 @@ ((class condition-class) slot-name dslotds) (let ((slotd (call-next-method))) (setf (slot-definition-reader-function slotd) - (lambda (x) - (handler-case (condition-reader-function x slot-name) - ;; FIXME: FIND-SLOT-DEFAULT throws an error if the slot - ;; is unbound; maybe it should be a CELL-ERROR of some - ;; sort? - (error () (values (slot-unbound class x slot-name)))))) + (lambda (x) + (handler-case (condition-reader-function x slot-name) + ;; FIXME: FIND-SLOT-DEFAULT throws an error if the slot + ;; is unbound; maybe it should be a CELL-ERROR of some + ;; sort? + (error () (values (slot-unbound class x slot-name)))))) (setf (slot-definition-writer-function slotd) - (lambda (v x) - (condition-writer-function x v slot-name))) + (lambda (v x) + (condition-writer-function x v slot-name))) (setf (slot-definition-boundp-function slotd) - (lambda (x) - (multiple-value-bind (v c) - (ignore-errors (condition-reader-function x slot-name)) - (declare (ignore v)) - (null c)))) + (lambda (x) + (multiple-value-bind (v c) + (ignore-errors (condition-reader-function x slot-name)) + (declare (ignore v)) + (null c)))) slotd)) (defmethod compute-slots ((class condition-class)) (mapcan (lambda (superclass) - (mapcar (lambda (dslotd) - (compute-effective-slot-definition - class (slot-definition-name dslotd) (list dslotd))) - (class-direct-slots superclass))) - (reverse (slot-value class 'class-precedence-list)))) + (mapcar (lambda (dslotd) + (compute-effective-slot-definition + class (slot-definition-name dslotd) (list dslotd))) + (class-direct-slots superclass))) + (reverse (slot-value class 'class-precedence-list)))) (defmethod compute-slots :around ((class condition-class)) (let ((eslotds (call-next-method))) @@ -612,13 +636,13 @@ direct-slots))) (reader-names (mapcar (lambda (slotd) (list 'slot-accessor name - (slot-definition-name slotd) - 'reader)) + (slot-definition-name slotd) + 'reader)) direct-slots)) (writer-names (mapcar (lambda (slotd) (list 'slot-accessor name - (slot-definition-name slotd) - 'writer)) + (slot-definition-name slotd) + 'writer)) direct-slots)) (readers-init (mapcar (lambda (slotd reader-name) @@ -648,15 +672,8 @@ (defun make-defstruct-allocation-function (class) (let ((dd (get-structure-dd (class-name class)))) (lambda () - (let ((instance (%make-instance (dd-length dd))) - (raw-index (dd-raw-index dd))) - (setf (%instance-layout instance) - (sb-kernel::compiler-layout-or-lose (dd-name dd))) - (when raw-index - (setf (%instance-ref instance raw-index) - (make-array (dd-raw-length dd) - :element-type '(unsigned-byte 32)))) - instance)))) + (sb-kernel::%make-instance-with-layout + (sb-kernel::compiler-layout-or-lose (dd-name dd)))))) (defmethod shared-initialize :after ((class structure-class) @@ -668,47 +685,47 @@ (declare (ignore slot-names direct-default-initargs)) (if direct-superclasses-p (setf (slot-value class 'direct-superclasses) - (or direct-superclasses - (setq direct-superclasses - (and (not (eq (class-name class) 'structure-object)) - (list *the-class-structure-object*))))) + (or direct-superclasses + (setq direct-superclasses + (and (not (eq (class-name class) 'structure-object)) + (list *the-class-structure-object*))))) (setq direct-superclasses (slot-value class 'direct-superclasses))) (let* ((name (class-name class)) - (from-defclass-p (slot-value class 'from-defclass-p)) - (defstruct-p (or from-defclass-p (not (structure-type-p name))))) + (from-defclass-p (slot-value class 'from-defclass-p)) + (defstruct-p (or from-defclass-p (not (structure-type-p name))))) (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)) - (accessor - (format-symbol *package* - "~S structure class ~A" - name slot-name))) - (setq pl (list* :defstruct-accessor-symbol - accessor pl)))) - (make-direct-slotd class pl)) - direct-slots))) - (setq direct-slots (slot-value class 'direct-slots))) + (setf (slot-value class 'direct-slots) + (setq direct-slots + (mapcar (lambda (pl) + (when defstruct-p + (let* ((slot-name (getf pl :name)) + (accessor + (format-symbol *package* + "~S structure class ~A" + name slot-name))) + (setq pl (list* :defstruct-accessor-symbol + accessor pl)))) + (make-direct-slotd class pl)) + direct-slots))) + (setq direct-slots (slot-value class 'direct-slots))) (if defstruct-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))) - (setf (slot-value class 'defstruct-constructor) - (make-defstruct-allocation-function class))) + (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 (fboundp 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))) + (setf (slot-value class 'defstruct-constructor) + (make-defstruct-allocation-function class))) (add-direct-subclasses class direct-superclasses) (setf (slot-value class 'class-precedence-list) (compute-class-precedence-list class)) @@ -720,10 +737,10 @@ (setf (slot-value class 'finalized-p) t) (update-pv-table-cache-info class) (setq predicate-name (if predicate-name-p - (setf (slot-value class 'predicate-name) + (setf (slot-value class 'predicate-name) (car predicate-name)) - (or (slot-value class 'predicate-name) - (setf (slot-value class '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) @@ -744,25 +761,31 @@ (defun fix-slot-accessors (class dslotds add/remove) (flet ((fix (gfspec name r/w) - (let ((gf (if (fboundp gfspec) - (without-package-locks - (ensure-generic-function gfspec)) - (ensure-generic-function - gfspec :lambda-list (case r/w - (r '(object)) - (w '(new-value object))))))) - (case r/w - (r (if (eq add/remove 'add) - (add-reader-method class gf name) - (remove-reader-method class gf))) - (w (if (eq add/remove 'add) - (add-writer-method class gf name) - (remove-writer-method class gf))))))) + (let ((gf (cond ((eq add/remove 'add) + (if (fboundp gfspec) + (without-package-locks + (ensure-generic-function gfspec)) + (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)))))) + (when gf + (case r/w + (r (if (eq add/remove 'add) + (add-reader-method class gf name) + (remove-reader-method class gf))) + (w (if (eq add/remove 'add) + (add-writer-method class gf name) + (remove-writer-method class gf)))))))) (dolist (dslotd dslotds) (let ((slot-name (slot-definition-name dslotd))) - (dolist (r (slot-definition-readers dslotd)) + (dolist (r (slot-definition-readers dslotd)) (fix r slot-name 'r)) - (dolist (w (slot-definition-writers dslotd)) + (dolist (w (slot-definition-writers dslotd)) (fix w slot-name 'w)))))) (defun add-direct-subclasses (class supers) @@ -787,7 +810,7 @@ (defun class-has-a-forward-referenced-superclass-p (class) (or (forward-referenced-class-p class) (some #'class-has-a-forward-referenced-superclass-p - (class-direct-superclasses class)))) + (class-direct-superclasses class)))) ;;; This is called by :after shared-initialize whenever a class is initialized ;;; or reinitialized. The class may or may not be finalized. @@ -799,12 +822,12 @@ ;; problems. (without-package-locks (when (and (not finalizep) - (not (class-finalized-p class)) - (not (class-has-a-forward-referenced-superclass-p class))) + (not (class-finalized-p class)) + (not (class-has-a-forward-referenced-superclass-p class))) (finalize-inheritance class) (return-from update-class)) (when (or finalizep (class-finalized-p class) - (not (class-has-a-forward-referenced-superclass-p class))) + (not (class-has-a-forward-referenced-superclass-p class))) (setf (find-class (class-name class)) class) (update-cpl class (compute-class-precedence-list class)) ;; This invocation of UPDATE-SLOTS, in practice, finalizes the @@ -817,21 +840,44 @@ (update-initargs class (compute-default-initargs class)) (update-ctors 'finalize-inheritance :class class)) (unless finalizep - (dolist (sub (class-direct-subclasses class)) (update-class sub nil))))) + (dolist (sub (class-direct-subclasses class)) + (update-class sub nil))))) + +(define-condition cpl-protocol-violation (reference-condition error) + ((class :initarg :class :reader cpl-protocol-violation-class) + (cpl :initarg :cpl :reader cpl-protocol-violation-cpl)) + (:default-initargs :references (list '(:sbcl :node "Metaobject Protocol"))) + (:report + (lambda (c s) + (format s "~@" + (class-name (class-of (cpl-protocol-violation-class c))) + (cpl-protocol-violation-class c) + (eq (class-of (cpl-protocol-violation-class c)) + *the-class-funcallable-standard-class*) + (find-class 'function) + (cpl-protocol-violation-cpl c))))) (defun update-cpl (class cpl) + (when (eq (class-of class) *the-class-standard-class*) + (when (find (find-class 'function) cpl) + (error 'cpl-protocol-violation :class class :cpl cpl))) + (when (eq (class-of class) *the-class-funcallable-standard-class*) + (unless (find (find-class 'function) cpl) + (error 'cpl-protocol-violation :class class :cpl cpl))) (if (class-finalized-p class) (unless (and (equal (class-precedence-list class) cpl) - (dolist (c cpl t) - (when (position :class (class-direct-slots c) - :key #'slot-definition-allocation) - (return nil)))) - ;; comment from the old CMU CL sources: - ;; Need to have the cpl setup before update-lisp-class-layout - ;; is called on CMU CL. - (setf (slot-value class 'class-precedence-list) cpl) + (dolist (c cpl t) + (when (position :class (class-direct-slots c) + :key #'slot-definition-allocation) + (return nil)))) + ;; comment from the old CMU CL sources: + ;; Need to have the cpl setup before update-lisp-class-layout + ;; is called on CMU CL. + (setf (slot-value class 'class-precedence-list) cpl) (setf (slot-value class 'cpl-available-p) t) - (force-cache-flushes class)) + (force-cache-flushes class)) (progn (setf (slot-value class 'class-precedence-list) cpl) (setf (slot-value class 'cpl-available-p) t))) @@ -841,7 +887,7 @@ (when cpl (let ((first (car cpl))) (dolist (c (cdr cpl)) - (pushnew c (slot-value first 'can-precede-list)))) + (pushnew c (slot-value first 'can-precede-list)))) (update-class-can-precede-p (cdr cpl)))) (defun class-can-precede-p (class1 class2) @@ -849,54 +895,54 @@ (defun update-slots (class eslotds) (let ((instance-slots ()) - (class-slots ())) + (class-slots ())) (dolist (eslotd eslotds) (let ((alloc (slot-definition-allocation eslotd))) - (case alloc + (case alloc (:instance (push eslotd instance-slots)) (:class (push eslotd class-slots))))) ;; If there is a change in the shape of the instances then the ;; old class is now obsolete. (let* ((nlayout (mapcar #'slot-definition-name - (sort instance-slots #'< - :key #'slot-definition-location))) - (nslots (length nlayout)) - (nwrapper-class-slots (compute-class-slots class-slots)) - (owrapper (when (class-finalized-p class) - (class-wrapper class))) - (olayout (when owrapper - (wrapper-instance-slots-layout owrapper))) - (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper))) - (nwrapper - (cond ((null owrapper) - (make-wrapper nslots class)) - ((and (equal nlayout olayout) - (not + (sort instance-slots #'< + :key #'slot-definition-location))) + (nslots (length nlayout)) + (nwrapper-class-slots (compute-class-slots class-slots)) + (owrapper (when (class-finalized-p class) + (class-wrapper class))) + (olayout (when owrapper + (wrapper-instance-slots-layout owrapper))) + (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper))) + (nwrapper + (cond ((null owrapper) + (make-wrapper nslots class)) + ((and (equal nlayout olayout) + (not (loop for o in owrapper-class-slots for n in nwrapper-class-slots do (unless (eq (car o) (car n)) (return t))))) - owrapper) - (t - ;; This will initialize the new wrapper to have the - ;; same state as the old wrapper. We will then have - ;; to change that. This may seem like wasted work - ;; (and it is), but the spec requires that we call - ;; MAKE-INSTANCES-OBSOLETE. - (make-instances-obsolete class) - (class-wrapper class))))) + owrapper) + (t + ;; This will initialize the new wrapper to have the + ;; same state as the old wrapper. We will then have + ;; to change that. This may seem like wasted work + ;; (and it is), but the spec requires that we call + ;; MAKE-INSTANCES-OBSOLETE. + (make-instances-obsolete class) + (class-wrapper class))))) (with-slots (wrapper slots) class - (update-lisp-class-layout class nwrapper) - (setf slots eslotds - (wrapper-instance-slots-layout nwrapper) nlayout - (wrapper-class-slots nwrapper) nwrapper-class-slots - (wrapper-no-of-instance-slots nwrapper) nslots - wrapper nwrapper)) + (update-lisp-class-layout class nwrapper) + (setf slots eslotds + (wrapper-instance-slots-layout nwrapper) nlayout + (wrapper-class-slots nwrapper) nwrapper-class-slots + (wrapper-no-of-instance-slots nwrapper) nslots + wrapper nwrapper)) (setf (slot-value class 'finalized-p) t) (unless (eq owrapper nwrapper) - (update-pv-table-cache-info class) - (maybe-update-standard-class-locations class))))) + (update-pv-table-cache-info class) + (maybe-update-standard-class-locations class))))) (defun compute-class-slots (eslotds) (let (collect) @@ -908,27 +954,27 @@ (defun update-gfs-of-class (class) (when (and (class-finalized-p class) - (let ((cpl (class-precedence-list class))) - (or (member *the-class-slot-class* cpl) - (member *the-class-standard-effective-slot-definition* - cpl)))) + (let ((cpl (class-precedence-list class))) + (or (member *the-class-slot-class* cpl) + (member *the-class-standard-effective-slot-definition* + cpl)))) (let ((gf-table (make-hash-table :test 'eq))) (labels ((collect-gfs (class) - (dolist (gf (specializer-direct-generic-functions class)) - (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)) - gf-table))))) + (dolist (gf (specializer-direct-generic-functions class)) + (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)) + gf-table))))) (defun update-initargs (class inits) (setf (plist-value class 'default-initargs) inits)) (defmethod compute-default-initargs ((class slot-class)) (let ((initargs (loop for c in (class-precedence-list class) - append (class-direct-default-initargs c)))) + append (class-direct-default-initargs c)))) (delete-duplicates initargs :test #'eq :key #'car :from-end t))) ;;;; protocols for constructing direct and effective slot definitions @@ -943,121 +989,89 @@ :class class initargs)) -(defmethod compute-slots ((class std-class)) +;;; I (CSR) am not sure, but I believe that the particular order of +;;; slots is quite important: it is ideal to attempt to have a +;;; constant slot location for the same notional slots as much as +;;; possible, so that clever discriminating functions (ONE-INDEX et +;;; al.) have a chance of working. The below at least walks through +;;; the slots predictably, but maybe it would be good to compute some +;;; kind of optimal slot layout by looking at locations of slots in +;;; superclasses? +(defun std-compute-slots (class) ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once ;; for each different slot name we find in our superclasses. Each ;; call receives the class and a list of the dslotds with that name. ;; The list is in most-specific-first order. (let ((name-dslotds-alist ())) - (dolist (c (class-precedence-list class)) + (dolist (c (reverse (class-precedence-list class))) (dolist (slot (class-direct-slots c)) - (let* ((name (slot-definition-name slot)) - (entry (assq name name-dslotds-alist))) - (if entry - (push slot (cdr entry)) - (push (list name slot) name-dslotds-alist))))) + (let* ((name (slot-definition-name slot)) + (entry (assq name name-dslotds-alist))) + (if entry + (push slot (cdr entry)) + (push (list name slot) name-dslotds-alist))))) (mapcar (lambda (direct) - (compute-effective-slot-definition class - (car direct) - (nreverse (cdr direct)))) - name-dslotds-alist))) + (compute-effective-slot-definition class + (car direct) + (cdr direct))) + (nreverse name-dslotds-alist)))) (defmethod compute-slots ((class standard-class)) - (call-next-method)) + (std-compute-slots class)) +(defmethod compute-slots ((class funcallable-standard-class)) + (std-compute-slots class)) -(defmethod compute-slots :around ((class standard-class)) - (let ((eslotds (call-next-method)) - (location -1)) +(defun std-compute-slots-around (class eslotds) + (let ((location -1)) (dolist (eslotd eslotds eslotds) (setf (slot-definition-location eslotd) - (case (slot-definition-allocation eslotd) - (:instance - (incf location)) - (:class - (let* ((name (slot-definition-name eslotd)) - (from-class - (or - (slot-definition-allocation-class eslotd) - ;; we get here if the user adds an extra slot - ;; himself... - (setf (slot-definition-allocation-class eslotd) - class))) - ;; which raises the question of what we should - ;; do if we find that said user has added a slot - ;; with the same name as another slot... - (cell (or (assq name (class-slot-cells from-class)) - (setf (class-slot-cells from-class) - (cons (cons name +slot-unbound+) - (class-slot-cells from-class)))))) - (aver (consp cell)) - (if (eq +slot-unbound+ (cdr cell)) - ;; We may have inherited an initfunction - (let ((initfun (slot-definition-initfunction eslotd))) - (if initfun - (rplacd cell (funcall initfun)) - cell)) - cell))))) + (case (slot-definition-allocation eslotd) + (:instance + (incf location)) + (:class + (let* ((name (slot-definition-name eslotd)) + (from-class + (or + (slot-definition-allocation-class eslotd) + ;; we get here if the user adds an extra slot + ;; himself... + (setf (slot-definition-allocation-class eslotd) + class))) + ;; which raises the question of what we should + ;; do if we find that said user has added a slot + ;; with the same name as another slot... + (cell (or (assq name (class-slot-cells from-class)) + (setf (class-slot-cells from-class) + (cons (cons name +slot-unbound+) + (class-slot-cells from-class)))))) + (aver (consp cell)) + (if (eq +slot-unbound+ (cdr cell)) + ;; We may have inherited an initfunction + (let ((initfun (slot-definition-initfunction eslotd))) + (if initfun + (rplacd cell (funcall initfun)) + cell)) + cell))))) (unless (slot-definition-class eslotd) - (setf (slot-definition-class eslotd) class)) + (setf (slot-definition-class eslotd) class)) (initialize-internal-slot-functions eslotd)))) -(defmethod compute-slots ((class funcallable-standard-class)) - (call-next-method)) - +(defmethod compute-slots :around ((class standard-class)) + (let ((eslotds (call-next-method))) + (std-compute-slots-around class eslotds))) (defmethod compute-slots :around ((class funcallable-standard-class)) - (labels ((instance-slot-names (slotds) - (let (collect) - (dolist (slotd slotds (nreverse collect)) - (when (eq (slot-definition-allocation slotd) :instance) - (push (slot-definition-name slotd) collect))))) - ;; This sorts slots so that slots of classes later in the CPL - ;; come before slots of other classes. This is crucial for - ;; funcallable instances because it ensures that the slots of - ;; FUNCALLABLE-STANDARD-OBJECT, which includes the slots of - ;; KERNEL:FUNCALLABLE-INSTANCE, come first, which in turn - ;; makes it possible to treat FUNCALLABLE-STANDARD-OBJECT as - ;; a funcallable instance. - (compute-layout (eslotds) - (let ((first ()) - (names (instance-slot-names eslotds))) - (dolist (class - (reverse (class-precedence-list class)) - (nreverse (nconc names first))) - (dolist (ss (class-slots class)) - (let ((name (slot-definition-name ss))) - (when (member name names) - (push name first) - (setq names (delete name names))))))))) - (let ((all-slotds (call-next-method)) - (instance-slots ()) - (class-slots ())) - (dolist (slotd all-slotds) - (case (slot-definition-allocation slotd) - (:instance (push slotd instance-slots)) - (:class (push slotd class-slots)))) - (let ((layout (compute-layout instance-slots))) - (dolist (slotd instance-slots) - (setf (slot-definition-location slotd) - (position (slot-definition-name slotd) layout)) - (initialize-internal-slot-functions slotd))) - (dolist (slotd class-slots) - (let ((name (slot-definition-name slotd)) - (from-class (slot-definition-allocation-class slotd))) - (setf (slot-definition-location slotd) - (assoc name (class-slot-cells from-class))) - (aver (consp (slot-definition-location slotd))) - (initialize-internal-slot-functions slotd))) - all-slotds))) + (let ((eslotds (call-next-method))) + (std-compute-slots-around class eslotds))) (defmethod compute-slots ((class structure-class)) (mapcan (lambda (superclass) - (mapcar (lambda (dslotd) - (compute-effective-slot-definition - class - (slot-definition-name dslotd) - (list dslotd))) - (class-direct-slots superclass))) - (reverse (slot-value class 'class-precedence-list)))) + (mapcar (lambda (dslotd) + (compute-effective-slot-definition + class + (slot-definition-name dslotd) + (list dslotd))) + (class-direct-slots superclass))) + (reverse (slot-value class 'class-precedence-list)))) (defmethod compute-slots :around ((class structure-class)) (let ((eslotds (call-next-method))) @@ -1067,7 +1081,7 @@ (defmethod compute-effective-slot-definition ((class slot-class) name dslotds) (declare (ignore name)) (let* ((initargs (compute-effective-slot-definition-initargs class dslotds)) - (class (apply #'effective-slot-definition-class class initargs))) + (class (apply #'effective-slot-definition-class class initargs))) (apply #'make-instance class initargs))) (defmethod effective-slot-definition-class ((class std-class) &rest initargs) @@ -1081,54 +1095,61 @@ (defmethod compute-effective-slot-definition-initargs ((class slot-class) direct-slotds) (let* ((name nil) - (initfunction nil) - (initform nil) - (initargs nil) - (allocation nil) - (allocation-class nil) - (type t) - (namep nil) - (initp nil) - (allocp nil)) + (initfunction nil) + (initform nil) + (initargs nil) + (allocation nil) + (allocation-class nil) + (type t) + (documentation nil) + (documentationp nil) + (namep nil) + (initp nil) + (allocp nil)) (dolist (slotd direct-slotds) (when slotd - (unless namep - (setq name (slot-definition-name slotd) - namep t)) - (unless initp - (when (slot-definition-initfunction slotd) - (setq initform (slot-definition-initform slotd) - initfunction (slot-definition-initfunction slotd) - initp t))) - (unless allocp - (setq allocation (slot-definition-allocation slotd) - allocation-class (slot-definition-class slotd) - allocp t)) - (setq initargs (append (slot-definition-initargs slotd) initargs)) - (let ((slotd-type (slot-definition-type slotd))) - (setq type (cond ((eq type t) slotd-type) - ((*subtypep type slotd-type) type) - (t `(and ,type ,slotd-type))))))) + (unless namep + (setq name (slot-definition-name slotd) + namep t)) + (unless initp + (when (slot-definition-initfunction slotd) + (setq initform (slot-definition-initform slotd) + initfunction (slot-definition-initfunction slotd) + initp t))) + (unless documentationp + (when (%slot-definition-documentation slotd) + (setq documentation (%slot-definition-documentation slotd) + documentationp t))) + (unless allocp + (setq allocation (slot-definition-allocation slotd) + allocation-class (slot-definition-class slotd) + allocp t)) + (setq initargs (append (slot-definition-initargs slotd) initargs)) + (let ((slotd-type (slot-definition-type slotd))) + (setq type (cond ((eq type t) slotd-type) + ((*subtypep type slotd-type) type) + (t `(and ,type ,slotd-type))))))) (list :name name - :initform initform - :initfunction initfunction - :initargs initargs - :allocation allocation - :allocation-class allocation-class - :type type - :class class))) + :initform initform + :initfunction initfunction + :initargs initargs + :allocation allocation + :allocation-class allocation-class + :type type + :class class + :documentation documentation))) (defmethod compute-effective-slot-definition-initargs :around ((class structure-class) direct-slotds) (let ((slotd (car direct-slotds))) (list* :defstruct-accessor-symbol - (slot-definition-defstruct-accessor-symbol slotd) - :internal-reader-function - (slot-definition-internal-reader-function slotd) - :internal-writer-function - (slot-definition-internal-writer-function slotd) - (call-next-method)))) + (slot-definition-defstruct-accessor-symbol slotd) + :internal-reader-function + (slot-definition-internal-reader-function slotd) + :internal-writer-function + (slot-definition-internal-writer-function slotd) + (call-next-method)))) ;;; NOTE: For bootstrapping considerations, these can't use MAKE-INSTANCE ;;; to make the method object. They have to use make-a-method which @@ -1139,13 +1160,13 @@ (defmethod add-reader-method ((class slot-class) generic-function slot-name) (add-method generic-function - (make-a-method 'standard-reader-method - () - (list (or (class-name class) 'object)) - (list class) - (make-reader-method-function class slot-name) - "automatically generated reader method" - slot-name))) + (make-a-method 'standard-reader-method + () + (list (or (class-name class) 'object)) + (list class) + (make-reader-method-function class slot-name) + "automatically generated reader method" + slot-name))) (defmethod writer-method-class ((class slot-class) direct-slot &rest initargs) (declare (ignore direct-slot initargs)) @@ -1153,23 +1174,23 @@ (defmethod add-writer-method ((class slot-class) generic-function slot-name) (add-method generic-function - (make-a-method 'standard-writer-method - () - (list 'new-value (or (class-name class) 'object)) - (list *the-class-t* class) - (make-writer-method-function class slot-name) - "automatically generated writer method" - slot-name))) + (make-a-method 'standard-writer-method + () + (list 'new-value (or (class-name class) 'object)) + (list *the-class-t* class) + (make-writer-method-function class slot-name) + "automatically generated writer method" + slot-name))) (defmethod add-boundp-method ((class slot-class) generic-function slot-name) (add-method generic-function - (make-a-method 'standard-boundp-method - () - (list (or (class-name class) 'object)) - (list class) - (make-boundp-method-function class slot-name) - "automatically generated boundp method" - slot-name))) + (make-a-method 'standard-boundp-method + () + (list (or (class-name class) 'object)) + (list class) + (make-boundp-method-function class slot-name) + "automatically generated boundp method" + slot-name))) (defmethod remove-reader-method ((class slot-class) generic-function) (let ((method (get-method generic-function () (list class) nil))) @@ -1177,16 +1198,17 @@ (defmethod remove-writer-method ((class slot-class) generic-function) (let ((method - (get-method generic-function () (list *the-class-t* class) nil))) + (get-method generic-function () (list *the-class-t* class) nil))) (when method (remove-method generic-function method)))) (defmethod remove-boundp-method ((class slot-class) generic-function) (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 @@ -1209,14 +1231,13 @@ (defmethod compatible-meta-class-change-p (class proto-new-class) (eq (class-of class) (class-of proto-new-class))) -(defmethod validate-superclass ((class class) (new-super class)) - (or (eq new-super *the-class-t*) - (eq (class-of class) (class-of new-super)))) - -(defmethod validate-superclass ((class standard-class) (new-super std-class)) - (let ((new-super-meta-class (class-of new-super))) - (or (eq new-super-meta-class *the-class-std-class*) - (eq (class-of class) new-super-meta-class)))) +(defmethod validate-superclass ((class class) (superclass class)) + (or (eq superclass *the-class-t*) + (eq (class-of class) (class-of superclass)) + (and (eq (class-of superclass) *the-class-standard-class*) + (eq (class-of class) *the-class-funcallable-standard-class*)) + (and (eq (class-of superclass) *the-class-funcallable-standard-class*) + (eq (class-of class) *the-class-standard-class*)))) ;;; What this does depends on which of the four possible values of ;;; LAYOUT-INVALID the PCL wrapper has; the simplest case is when it @@ -1245,28 +1266,28 @@ ;; particular, we must be sure we never change an OBSOLETE into a ;; FLUSH since OBSOLETE means do what FLUSH does and then some. (when (or (not (invalid-wrapper-p owrapper)) - ;; KLUDGE: despite the observations above, this remains - ;; a violation of locality or what might be considered - ;; good style. There has to be a better way! -- CSR, - ;; 2002-10-29 - (eq (layout-invalid owrapper) t)) + ;; KLUDGE: despite the observations above, this remains + ;; a violation of locality or what might be considered + ;; good style. There has to be a better way! -- CSR, + ;; 2002-10-29 + (eq (layout-invalid owrapper) t)) (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper) - class))) - (setf (wrapper-instance-slots-layout nwrapper) - (wrapper-instance-slots-layout owrapper)) - (setf (wrapper-class-slots nwrapper) - (wrapper-class-slots owrapper)) - (with-pcl-lock - (update-lisp-class-layout class nwrapper) - (setf (slot-value class 'wrapper) nwrapper) - ;; Use :OBSOLETE instead of :FLUSH if any superclass has - ;; been obsoleted. - (if (find-if (lambda (x) - (and (consp x) (eq :obsolete (car x)))) - (layout-inherits owrapper) - :key #'layout-invalid) - (invalidate-wrapper owrapper :obsolete nwrapper) - (invalidate-wrapper owrapper :flush nwrapper))))))) + class))) + (setf (wrapper-instance-slots-layout nwrapper) + (wrapper-instance-slots-layout owrapper)) + (setf (wrapper-class-slots nwrapper) + (wrapper-class-slots owrapper)) + (with-pcl-lock + (update-lisp-class-layout class nwrapper) + (setf (slot-value class 'wrapper) nwrapper) + ;; Use :OBSOLETE instead of :FLUSH if any superclass has + ;; been obsoleted. + (if (find-if (lambda (x) + (and (consp x) (eq :obsolete (car x)))) + (layout-inherits owrapper) + :key #'layout-invalid) + (invalidate-wrapper owrapper :obsolete nwrapper) + (invalidate-wrapper owrapper :flush nwrapper))))))) (defun flush-cache-trap (owrapper nwrapper instance) (declare (ignore owrapper)) @@ -1277,17 +1298,17 @@ ;;; through the UPDATE-INSTANCE-FOR-REDEFINED-CLASS mechanism. (defmethod make-instances-obsolete ((class std-class)) (let* ((owrapper (class-wrapper class)) - (nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper) - class))) + (nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper) + class))) (setf (wrapper-instance-slots-layout nwrapper) - (wrapper-instance-slots-layout owrapper)) + (wrapper-instance-slots-layout owrapper)) (setf (wrapper-class-slots nwrapper) - (wrapper-class-slots owrapper)) + (wrapper-class-slots owrapper)) (with-pcl-lock - (update-lisp-class-layout class nwrapper) - (setf (slot-value class 'wrapper) nwrapper) - (invalidate-wrapper owrapper :obsolete nwrapper) - class))) + (update-lisp-class-layout class nwrapper) + (setf (slot-value class 'wrapper) nwrapper) + (invalidate-wrapper owrapper :obsolete nwrapper) + class))) (defmethod make-instances-obsolete ((class symbol)) (make-instances-obsolete (find-class class)) @@ -1331,45 +1352,45 @@ (lambda (condition stream) ;; Don't try to print the structure, since it probably won't work. (format stream - "~@" - (type-of (obsolete-structure-datum condition)))))) + "~@" + (type-of (obsolete-structure-datum condition)))))) (defun obsolete-instance-trap (owrapper nwrapper instance) (if (not (pcl-instance-p instance)) (if *in-obsolete-instance-trap* - *the-wrapper-of-structure-object* - (let ((*in-obsolete-instance-trap* t)) - (error 'obsolete-structure :datum instance))) + *the-wrapper-of-structure-object* + (let ((*in-obsolete-instance-trap* t)) + (error 'obsolete-structure :datum instance))) (let* ((class (wrapper-class* nwrapper)) - (copy (allocate-instance class)) ;??? allocate-instance ??? - (olayout (wrapper-instance-slots-layout owrapper)) - (nlayout (wrapper-instance-slots-layout nwrapper)) - (oslots (get-slots instance)) - (nslots (get-slots copy)) - (oclass-slots (wrapper-class-slots owrapper)) - (added ()) - (discarded ()) - (plist ())) + (copy (allocate-instance class)) ;??? allocate-instance ??? + (olayout (wrapper-instance-slots-layout owrapper)) + (nlayout (wrapper-instance-slots-layout nwrapper)) + (oslots (get-slots instance)) + (nslots (get-slots copy)) + (oclass-slots (wrapper-class-slots owrapper)) + (added ()) + (discarded ()) + (plist ())) - ;; local --> local transfer value - ;; local --> shared discard value, discard slot - ;; local --> -- discard slot - ;; shared --> local transfer value - ;; shared --> shared -- (cf SHARED-INITIALIZE :AFTER STD-CLASS) - ;; shared --> -- discard value - ;; -- --> local add slot - ;; -- --> shared -- + ;; local --> local transfer value + ;; local --> shared discard value, discard slot + ;; local --> -- discard slot + ;; shared --> local transfer value + ;; shared --> shared -- (cf SHARED-INITIALIZE :AFTER STD-CLASS) + ;; shared --> -- discard value + ;; -- --> local add slot + ;; -- --> shared -- - ;; Collect class slots from inherited wrappers. Needed for - ;; shared -> local transfers of inherited slots. - (let ((inherited (layout-inherits owrapper))) - (loop for i from (1- (length inherited)) downto 0 - for layout = (aref inherited i) - when (typep layout 'wrapper) - do (dolist (slot (wrapper-class-slots layout)) - (pushnew slot oclass-slots :key #'car)))) + ;; Collect class slots from inherited wrappers. Needed for + ;; shared -> local transfers of inherited slots. + (let ((inherited (layout-inherits owrapper))) + (loop for i from (1- (length inherited)) downto 0 + for layout = (aref inherited i) + when (typep layout 'wrapper) + do (dolist (slot (wrapper-class-slots layout)) + (pushnew slot oclass-slots :key #'car)))) - ;; Go through all the old local slots. + ;; Go through all the old local slots. (let ((opos 0)) (dolist (name olayout) (let ((npos (posq name nlayout))) @@ -1382,38 +1403,38 @@ (setf (getf plist name) (clos-slots-ref oslots opos)))))) (incf opos))) - ;; Go through all the old shared slots. + ;; Go through all the old shared slots. (dolist (oclass-slot-and-val oclass-slots) - (let ((name (car oclass-slot-and-val)) - (val (cdr oclass-slot-and-val))) - (let ((npos (posq name nlayout))) - (when npos - (setf (clos-slots-ref nslots npos) val))))) + (let ((name (car oclass-slot-and-val)) + (val (cdr oclass-slot-and-val))) + (let ((npos (posq name nlayout))) + (when npos + (setf (clos-slots-ref nslots npos) val))))) - ;; Go through all the new local slots to compute the added slots. - (dolist (nlocal nlayout) - (unless (or (memq nlocal olayout) - (assq nlocal oclass-slots)) - (push nlocal added))) + ;; Go through all the new local slots to compute the added slots. + (dolist (nlocal nlayout) + (unless (or (memq nlocal olayout) + (assq nlocal oclass-slots)) + (push nlocal added))) - (swap-wrappers-and-slots instance copy) + (swap-wrappers-and-slots instance copy) - (update-instance-for-redefined-class instance - added - discarded - plist) - nwrapper))) + (update-instance-for-redefined-class instance + added + discarded + plist) + nwrapper))) (defun change-class-internal (instance new-class initargs) (let* ((old-class (class-of instance)) - (copy (allocate-instance new-class)) - (new-wrapper (get-wrapper copy)) - (old-wrapper (class-wrapper old-class)) - (old-layout (wrapper-instance-slots-layout old-wrapper)) - (new-layout (wrapper-instance-slots-layout new-wrapper)) - (old-slots (get-slots instance)) - (new-slots (get-slots copy)) - (old-class-slots (wrapper-class-slots old-wrapper))) + (copy (allocate-instance new-class)) + (new-wrapper (get-wrapper copy)) + (old-wrapper (class-wrapper old-class)) + (old-layout (wrapper-instance-slots-layout old-wrapper)) + (new-layout (wrapper-instance-slots-layout new-wrapper)) + (old-slots (get-slots instance)) + (new-slots (get-slots copy)) + (old-class-slots (wrapper-class-slots old-wrapper))) ;; "The values of local slots specified by both the class CTO and ;; CFROM are retained. If such a local slot was unbound, it @@ -1424,14 +1445,14 @@ (when old-position (setf (clos-slots-ref new-slots new-position) (clos-slots-ref old-slots old-position)))) - (incf new-position))) + (incf new-position))) ;; "The values of slots specified as shared in the class CFROM and ;; as local in the class CTO are retained." (dolist (slot-and-val old-class-slots) (let ((position (posq (car slot-and-val) new-layout))) - (when position - (setf (clos-slots-ref new-slots position) (cdr slot-and-val))))) + (when position + (setf (clos-slots-ref new-slots position) (cdr slot-and-val))))) ;; Make the copy point to the old instance's storage, and make the ;; old instance point to the new storage. @@ -1440,31 +1461,72 @@ (apply #'update-instance-for-different-class copy instance initargs) instance)) -(defmethod change-class ((instance standard-object) - (new-class standard-class) - &rest initargs) +(defmethod change-class ((instance standard-object) (new-class standard-class) + &rest initargs) + (let ((cpl (class-precedence-list new-class))) + (dolist (class cpl) + (macrolet + ((frob (class-name) + `(when (eq class (find-class ',class-name)) + (error 'metaobject-initialization-violation + :format-control "~@" + :format-arguments (list 'change-class ',class-name) + :references (list '(:amop :initialization ,class-name)))))) + (frob class) + (frob generic-function) + (frob method) + (frob slot-definition)))) + (change-class-internal instance new-class initargs)) + +(defmethod change-class ((instance forward-referenced-class) + (new-class standard-class) &rest initargs) + (let ((cpl (class-precedence-list new-class))) + (dolist (class cpl + (error 'metaobject-initialization-violation + :format-control + "~@" + :format-arguments + (list 'change-class 'forward-referenced-class 'class) + :references + (list '(:amop :generic-function ensure-class-using-class) + '(:amop :initialization class)))) + (when (eq class (find-class 'class)) + (return nil)))) (change-class-internal instance new-class initargs)) (defmethod change-class ((instance funcallable-standard-object) - (new-class funcallable-standard-class) - &rest initargs) + (new-class funcallable-standard-class) + &rest initargs) + (let ((cpl (class-precedence-list new-class))) + (dolist (class cpl) + (macrolet + ((frob (class-name) + `(when (eq class (find-class ',class-name)) + (error 'metaobject-initialization-violation + :format-control "~@" + :format-arguments (list 'change-class ',class-name) + :references (list '(:amop :initialization ,class-name)))))) + (frob class) + (frob generic-function) + (frob method) + (frob slot-definition)))) (change-class-internal instance new-class initargs)) (defmethod change-class ((instance standard-object) - (new-class funcallable-standard-class) - &rest initargs) + (new-class funcallable-standard-class) + &rest initargs) (declare (ignore initargs)) (error "You can't change the class of ~S to ~S~@ - because it isn't already an instance with metaclass ~S." - instance new-class 'standard-class)) + because it isn't already an instance with metaclass ~S." + instance new-class 'standard-class)) (defmethod change-class ((instance funcallable-standard-object) - (new-class standard-class) - &rest initargs) + (new-class standard-class) + &rest initargs) (declare (ignore initargs)) (error "You can't change the class of ~S to ~S~@ - because it isn't already an instance with metaclass ~S." - instance new-class 'funcallable-standard-class)) + because it isn't already an instance with metaclass ~S." + instance new-class 'funcallable-standard-class)) (defmethod change-class ((instance t) (new-class-name symbol) &rest initargs) (apply #'change-class instance (find-class new-class-name) initargs)) @@ -1478,19 +1540,32 @@ ;;;; But, there are other parts of the protocol we must follow and those ;;;; definitions appear here. -(defmethod shared-initialize :before - ((class built-in-class) slot-names &rest initargs) - (declare (ignore slot-names initargs)) - (error "attempt to initialize or reinitialize a built in class")) +(macrolet ((def (name args control) + `(defmethod ,name ,args + (declare (ignore initargs)) + (error 'metaobject-initialization-violation + :format-control ,(format nil "~@<~A~@:>" control) + :format-arguments (list ',name) + :references (list '(:amop :initialization "Class")))))) + (def initialize-instance ((class built-in-class) &rest initargs) + "Cannot ~S an instance of BUILT-IN-CLASS.") + (def reinitialize-instance ((class built-in-class) &rest initargs) + "Cannot ~S an instance of BUILT-IN-CLASS.")) -(defmethod class-direct-slots ((class built-in-class)) ()) -(defmethod class-slots ((class built-in-class)) ()) -(defmethod class-direct-default-initargs ((class built-in-class)) ()) -(defmethod class-default-initargs ((class built-in-class)) ()) +(macrolet ((def (name) + `(defmethod ,name ((class built-in-class)) nil))) + (def class-direct-slots) + (def class-slots) + (def class-direct-default-initargs) + (def class-default-initargs)) (defmethod validate-superclass ((c class) (s built-in-class)) - (or (eq s *the-class-t*) - (eq s *the-class-stream*))) + (or (eq s *the-class-t*) (eq s *the-class-stream*) + ;; FIXME: bad things happen if someone tries to mix in both + ;; FILE-STREAM and STRING-STREAM (as they have the same + ;; layout-depthoid). Is there any way we can provide a useful + ;; error message? -- CSR, 2005-05-03 + (eq s *the-class-file-stream*) (eq s *the-class-string-stream*))) ;;; Some necessary methods for FORWARD-REFERENCED-CLASS (defmethod class-direct-slots ((class forward-referenced-class)) ()) @@ -1504,7 +1579,7 @@ (def class-slots)) (defmethod validate-superclass ((c slot-class) - (f forward-referenced-class)) + (f forward-referenced-class)) t) (defmethod add-dependent ((metaobject dependent-update-mixin) dependent) @@ -1512,7 +1587,7 @@ (defmethod remove-dependent ((metaobject dependent-update-mixin) dependent) (setf (plist-value metaobject 'dependents) - (delete dependent (plist-value metaobject 'dependents)))) + (delete dependent (plist-value metaobject 'dependents)))) (defmethod map-dependents ((metaobject dependent-update-mixin) function) (dolist (dependent (plist-value metaobject 'dependents)) diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 9a8f51d4d..179cd9e5f 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -30,16 +30,16 @@ (declare (fixnum pos)) (block loop (dolist (sn (wrapper-instance-slots-layout ,wrapper)) - (when (eq ,slot-name sn) (return-from loop pos)) - (incf pos))))) + (when (eq ,slot-name sn) (return-from loop pos)) + (incf pos))))) (defun pv-cache-limit-fn (nlines) (default-limit-fn nlines)) (defstruct (pv-table (:predicate pv-tablep) - (:constructor make-pv-table-internal - (slot-name-lists call-list)) - (:copier nil)) + (:constructor make-pv-table-internal + (slot-name-lists call-list)) + (:copier nil)) (cache nil :type (or cache null)) (pv-size 0 :type fixnum) (slot-name-lists nil :type list) @@ -69,63 +69,63 @@ (defun intern-pv-table (&key slot-name-lists call-list) (let ((new-p nil)) (flet ((inner (x) - (or (gethash x *slot-name-lists-inner*) - (setf (gethash x *slot-name-lists-inner*) (copy-list x)))) - (outer (x) - (or (gethash x *slot-name-lists-outer*) - (setf (gethash x *slot-name-lists-outer*) - (let ((snl (copy-list (cdr x))) - (cl (car x))) - (setq new-p t) - (make-pv-table :slot-name-lists snl - :call-list cl)))))) + (or (gethash x *slot-name-lists-inner*) + (setf (gethash x *slot-name-lists-inner*) (copy-list x)))) + (outer (x) + (or (gethash x *slot-name-lists-outer*) + (setf (gethash x *slot-name-lists-outer*) + (let ((snl (copy-list (cdr x))) + (cl (car x))) + (setq new-p t) + (make-pv-table :slot-name-lists snl + :call-list cl)))))) (let ((pv-table (outer (mapcar #'inner (cons call-list slot-name-lists))))) (when new-p - (let ((pv-index 1)) - (dolist (slot-name-list slot-name-lists) - (dolist (slot-name (cdr slot-name-list)) - (note-pv-table-reference slot-name pv-index pv-table) - (incf pv-index))) - (dolist (gf-call call-list) - (note-pv-table-reference gf-call pv-index pv-table) - (incf pv-index)) - (setf (pv-table-pv-size pv-table) pv-index))) + (let ((pv-index 1)) + (dolist (slot-name-list slot-name-lists) + (dolist (slot-name (cdr slot-name-list)) + (note-pv-table-reference slot-name pv-index pv-table) + (incf pv-index))) + (dolist (gf-call call-list) + (note-pv-table-reference gf-call pv-index pv-table) + (incf pv-index)) + (setf (pv-table-pv-size pv-table) pv-index))) pv-table)))) (defun note-pv-table-reference (ref pv-offset pv-table) (let ((entry (gethash ref *pv-key-to-pv-table-table*))) (when (listp entry) (let ((table-entry (assq pv-table entry))) - (when (and (null table-entry) - (> (length entry) 8)) - (let ((new-table-table (make-hash-table :size 16 :test 'eq))) - (dolist (table-entry entry) - (setf (gethash (car table-entry) new-table-table) - (cdr table-entry))) - (setf (gethash ref *pv-key-to-pv-table-table*) new-table-table))) - (when (listp entry) - (if (null table-entry) - (let ((new (cons pv-table pv-offset))) - (if (consp entry) - (push new (cdr entry)) - (setf (gethash ref *pv-key-to-pv-table-table*) - (list new)))) - (push pv-offset (cdr table-entry))) - (return-from note-pv-table-reference nil)))) + (when (and (null table-entry) + (> (length entry) 8)) + (let ((new-table-table (make-hash-table :size 16 :test 'eq))) + (dolist (table-entry entry) + (setf (gethash (car table-entry) new-table-table) + (cdr table-entry))) + (setf (gethash ref *pv-key-to-pv-table-table*) new-table-table))) + (when (listp entry) + (if (null table-entry) + (let ((new (cons pv-table pv-offset))) + (if (consp entry) + (push new (cdr entry)) + (setf (gethash ref *pv-key-to-pv-table-table*) + (list new)))) + (push pv-offset (cdr table-entry))) + (return-from note-pv-table-reference nil)))) (let ((list (gethash pv-table entry))) (if (consp list) - (push pv-offset (cdr list)) - (setf (gethash pv-table entry) (list pv-offset))))) + (push pv-offset (cdr list)) + (setf (gethash pv-table entry) (list pv-offset))))) nil) (defun map-pv-table-references-of (ref function) (let ((entry (gethash ref *pv-key-to-pv-table-table*))) (if (listp entry) - (dolist (table+pv-offset-list entry) - (funcall function - (car table+pv-offset-list) - (cdr table+pv-offset-list))) - (maphash function entry))) + (dolist (table+pv-offset-list entry) + (funcall function + (car table+pv-offset-list) + (cdr table+pv-offset-list))) + (maphash function entry))) ref) (defvar *pvs* (make-hash-table :test 'equal)) @@ -133,41 +133,41 @@ (defun optimize-slot-value-by-class-p (class slot-name type) (or (not (eq *boot-state* 'complete)) (let ((slotd (find-slot-definition class slot-name))) - (and slotd - (slot-accessor-std-p slotd type))))) + (and slotd + (slot-accessor-std-p slotd type))))) (defun compute-pv-slot (slot-name wrapper class class-slots class-slot-p-cell) (if (symbolp slot-name) (when (optimize-slot-value-by-class-p class slot-name 'all) - (or (instance-slot-index wrapper slot-name) - (let ((cell (assq slot-name class-slots))) - (when cell - (setf (car class-slot-p-cell) t) - cell)))) + (or (instance-slot-index wrapper slot-name) + (let ((cell (assq slot-name class-slots))) + (when cell + (setf (car class-slot-p-cell) t) + cell)))) (when (consp slot-name) - (dolist (type '(reader writer) nil) - (when (eq (car slot-name) type) - (return - (let* ((gf-name (cadr slot-name)) - (gf (gdefinition gf-name)) - (location (when (eq *boot-state* 'complete) - (accessor-values1 gf type class)))) - (when (consp location) - (setf (car class-slot-p-cell) t)) - location))))))) + (dolist (type '(reader writer) nil) + (when (eq (car slot-name) type) + (return + (let* ((gf-name (cadr slot-name)) + (gf (gdefinition gf-name)) + (location (when (eq *boot-state* 'complete) + (accessor-values1 gf type class)))) + (when (consp location) + (setf (car class-slot-p-cell) t)) + location))))))) (defun compute-pv (slot-name-lists wrappers) (unless (listp wrappers) (setq wrappers (list wrappers))) (let* ((not-simple-p-cell (list nil)) - (elements + (elements (let ((elements nil)) (dolist (slot-names slot-name-lists) - (when slot-names - (let* ((wrapper (pop wrappers)) - (std-p (typep wrapper 'wrapper)) - (class (wrapper-class* wrapper)) - (class-slots (and std-p (wrapper-class-slots wrapper)))) - (dolist (slot-name (cdr slot-names)) + (when slot-names + (let* ((wrapper (pop wrappers)) + (std-p (typep wrapper 'wrapper)) + (class (wrapper-class* wrapper)) + (class-slots (and std-p (wrapper-class-slots wrapper)))) + (dolist (slot-name (cdr slot-names)) ;; Original PCL code had this idiom. why not: ;; ;; (WHEN STD-P @@ -178,17 +178,17 @@ elements))))) (nreverse elements)))) (if (car not-simple-p-cell) - (make-permutation-vector (cons t elements)) - (or (gethash elements *pvs*) - (setf (gethash elements *pvs*) - (make-permutation-vector (cons nil elements))))))) + (make-permutation-vector (cons t elements)) + (or (gethash elements *pvs*) + (setf (gethash elements *pvs*) + (make-permutation-vector (cons nil elements))))))) (defun compute-calls (call-list wrappers) (declare (ignore call-list wrappers)) #|| (map 'vector (lambda (call) - (compute-emf-from-wrappers call wrappers)) + (compute-emf-from-wrappers call wrappers)) call-list) ||# '#()) @@ -198,19 +198,19 @@ (when call (destructuring-bind (gf-name nreq restp arg-info) call (if (eq gf-name 'make-instance) - (error "should not get here") ; there is another mechanism for this. - (lambda (&rest args) - (if (not (eq *boot-state* 'complete)) - (apply (gdefinition gf-name) args) - (let* ((gf (gdefinition gf-name)) - (arg-info (arg-info-reader gf)) - (classes '?) - (types '?) - (emf (cache-miss-values-internal gf arg-info - wrappers classes types - 'caching))) - (update-all-pv-tables call wrappers emf) - (invoke-emf emf args)))))))) + (error "should not get here") ; there is another mechanism for this. + (lambda (&rest args) + (if (not (eq *boot-state* 'complete)) + (apply (gdefinition gf-name) args) + (let* ((gf (gdefinition gf-name)) + (arg-info (arg-info-reader gf)) + (classes '?) + (types '?) + (emf (cache-miss-values-internal gf arg-info + wrappers classes types + 'caching))) + (update-all-pv-tables call wrappers emf) + (invoke-emf emf args)))))))) ||# (defun make-permutation-vector (indexes) @@ -218,22 +218,22 @@ (defun pv-table-lookup (pv-table pv-wrappers) (let* ((slot-name-lists (pv-table-slot-name-lists pv-table)) - (call-list (pv-table-call-list pv-table)) - (cache (or (pv-table-cache pv-table) - (setf (pv-table-cache pv-table) - (get-cache (- (length slot-name-lists) - (count nil slot-name-lists)) - t - #'pv-cache-limit-fn - 2))))) + (call-list (pv-table-call-list pv-table)) + (cache (or (pv-table-cache pv-table) + (setf (pv-table-cache pv-table) + (get-cache (- (length slot-name-lists) + (count nil slot-name-lists)) + t + #'pv-cache-limit-fn + 2))))) (or (probe-cache cache pv-wrappers) - (let* ((pv (compute-pv slot-name-lists pv-wrappers)) - (calls (compute-calls call-list pv-wrappers)) - (pv-cell (cons pv calls)) - (new-cache (fill-cache cache pv-wrappers pv-cell))) - (unless (eq new-cache cache) - (setf (pv-table-cache pv-table) new-cache)) - pv-cell)))) + (let* ((pv (compute-pv slot-name-lists pv-wrappers)) + (calls (compute-calls call-list pv-wrappers)) + (pv-cell (cons pv calls)) + (new-cache (fill-cache cache pv-wrappers pv-cell))) + (unless (eq new-cache cache) + (setf (pv-table-cache pv-table) new-cache)) + pv-cell)))) (defun make-pv-type-declaration (var) `(type simple-vector ,var)) @@ -256,147 +256,147 @@ (defun update-pv-table-cache-info (class) (let ((slot-names-for-pv-table-update nil) - (new-icui nil)) + (new-icui nil)) (dolist (icu *pv-table-cache-update-info*) (if (eq (car icu) class) - (pushnew (cdr icu) slot-names-for-pv-table-update) - (push icu new-icui))) + (pushnew (cdr icu) slot-names-for-pv-table-update) + (push icu new-icui))) (setq *pv-table-cache-update-info* new-icui) (when slot-names-for-pv-table-update (update-all-pv-table-caches class slot-names-for-pv-table-update)))) (defun update-all-pv-table-caches (class slot-names) (let* ((cwrapper (class-wrapper class)) - (std-p (typep cwrapper 'wrapper)) - (class-slots (and std-p (wrapper-class-slots cwrapper))) - (class-slot-p-cell (list nil)) - (new-values (mapcar (lambda (slot-name) - (cons slot-name - (when std-p - (compute-pv-slot - slot-name cwrapper class - class-slots class-slot-p-cell)))) - slot-names)) - (pv-tables nil)) + (std-p (typep cwrapper 'wrapper)) + (class-slots (and std-p (wrapper-class-slots cwrapper))) + (class-slot-p-cell (list nil)) + (new-values (mapcar (lambda (slot-name) + (cons slot-name + (when std-p + (compute-pv-slot + slot-name cwrapper class + class-slots class-slot-p-cell)))) + slot-names)) + (pv-tables nil)) (dolist (slot-name slot-names) (map-pv-table-references-of slot-name (lambda (pv-table pv-offset-list) - (declare (ignore pv-offset-list)) - (pushnew pv-table pv-tables)))) + (declare (ignore pv-offset-list)) + (pushnew pv-table pv-tables)))) (dolist (pv-table pv-tables) (let* ((cache (pv-table-cache pv-table)) - (slot-name-lists (pv-table-slot-name-lists pv-table)) - (pv-size (pv-table-pv-size pv-table)) - (pv-map (make-array pv-size :initial-element nil))) - (let ((map-index 1) (param-index 0)) - (dolist (slot-name-list slot-name-lists) - (dolist (slot-name (cdr slot-name-list)) - (let ((a (assoc slot-name new-values))) - (setf (svref pv-map map-index) - (and a (cons param-index (cdr a))))) - (incf map-index)) - (incf param-index))) - (when cache - (map-cache (lambda (wrappers pv-cell) - (setf (car pv-cell) - (update-slots-in-pv wrappers (car pv-cell) - cwrapper pv-size pv-map))) - cache)))))) + (slot-name-lists (pv-table-slot-name-lists pv-table)) + (pv-size (pv-table-pv-size pv-table)) + (pv-map (make-array pv-size :initial-element nil))) + (let ((map-index 1) (param-index 0)) + (dolist (slot-name-list slot-name-lists) + (dolist (slot-name (cdr slot-name-list)) + (let ((a (assoc slot-name new-values))) + (setf (svref pv-map map-index) + (and a (cons param-index (cdr a))))) + (incf map-index)) + (incf param-index))) + (when cache + (map-cache (lambda (wrappers pv-cell) + (setf (car pv-cell) + (update-slots-in-pv wrappers (car pv-cell) + cwrapper pv-size pv-map))) + cache)))))) (defun update-slots-in-pv (wrappers pv cwrapper pv-size pv-map) (if (not (if (atom wrappers) - (eq cwrapper wrappers) - (dolist (wrapper wrappers nil) - (when (eq wrapper cwrapper) - (return t))))) + (eq cwrapper wrappers) + (dolist (wrapper wrappers nil) + (when (eq wrapper cwrapper) + (return t))))) pv (let* ((old-intern-p (listp (pvref pv 0))) - (new-pv (if old-intern-p - (copy-pv pv) - pv)) - (new-intern-p t)) - (if (atom wrappers) - (dotimes-fixnum (i pv-size) - (when (consp (let ((map (svref pv-map i))) - (if map - (setf (pvref new-pv i) (cdr map)) - (pvref new-pv i)))) - (setq new-intern-p nil))) - (let ((param 0)) - (dolist (wrapper wrappers) - (when (eq wrapper cwrapper) - (dotimes-fixnum (i pv-size) - (when (consp (let ((map (svref pv-map i))) - (if (and map (= (car map) param)) - (setf (pvref new-pv i) (cdr map)) - (pvref new-pv i)))) - (setq new-intern-p nil)))) - (incf param)))) - (when new-intern-p - (setq new-pv (let ((list-pv (coerce pv 'list))) - (or (gethash (cdr list-pv) *pvs*) - (setf (gethash (cdr list-pv) *pvs*) - (if old-intern-p - new-pv - (make-permutation-vector list-pv))))))) - new-pv))) + (new-pv (if old-intern-p + (copy-pv pv) + pv)) + (new-intern-p t)) + (if (atom wrappers) + (dotimes-fixnum (i pv-size) + (when (consp (let ((map (svref pv-map i))) + (if map + (setf (pvref new-pv i) (cdr map)) + (pvref new-pv i)))) + (setq new-intern-p nil))) + (let ((param 0)) + (dolist (wrapper wrappers) + (when (eq wrapper cwrapper) + (dotimes-fixnum (i pv-size) + (when (consp (let ((map (svref pv-map i))) + (if (and map (= (car map) param)) + (setf (pvref new-pv i) (cdr map)) + (pvref new-pv i)))) + (setq new-intern-p nil)))) + (incf param)))) + (when new-intern-p + (setq new-pv (let ((list-pv (coerce pv 'list))) + (or (gethash (cdr list-pv) *pvs*) + (setf (gethash (cdr list-pv) *pvs*) + (if old-intern-p + new-pv + (make-permutation-vector list-pv))))))) + new-pv))) (defun maybe-expand-accessor-form (form required-parameters slots env) (let* ((fname (car form)) - #||(len (length form))||# - (gf (if (symbolp fname) - (unencapsulated-fdefinition fname) - (gdefinition fname)))) + #||(len (length form))||# + (gf (if (symbolp fname) + (unencapsulated-fdefinition fname) + (gdefinition fname)))) (macrolet ((maybe-optimize-reader () - `(let ((parameter - (can-optimize-access1 (cadr form) - required-parameters env))) - (when parameter - (optimize-reader slots parameter gf-name form)))) - (maybe-optimize-writer () - `(let ((parameter - (can-optimize-access1 (caddr form) - required-parameters env))) - (when parameter - (optimize-writer slots parameter gf-name form))))) + `(let ((parameter + (can-optimize-access1 (cadr form) + required-parameters env))) + (when parameter + (optimize-reader slots parameter gf-name form)))) + (maybe-optimize-writer () + `(let ((parameter + (can-optimize-access1 (caddr form) + required-parameters env))) + (when parameter + (optimize-writer slots parameter gf-name form))))) (unless (and (consp (cadr form)) - (eq 'instance-accessor-parameter (caadr form))) - (when (and (eq *boot-state* 'complete) - (generic-function-p gf)) - (let ((methods (generic-function-methods gf))) - (when methods - (let* ((gf-name (generic-function-name gf)) - (arg-info (gf-arg-info gf)) - (metatypes (arg-info-metatypes arg-info)) - (nreq (length metatypes)) - (applyp (arg-info-applyp arg-info))) - (when (null applyp) - (cond ((= nreq 1) - (when (some #'standard-reader-method-p methods) - (maybe-optimize-reader))) - ((and (= nreq 2) - (consp gf-name) - (eq (car gf-name) 'setf)) - (when (some #'standard-writer-method-p methods) - (maybe-optimize-writer))))))))))))) + (eq 'instance-accessor-parameter (caadr form))) + (when (and (eq *boot-state* 'complete) + (generic-function-p gf)) + (let ((methods (generic-function-methods gf))) + (when methods + (let* ((gf-name (generic-function-name gf)) + (arg-info (gf-arg-info gf)) + (metatypes (arg-info-metatypes arg-info)) + (nreq (length metatypes)) + (applyp (arg-info-applyp arg-info))) + (when (null applyp) + (cond ((= nreq 1) + (when (some #'standard-reader-method-p methods) + (maybe-optimize-reader))) + ((and (= nreq 2) + (consp gf-name) + (eq (car gf-name) 'setf)) + (when (some #'standard-writer-method-p methods) + (maybe-optimize-writer))))))))))))) (defun optimize-generic-function-call (form - required-parameters - env - slots - calls) + required-parameters + env + slots + calls) (declare (ignore required-parameters env slots calls)) (or ; (optimize-reader ...)? form)) (defun can-optimize-access (form required-parameters env) (let ((type (ecase (car form) - (slot-value 'reader) - (set-slot-value 'writer) - (slot-boundp 'boundp))) - (var (cadr form)) - (slot-name (eval (caddr form)))) ; known to be constant + (slot-value 'reader) + (set-slot-value 'writer) + (slot-boundp 'boundp))) + (var (cadr form)) + (slot-name (eval (caddr form)))) ; known to be constant (can-optimize-access1 var required-parameters env type slot-name))) ;;; FIXME: This looks like an internal helper function for @@ -406,7 +406,7 @@ ;;; CAN-OPTIMIZE-ACCESS-FOR-VAR. If so, I'd just as soon use keyword ;;; args instead of optional ones, too. (defun can-optimize-access1 (var required-parameters env - &optional type slot-name) + &optional type slot-name) (when (and (consp var) (eq 'the (car var))) ;; FIXME: We should assert list of length 3 here. Or maybe we ;; should just define EXTRACT-THE, replace the whole @@ -419,71 +419,71 @@ (setq var (caddr var))) (when (symbolp var) (let* ((rebound? (caddr (var-declaration '%variable-rebinding var env))) - (parameter-or-nil (car (memq (or rebound? var) - required-parameters)))) + (parameter-or-nil (car (memq (or rebound? var) + required-parameters)))) (when parameter-or-nil - (let* ((class-name (caddr (var-declaration '%class - parameter-or-nil - env))) - (class (find-class class-name nil))) - (when (or (not (eq *boot-state* 'complete)) - (and class (not (class-finalized-p class)))) - (setq class nil)) - (when (and class-name (not (eq class-name t))) - (when (or (null type) - (not (and class - (memq *the-class-structure-object* - (class-precedence-list class)))) - (optimize-slot-value-by-class-p class slot-name type)) - (cons parameter-or-nil (or class class-name))))))))) + (let* ((class-name (caddr (var-declaration '%class + parameter-or-nil + env))) + (class (find-class class-name nil))) + (when (or (not (eq *boot-state* 'complete)) + (and class (not (class-finalized-p class)))) + (setq class nil)) + (when (and class-name (not (eq class-name t))) + (when (or (null type) + (not (and class + (memq *the-class-structure-object* + (class-precedence-list class)))) + (optimize-slot-value-by-class-p class slot-name type)) + (cons parameter-or-nil (or class class-name))))))))) (defun optimize-slot-value (slots sparameter form) (if sparameter (destructuring-bind (ignore1 ignore2 slot-name-form) form - (declare (ignore ignore1 ignore2)) - (let ((slot-name (eval slot-name-form))) - (optimize-instance-access slots :read sparameter slot-name nil))) + (declare (ignore ignore1 ignore2)) + (let ((slot-name (eval slot-name-form))) + (optimize-instance-access slots :read sparameter slot-name nil))) `(accessor-slot-value ,@(cdr form)))) (defun optimize-set-slot-value (slots sparameter form) (if sparameter (destructuring-bind (ignore1 ignore2 slot-name-form new-value) form - (declare (ignore ignore1 ignore2)) - (let ((slot-name (eval slot-name-form))) - (optimize-instance-access slots - :write - sparameter - slot-name - new-value))) + (declare (ignore ignore1 ignore2)) + (let ((slot-name (eval slot-name-form))) + (optimize-instance-access slots + :write + sparameter + slot-name + new-value))) `(accessor-set-slot-value ,@(cdr form)))) (defun optimize-slot-boundp (slots sparameter form) (if sparameter (destructuring-bind - ;; FIXME: In CMU CL ca. 19991205, this binding list had a - ;; fourth element in it, NEW-VALUE. It's hard to see how - ;; that could possibly be right, since SLOT-BOUNDP has no - ;; NEW-VALUE. Since it was causing a failure in building PCL - ;; for SBCL, so I changed it to match the definition of - ;; SLOT-BOUNDP (and also to match the list used in the - ;; similar OPTIMIZE-SLOT-VALUE, above). However, I'm weirded - ;; out by this, since this is old code which has worked for - ;; ages to build PCL for CMU CL, so it's hard to see why it - ;; should need a patch like this in order to build PCL for - ;; SBCL. I'd like to return to this and find a test case - ;; which exercises this function both in CMU CL, to see - ;; whether it's really a previously-unexercised bug or - ;; whether I've misunderstood something (and, presumably, - ;; patched it wrong). - (slot-boundp-symbol instance slot-name-form) - form - (declare (ignore slot-boundp-symbol instance)) - (let ((slot-name (eval slot-name-form))) - (optimize-instance-access slots - :boundp - sparameter - slot-name - nil))) + ;; FIXME: In CMU CL ca. 19991205, this binding list had a + ;; fourth element in it, NEW-VALUE. It's hard to see how + ;; that could possibly be right, since SLOT-BOUNDP has no + ;; NEW-VALUE. Since it was causing a failure in building PCL + ;; for SBCL, so I changed it to match the definition of + ;; SLOT-BOUNDP (and also to match the list used in the + ;; similar OPTIMIZE-SLOT-VALUE, above). However, I'm weirded + ;; out by this, since this is old code which has worked for + ;; ages to build PCL for CMU CL, so it's hard to see why it + ;; should need a patch like this in order to build PCL for + ;; SBCL. I'd like to return to this and find a test case + ;; which exercises this function both in CMU CL, to see + ;; whether it's really a previously-unexercised bug or + ;; whether I've misunderstood something (and, presumably, + ;; patched it wrong). + (slot-boundp-symbol instance slot-name-form) + form + (declare (ignore slot-boundp-symbol instance)) + (let ((slot-name (eval slot-name-form))) + (optimize-instance-access slots + :boundp + sparameter + slot-name + nil))) `(accessor-slot-boundp ,@(cdr form)))) (defun optimize-reader (slots sparameter gf-name form) @@ -494,8 +494,8 @@ (defun optimize-writer (slots sparameter gf-name form) (if sparameter (destructuring-bind (ignore1 ignore2 new-value) form - (declare (ignore ignore1 ignore2)) - (optimize-accessor-call slots :write sparameter gf-name new-value)) + (declare (ignore ignore1 ignore2)) + (optimize-accessor-call slots :write sparameter gf-name new-value)) form)) ;;; The SLOTS argument is an alist, the CAR of each entry is the name @@ -503,57 +503,57 @@ ;;; the position of an entry in the alist corresponds to the ;;; argument's position in the lambda list. (defun optimize-instance-access (slots - read/write - sparameter - slot-name - new-value) + read/write + sparameter + slot-name + new-value) (let ((class (if (consp sparameter) (cdr sparameter) *the-class-t*)) - (parameter (if (consp sparameter) (car sparameter) sparameter))) + (parameter (if (consp sparameter) (car sparameter) sparameter))) (if (and (eq *boot-state* 'complete) - (classp class) - (memq *the-class-structure-object* (class-precedence-list class))) - (let ((slotd (find-slot-definition class slot-name))) - (ecase read/write - (:read - `(,(slot-definition-defstruct-accessor-symbol slotd) ,parameter)) - (:write - `(setf (,(slot-definition-defstruct-accessor-symbol slotd) - ,parameter) - ,new-value)) - (:boundp - t))) - (let* ((parameter-entry (assq parameter slots)) - (slot-entry (assq slot-name (cdr parameter-entry))) - (position (posq parameter-entry slots)) - (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) - (unless parameter-entry - (bug "slot optimization bewilderment: O-I-A")) - (unless slot-entry - (setq slot-entry (list slot-name)) - (push slot-entry (cdr parameter-entry))) - (push pv-offset-form (cdr slot-entry)) - (ecase read/write - (:read - `(instance-read ,pv-offset-form ,parameter ,position - ',slot-name ',class)) - (:write - `(let ((.new-value. ,new-value)) - (instance-write ,pv-offset-form ,parameter ,position - ',slot-name ',class .new-value.))) - (:boundp - `(instance-boundp ,pv-offset-form ,parameter ,position - ',slot-name ',class))))))) + (classp class) + (memq *the-class-structure-object* (class-precedence-list class))) + (let ((slotd (find-slot-definition class slot-name))) + (ecase read/write + (:read + `(,(slot-definition-defstruct-accessor-symbol slotd) ,parameter)) + (:write + `(setf (,(slot-definition-defstruct-accessor-symbol slotd) + ,parameter) + ,new-value)) + (:boundp + t))) + (let* ((parameter-entry (assq parameter slots)) + (slot-entry (assq slot-name (cdr parameter-entry))) + (position (posq parameter-entry slots)) + (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) + (unless parameter-entry + (bug "slot optimization bewilderment: O-I-A")) + (unless slot-entry + (setq slot-entry (list slot-name)) + (push slot-entry (cdr parameter-entry))) + (push pv-offset-form (cdr slot-entry)) + (ecase read/write + (:read + `(instance-read ,pv-offset-form ,parameter ,position + ',slot-name ',class)) + (:write + `(let ((.new-value. ,new-value)) + (instance-write ,pv-offset-form ,parameter ,position + ',slot-name ',class .new-value.))) + (:boundp + `(instance-boundp ,pv-offset-form ,parameter ,position + ',slot-name ',class))))))) (defun optimize-accessor-call (slots read/write sparameter gf-name new-value) (let* ((class (if (consp sparameter) (cdr sparameter) *the-class-t*)) - (parameter (if (consp sparameter) (car sparameter) sparameter)) - (parameter-entry (assq parameter slots)) - (name (case read/write - (:read `(reader ,gf-name)) - (:write `(writer ,gf-name)))) - (slot-entry (assoc name (cdr parameter-entry) :test #'equal)) - (position (posq parameter-entry slots)) - (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) + (parameter (if (consp sparameter) (car sparameter) sparameter)) + (parameter-entry (assq parameter slots)) + (name (case read/write + (:read `(reader ,gf-name)) + (:write `(writer ,gf-name)))) + (slot-entry (assoc name (cdr parameter-entry) :test #'equal)) + (position (posq parameter-entry slots)) + (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) (unless parameter-entry (error "slot optimization bewilderment: O-A-C")) (unless slot-entry @@ -565,62 +565,62 @@ `(instance-reader ,pv-offset-form ,parameter ,position ,gf-name ',class)) (:write `(let ((.new-value. ,new-value)) - (instance-writer ,pv-offset-form ,parameter ,position ,gf-name ',class - .new-value.)))))) + (instance-writer ,pv-offset-form ,parameter ,position ,gf-name ',class + .new-value.)))))) (defvar *unspecific-arg* '..unspecific-arg..) (defun optimize-gf-call-internal (form slots env) (when (and (consp form) - (eq (car form) 'the)) + (eq (car form) 'the)) (setq form (caddr form))) (or (and (symbolp form) - (let* ((rebound? (caddr (var-declaration '%variable-rebinding - form - env))) - (parameter-or-nil (car (assq (or rebound? form) slots)))) - (when parameter-or-nil - (let* ((class-name (caddr (var-declaration 'class - parameter-or-nil - env)))) - (when (and class-name (not (eq class-name t))) - (position parameter-or-nil slots :key #'car)))))) + (let* ((rebound? (caddr (var-declaration '%variable-rebinding + form + env))) + (parameter-or-nil (car (assq (or rebound? form) slots)))) + (when parameter-or-nil + (let* ((class-name (caddr (var-declaration 'class + parameter-or-nil + env)))) + (when (and class-name (not (eq class-name t))) + (position parameter-or-nil slots :key #'car)))))) (if (constantp form) - (let ((form (eval form))) - (if (symbolp form) - form - *unspecific-arg*)) - *unspecific-arg*))) + (let ((form (eval form))) + (if (symbolp form) + form + *unspecific-arg*)) + *unspecific-arg*))) (defun optimize-gf-call (slots calls gf-call-form nreq restp env) (unless (eq (car gf-call-form) 'make-instance) ; XXX needs more work (let* ((args (cdr gf-call-form)) - (all-args-p (eq (car gf-call-form) 'make-instance)) - (non-required-args (nthcdr nreq args)) - (required-args (ldiff args non-required-args)) - (call-spec (list (car gf-call-form) nreq restp - (mapcar (lambda (form) - (optimize-gf-call-internal form slots env)) - (if all-args-p - args - required-args)))) - (call-entry (assoc call-spec calls :test #'equal)) - (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) + (all-args-p (eq (car gf-call-form) 'make-instance)) + (non-required-args (nthcdr nreq args)) + (required-args (ldiff args non-required-args)) + (call-spec (list (car gf-call-form) nreq restp + (mapcar (lambda (form) + (optimize-gf-call-internal form slots env)) + (if all-args-p + args + required-args)))) + (call-entry (assoc call-spec calls :test #'equal)) + (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) (unless (some #'integerp - (let ((spec-args (cdr call-spec))) - (if all-args-p - (ldiff spec-args (nthcdr nreq spec-args)) - spec-args))) - (return-from optimize-gf-call nil)) + (let ((spec-args (cdr call-spec))) + (if all-args-p + (ldiff spec-args (nthcdr nreq spec-args)) + spec-args))) + (return-from optimize-gf-call nil)) (unless call-entry - (setq call-entry (list call-spec)) - (push call-entry (cdr calls))) + (setq call-entry (list call-spec)) + (push call-entry (cdr calls))) (push pv-offset-form (cdr call-entry)) (if (eq (car call-spec) 'make-instance) - `(funcall (pv-ref .pv. ,pv-offset-form) ,@(cdr gf-call-form)) - `(let ((.emf. (pv-ref .pv. ,pv-offset-form))) - (invoke-effective-method-function .emf. ,restp - ,@required-args ,@(when restp `((list ,@non-required-args))))))))) + `(funcall (pv-ref .pv. ,pv-offset-form) ,@(cdr gf-call-form)) + `(let ((.emf. (pv-ref .pv. ,pv-offset-form))) + (invoke-effective-method-function .emf. ,restp + ,@required-args ,@(when restp `((list ,@non-required-args))))))))) (define-walker-template pv-offset) ; These forms get munged by mutate slots. (defmacro pv-offset (arg) arg) @@ -631,69 +631,69 @@ ;;; guess what the most likely case will be. (defun generate-fast-class-slot-access-p (class-form slot-name-form) (let ((class (and (constantp class-form) (eval class-form))) - (slot-name (and (constantp slot-name-form) (eval slot-name-form)))) + (slot-name (and (constantp slot-name-form) (eval slot-name-form)))) (and (eq *boot-state* 'complete) - (standard-class-p class) - (not (eq class *the-class-t*)) ; shouldn't happen, though. - (let ((slotd (find-slot-definition class slot-name))) - (and slotd (eq :class (slot-definition-allocation slotd))))))) + (standard-class-p class) + (not (eq class *the-class-t*)) ; shouldn't happen, though. + (let ((slotd (find-slot-definition class slot-name))) + (and slotd (eq :class (slot-definition-allocation slotd))))))) (defun skip-fast-slot-access-p (class-form slot-name-form type) (let ((class (and (constantp class-form) (eval class-form))) - (slot-name (and (constantp slot-name-form) (eval slot-name-form)))) + (slot-name (and (constantp slot-name-form) (eval slot-name-form)))) (and (eq *boot-state* 'complete) - (standard-class-p class) - (not (eq class *the-class-t*)) ; shouldn't happen, though. - (let ((slotd (find-slot-definition class slot-name))) - (and slotd (skip-optimize-slot-value-by-class-p class - slot-name - type)))))) + (standard-class-p class) + (not (eq class *the-class-t*)) ; shouldn't happen, though. + (let ((slotd (find-slot-definition class slot-name))) + (and slotd (skip-optimize-slot-value-by-class-p class + slot-name + type)))))) (defun skip-optimize-slot-value-by-class-p (class slot-name type) (let ((slotd (find-slot-definition class slot-name))) (and slotd - (eq *boot-state* 'complete) - (not (slot-accessor-std-p slotd type))))) + (eq *boot-state* 'complete) + (not (slot-accessor-std-p slotd type))))) -(defmacro instance-read-internal (pv slots pv-offset default &optional type) - (unless (member type '(nil :instance :class :default)) - (error "illegal type argument to ~S: ~S" 'instance-read-internal type)) - (if (eq type :default) +(defmacro instance-read-internal (pv slots pv-offset default &optional kind) + (unless (member kind '(nil :instance :class :default)) + (error "illegal kind argument to ~S: ~S" 'instance-read-internal kind)) + (if (eq kind :default) default (let* ((index (gensym)) - (value index)) - `(locally (declare #.*optimize-speed*) - (let ((,index (pvref ,pv ,pv-offset))) - (setq ,value (typecase ,index - ;; FIXME: the line marked by KLUDGE below - ;; (and the analogous spot in - ;; INSTANCE-WRITE-INTERNAL) is there purely - ;; to suppress a type mismatch warning that - ;; propagates through to user code. - ;; Presumably SLOTS at this point can never - ;; actually be NIL, but the compiler seems - ;; to think it could, so we put this here - ;; to shut it up. (see also mail Rudi - ;; Schlatte sbcl-devel 2003-09-21) -- CSR, - ;; 2003-11-30 - ,@(when (or (null type) (eq type :instance)) - `((fixnum - (and ,slots ; KLUDGE - (clos-slots-ref ,slots ,index))))) - ,@(when (or (null type) (eq type :class)) - `((cons (cdr ,index)))) - (t +slot-unbound+))) - (if (eq ,value +slot-unbound+) - ,default - ,value)))))) + (value index)) + `(locally (declare #.*optimize-speed*) + (let ((,index (pvref ,pv ,pv-offset))) + (setq ,value (typecase ,index + ;; FIXME: the line marked by KLUDGE below + ;; (and the analogous spot in + ;; INSTANCE-WRITE-INTERNAL) is there purely + ;; to suppress a type mismatch warning that + ;; propagates through to user code. + ;; Presumably SLOTS at this point can never + ;; actually be NIL, but the compiler seems + ;; to think it could, so we put this here + ;; to shut it up. (see also mail Rudi + ;; Schlatte sbcl-devel 2003-09-21) -- CSR, + ;; 2003-11-30 + ,@(when (or (null kind) (eq kind :instance)) + `((fixnum + (and ,slots ; KLUDGE + (clos-slots-ref ,slots ,index))))) + ,@(when (or (null kind) (eq kind :class)) + `((cons (cdr ,index)))) + (t +slot-unbound+))) + (if (eq ,value +slot-unbound+) + ,default + ,value)))))) (defmacro instance-read (pv-offset parameter position slot-name class) (if (skip-fast-slot-access-p class slot-name 'reader) `(accessor-slot-value ,parameter ,slot-name) `(instance-read-internal .pv. ,(slot-vector-symbol position) - ,pv-offset (accessor-slot-value ,parameter ,slot-name) - ,(if (generate-fast-class-slot-access-p class slot-name) - :class :instance)))) + ,pv-offset (accessor-slot-value ,parameter ,slot-name) + ,(if (generate-fast-class-slot-access-p class slot-name) + :class :instance)))) (defmacro instance-reader (pv-offset parameter position gf-name class) (declare (ignore class)) @@ -703,78 +703,92 @@ :instance)) (defmacro instance-write-internal (pv slots pv-offset new-value default - &optional type) - (unless (member type '(nil :instance :class :default)) - (error "illegal type argument to ~S: ~S" 'instance-write-internal type)) - (if (eq type :default) + &optional kind (type t)) + (unless (member kind '(nil :instance :class :default)) + (error "illegal kind argument to ~S: ~S" 'instance-write-internal kind)) + (if (eq kind :default) default (let* ((index (gensym))) - `(locally (declare #.*optimize-speed*) - (let ((,index (pvref ,pv ,pv-offset))) - (typecase ,index - ,@(when (or (null type) (eq type :instance)) + `(locally (declare #.*optimize-speed*) + (let ((,index (pvref ,pv ,pv-offset))) + (typecase ,index + ,@(when (or (null kind) (eq kind :instance)) `((fixnum (and ,slots - (setf (clos-slots-ref ,slots ,index) - ,new-value))))) - ,@(when (or (null type) (eq type :class)) - `((cons (setf (cdr ,index) ,new-value)))) - (t ,default))))))) + (setf (clos-slots-ref ,slots ,index) + (locally + (declare (optimize (safety 3))) + (the ,type ,new-value))))))) + ,@(when (or (null kind) (eq kind :class)) + `((cons (setf (cdr ,index) + (locally + (declare (optimize (safety 3))) + (the ,type ,new-value)))))) + (t ,default))))))) (defmacro instance-write (pv-offset - parameter - position - slot-name - class - new-value) + parameter + position + slot-name + class + new-value) (if (skip-fast-slot-access-p class slot-name 'writer) `(accessor-set-slot-value ,parameter ,slot-name ,new-value) `(instance-write-internal .pv. ,(slot-vector-symbol position) - ,pv-offset ,new-value - (accessor-set-slot-value ,parameter ,slot-name ,new-value) - ,(if (generate-fast-class-slot-access-p class slot-name) - :class :instance)))) + ,pv-offset ,new-value + (accessor-set-slot-value ,parameter ,slot-name ,new-value) + ,(if (generate-fast-class-slot-access-p class slot-name) + :class :instance) + ,(if (and (eq *boot-state* 'complete) + (constantp class) + (constantp slot-name) + (standard-class-p (eval class)) + (not (eq (eval class) *the-class-t*))) + (let ((slotd (find-slot-definition (eval class) (eval slot-name)))) + (or (not slotd) + (slot-definition-type slotd))) + t)))) (defmacro instance-writer (pv-offset - parameter - position - gf-name - class - new-value) + parameter + position + gf-name + class + new-value) (declare (ignore class)) `(instance-write-internal .pv. ,(slot-vector-symbol position) ,pv-offset ,new-value (,(if (consp gf-name) - (get-setf-fun-name gf-name) - gf-name) + (get-setf-fun-name gf-name) + gf-name) (instance-accessor-parameter ,parameter) ,new-value) :instance)) (defmacro instance-boundp-internal (pv slots pv-offset default - &optional type) - (unless (member type '(nil :instance :class :default)) - (error "illegal type argument to ~S: ~S" 'instance-boundp-internal type)) - (if (eq type :default) + &optional kind) + (unless (member kind '(nil :instance :class :default)) + (error "illegal kind argument to ~S: ~S" 'instance-boundp-internal kind)) + (if (eq kind :default) default (let* ((index (gensym))) - `(locally (declare #.*optimize-speed*) - (let ((,index (pvref ,pv ,pv-offset))) - (typecase ,index - ,@(when (or (null type) (eq type :instance)) - `((fixnum (not (and ,slots + `(locally (declare #.*optimize-speed*) + (let ((,index (pvref ,pv ,pv-offset))) + (typecase ,index + ,@(when (or (null kind) (eq kind :instance)) + `((fixnum (not (and ,slots (eq (clos-slots-ref ,slots ,index) +slot-unbound+)))))) - ,@(when (or (null type) (eq type :class)) - `((cons (not (eq (cdr ,index) +slot-unbound+))))) - (t ,default))))))) + ,@(when (or (null kind) (eq kind :class)) + `((cons (not (eq (cdr ,index) +slot-unbound+))))) + (t ,default))))))) (defmacro instance-boundp (pv-offset parameter position slot-name class) (if (skip-fast-slot-access-p class slot-name 'boundp) `(accessor-slot-boundp ,parameter ,slot-name) `(instance-boundp-internal .pv. ,(slot-vector-symbol position) - ,pv-offset (accessor-slot-boundp ,parameter ,slot-name) - ,(if (generate-fast-class-slot-access-p class slot-name) - :class :instance)))) + ,pv-offset (accessor-slot-boundp ,parameter ,slot-name) + ,(if (generate-fast-class-slot-access-p class slot-name) + :class :instance)))) ;;; This magic function has quite a job to do indeed. ;;; @@ -795,47 +809,47 @@ (defun slot-name-lists-from-slots (slots calls) (multiple-value-bind (slots calls) (mutate-slots-and-calls slots calls) (let* ((slot-name-lists - (mapcar (lambda (parameter-entry) - (cons nil (mapcar #'car (cdr parameter-entry)))) - slots)) - (call-list - (mapcar #'car calls))) + (mapcar (lambda (parameter-entry) + (cons nil (mapcar #'car (cdr parameter-entry)))) + slots)) + (call-list + (mapcar #'car calls))) (dolist (call call-list) - (dolist (arg (cdr call)) - (when (integerp arg) - (setf (car (nth arg slot-name-lists)) t)))) + (dolist (arg (cdr call)) + (when (integerp arg) + (setf (car (nth arg slot-name-lists)) t)))) (setq slot-name-lists (mapcar (lambda (r+snl) - (when (or (car r+snl) (cdr r+snl)) - r+snl)) - slot-name-lists)) + (when (or (car r+snl) (cdr r+snl)) + r+snl)) + slot-name-lists)) (let ((cvt (apply #'vector - (let ((i -1)) - (mapcar (lambda (r+snl) - (when r+snl (incf i))) - slot-name-lists))))) - (setq call-list (mapcar (lambda (call) - (cons (car call) - (mapcar (lambda (arg) - (if (integerp arg) - (svref cvt arg) - arg)) - (cdr call)))) - call-list))) + (let ((i -1)) + (mapcar (lambda (r+snl) + (when r+snl (incf i))) + slot-name-lists))))) + (setq call-list (mapcar (lambda (call) + (cons (car call) + (mapcar (lambda (arg) + (if (integerp arg) + (svref cvt arg) + arg)) + (cdr call)))) + call-list))) (values slot-name-lists call-list)))) (defun mutate-slots-and-calls (slots calls) (let ((sorted-slots (sort-slots slots)) - (sorted-calls (sort-calls (cdr calls))) - (pv-offset 0)) ; index 0 is for info + (sorted-calls (sort-calls (cdr calls))) + (pv-offset 0)) ; index 0 is for info (dolist (parameter-entry sorted-slots) (dolist (slot-entry (cdr parameter-entry)) - (incf pv-offset) - (dolist (form (cdr slot-entry)) - (setf (cadr form) pv-offset)))) + (incf pv-offset) + (dolist (form (cdr slot-entry)) + (setf (cadr form) pv-offset)))) (dolist (call-entry sorted-calls) (incf pv-offset) (dolist (form (cdr call-entry)) - (setf (cadr form) pv-offset))) + (setf (cadr form) pv-offset))) (values sorted-slots sorted-calls))) (defun symbol-pkg-name (sym) @@ -856,30 +870,30 @@ ;;; * faster code. (defun symbol-lessp (a b) (if (eq (symbol-package a) - (symbol-package b)) + (symbol-package b)) (string-lessp (symbol-name a) - (symbol-name b)) + (symbol-name b)) (string-lessp (symbol-pkg-name a) - (symbol-pkg-name b)))) + (symbol-pkg-name b)))) (defun symbol-or-cons-lessp (a b) (etypecase a (symbol (etypecase b - (symbol (symbol-lessp a b)) - (cons t))) + (symbol (symbol-lessp a b)) + (cons t))) (cons (etypecase b - (symbol nil) - (cons (if (eq (car a) (car b)) - (symbol-or-cons-lessp (cdr a) (cdr b)) - (symbol-or-cons-lessp (car a) (car b)))))))) + (symbol nil) + (cons (if (eq (car a) (car b)) + (symbol-or-cons-lessp (cdr a) (cdr b)) + (symbol-or-cons-lessp (car a) (car b)))))))) (defun sort-slots (slots) (mapcar (lambda (parameter-entry) - (cons (car parameter-entry) - (sort (cdr parameter-entry) ;slot entries - #'symbol-or-cons-lessp - :key #'car))) - slots)) + (cons (car parameter-entry) + (sort (cdr parameter-entry) ;slot entries + #'symbol-or-cons-lessp + :key #'car))) + slots)) (defun sort-calls (calls) (sort calls #'symbol-or-cons-lessp :key #'car)) @@ -890,7 +904,7 @@ ;;;; stuff too. (defmacro pv-binding ((required-parameters slot-name-lists pv-table-symbol) - &body body) + &body body) (let (slot-vars pv-parameters) (loop for slots in slot-name-lists for required-parameter in required-parameters @@ -903,25 +917,25 @@ ,@body))) (defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars) - &body body) + &body body) `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters) (let (,@(mapcar (lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p))) - slot-vars pv-parameters)) + slot-vars pv-parameters)) (declare (ignorable ,@(mapcar #'identity slot-vars))) ,@body))) ;;; This gets used only when the default MAKE-METHOD-LAMBDA is ;;; overridden. (defmacro pv-env ((pv calls pv-table-symbol pv-parameters) - &rest forms) + &rest forms) `(let* ((.pv-table. ,pv-table-symbol) - (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters)) - (,pv (car .pv-cell.)) - (,calls (cdr .pv-cell.))) + (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters)) + (,pv (car .pv-cell.)) + (,calls (cdr .pv-cell.))) (declare ,(make-pv-type-declaration pv)) (declare ,(make-calls-type-declaration calls)) ,@(when (symbolp pv-table-symbol) - `((declare (special ,pv-table-symbol)))) + `((declare (special ,pv-table-symbol)))) ,pv ,calls ,@forms)) @@ -960,68 +974,68 @@ (defun split-declarations (body args maybe-reads-params-p) (let ((inner-decls nil) - (outer-decls nil) - decl) + (outer-decls nil) + decl) (loop (when (null body) (return nil)) - (setq decl (car body)) - (unless (and (consp decl) - (eq (car decl) 'declare)) - (return nil)) - (dolist (form (cdr decl)) - (when (consp form) - (let ((declaration-name (car form))) - (if (member declaration-name *non-var-declarations*) - (push `(declare ,form) outer-decls) - (let ((arg-p - (member declaration-name - *var-declarations-with-arg*)) - (non-arg-p - (member declaration-name - *var-declarations-without-arg*)) - (dname (list (pop form))) - (inners nil) (outers nil)) - (unless (or arg-p non-arg-p) - ;; FIXME: This warning, and perhaps the - ;; various *VAR-DECLARATIONS-FOO* and/or - ;; *NON-VAR-DECLARATIONS* variables, - ;; could probably go away now that we're not - ;; trying to be portable between different - ;; CLTL1 hosts the way PCL was. (Note that to - ;; do this right, we need to be able to handle - ;; user-defined (DECLAIM (DECLARATION FOO)) - ;; stuff.) - (warn "The declaration ~S is not understood by ~S.~@ - Please put ~S on one of the lists ~S,~%~S, or~%~S.~@ - (Assuming it is a variable declaration without argument)." - declaration-name 'split-declarations - declaration-name - '*non-var-declarations* - '*var-declarations-with-arg* - '*var-declarations-without-arg*) - (push declaration-name *var-declarations-without-arg*)) - (when arg-p - (setq dname (append dname (list (pop form))))) - (case (car dname) - (%class (push `(declare (,@dname ,@form)) inner-decls)) - (t - (dolist (var form) - (if (member var args) - ;; Quietly remove IGNORE declarations - ;; on args when a next-method is - ;; involved, to prevent compiler - ;; warnings about ignored args being - ;; read. - (unless (and maybe-reads-params-p - (eq (car dname) 'ignore)) - (push var outers)) - (push var inners))) - (when outers - (push `(declare (,@dname ,@outers)) outer-decls)) - (when inners - (push - `(declare (,@dname ,@inners)) - inner-decls))))))))) - (setq body (cdr body))) + (setq decl (car body)) + (unless (and (consp decl) + (eq (car decl) 'declare)) + (return nil)) + (dolist (form (cdr decl)) + (when (consp form) + (let ((declaration-name (car form))) + (if (member declaration-name *non-var-declarations*) + (push `(declare ,form) outer-decls) + (let ((arg-p + (member declaration-name + *var-declarations-with-arg*)) + (non-arg-p + (member declaration-name + *var-declarations-without-arg*)) + (dname (list (pop form))) + (inners nil) (outers nil)) + (unless (or arg-p non-arg-p) + ;; FIXME: This warning, and perhaps the + ;; various *VAR-DECLARATIONS-FOO* and/or + ;; *NON-VAR-DECLARATIONS* variables, + ;; could probably go away now that we're not + ;; trying to be portable between different + ;; CLTL1 hosts the way PCL was. (Note that to + ;; do this right, we need to be able to handle + ;; user-defined (DECLAIM (DECLARATION FOO)) + ;; stuff.) + (warn "The declaration ~S is not understood by ~S.~@ + Please put ~S on one of the lists ~S,~%~S, or~%~S.~@ + (Assuming it is a variable declaration without argument)." + declaration-name 'split-declarations + declaration-name + '*non-var-declarations* + '*var-declarations-with-arg* + '*var-declarations-without-arg*) + (push declaration-name *var-declarations-without-arg*)) + (when arg-p + (setq dname (append dname (list (pop form))))) + (case (car dname) + (%class (push `(declare (,@dname ,@form)) inner-decls)) + (t + (dolist (var form) + (if (member var args) + ;; Quietly remove IGNORE declarations + ;; on args when a next-method is + ;; involved, to prevent compiler + ;; warnings about ignored args being + ;; read. + (unless (and maybe-reads-params-p + (eq (car dname) 'ignore)) + (push var outers)) + (push var inners))) + (when outers + (push `(declare (,@dname ,@outers)) outer-decls)) + (when inners + (push + `(declare (,@dname ,@inners)) + inner-decls))))))))) + (setq body (cdr body))) (values outer-decls inner-decls body))) ;;; Pull a name out of the %METHOD-NAME declaration in the function @@ -1032,8 +1046,8 @@ (declare (ignore real-body documentation)) (let ((name-decl (get-declaration '%method-name declarations))) (and name-decl - (destructuring-bind (name) name-decl - name))))) + (destructuring-bind (name) name-decl + name))))) ;;; Convert a lambda expression containing a SB-PCL::%METHOD-NAME ;;; declaration (which is a naming style internal to PCL) into an @@ -1044,80 +1058,80 @@ (defun name-method-lambda (method-lambda) (let ((method-name (body-method-name (cddr method-lambda)))) (if method-name - `(named-lambda (method ,method-name) ,(rest method-lambda)) - method-lambda))) + `(named-lambda (slow-method ,method-name) ,(rest method-lambda)) + method-lambda))) (defun make-method-initargs-form-internal (method-lambda initargs env) (declare (ignore env)) (let (method-lambda-args - lmf ; becomes body of function - lmf-params) + lmf ; becomes body of function + lmf-params) (if (not (and (= 3 (length method-lambda)) - (= 2 (length (setq method-lambda-args (cadr method-lambda)))) - (consp (setq lmf (third method-lambda))) - (eq 'simple-lexical-method-functions (car lmf)) - (eq (car method-lambda-args) - (cadr (setq lmf-params (cadr lmf)))) - (eq (cadr method-lambda-args) - (caddr lmf-params)))) - `(list* :function ,(name-method-lambda method-lambda) - ',initargs) - (let* ((lambda-list (car lmf-params)) - (nreq 0) - (restp nil) - (args nil)) - (dolist (arg lambda-list) - (when (member arg '(&optional &rest &key)) - (setq restp t) - (return nil)) - (when (eq arg '&aux) - (return nil)) - (incf nreq) - (push arg args)) - (setq args (nreverse args)) - (setf (getf (getf initargs :plist) :arg-info) (cons nreq restp)) - (make-method-initargs-form-internal1 - initargs (cddr lmf) args lmf-params restp))))) + (= 2 (length (setq method-lambda-args (cadr method-lambda)))) + (consp (setq lmf (third method-lambda))) + (eq 'simple-lexical-method-functions (car lmf)) + (eq (car method-lambda-args) + (cadr (setq lmf-params (cadr lmf)))) + (eq (cadr method-lambda-args) + (caddr lmf-params)))) + `(list* :function ,(name-method-lambda method-lambda) + ',initargs) + (let* ((lambda-list (car lmf-params)) + (nreq 0) + (restp nil) + (args nil)) + (dolist (arg lambda-list) + (when (member arg '(&optional &rest &key)) + (setq restp t) + (return nil)) + (when (eq arg '&aux) + (return nil)) + (incf nreq) + (push arg args)) + (setq args (nreverse args)) + (setf (getf (getf initargs :plist) :arg-info) (cons nreq restp)) + (make-method-initargs-form-internal1 + initargs (cddr lmf) args lmf-params restp))))) (defun make-method-initargs-form-internal1 (initargs body req-args lmf-params restp) (multiple-value-bind (outer-decls inner-decls body-sans-decls) (split-declarations body req-args (or (getf (cdr lmf-params) :call-next-method-p) - (getf (cdr lmf-params) :setq-p))) + (getf (cdr lmf-params) :setq-p))) (let* ((rest-arg (when restp '.rest-arg.)) - (args+rest-arg (if restp - (append req-args (list rest-arg)) - req-args))) + (args+rest-arg (if restp + (append req-args (list rest-arg)) + req-args))) `(list* - :fast-function - (,(if (body-method-name body) 'named-lambda 'lambda) - ,@(when (body-method-name body) + :fast-function + (,(if (body-method-name body) 'named-lambda 'lambda) + ,@(when (body-method-name body) ;; function name - (list (cons 'fast-method (body-method-name body)))) - (.pv-cell. .next-method-call. ,@args+rest-arg) ; function args - ;; body of the function - (declare (ignorable .pv-cell. .next-method-call.)) - ,@outer-decls - (declare (disable-package-locks pv-env)) - (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters) - &rest forms) - (declare (ignore pv-table-symbol - pv-parameters)) - (declare (enable-package-locks pv-env)) - `(let ((,pv (car .pv-cell.)) - (,calls (cdr .pv-cell.))) - (declare ,(make-pv-type-declaration pv) - ,(make-calls-type-declaration calls)) - ,pv ,calls - ,@forms))) - (declare (enable-package-locks pv-env)) - (fast-lexical-method-functions - (,(car lmf-params) .next-method-call. ,req-args ,rest-arg - ,@(cdddr lmf-params)) - ,@inner-decls - ,@body-sans-decls))) - ',initargs)))) + (list (cons 'fast-method (body-method-name body)))) + (.pv-cell. .next-method-call. ,@args+rest-arg) ; function args + ;; body of the function + (declare (ignorable .pv-cell. .next-method-call.)) + ,@outer-decls + (declare (disable-package-locks pv-env)) + (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters) + &rest forms) + (declare (ignore pv-table-symbol + pv-parameters)) + (declare (enable-package-locks pv-env)) + `(let ((,pv (car .pv-cell.)) + (,calls (cdr .pv-cell.))) + (declare ,(make-pv-type-declaration pv) + ,(make-calls-type-declaration calls)) + ,pv ,calls + ,@forms))) + (declare (enable-package-locks pv-env)) + (fast-lexical-method-functions + (,(car lmf-params) .next-method-call. ,req-args ,rest-arg + ,@(cdddr lmf-params)) + ,@inner-decls + ,@body-sans-decls))) + ',initargs)))) ;;; Use arrays and hash tables and the fngen stuff to make this much ;;; better. It doesn't really matter, though, because a function @@ -1127,49 +1141,43 @@ (defun method-function-from-fast-function (fmf) (declare (type function fmf)) (let* ((method-function nil) (pv-table nil) - (arg-info (method-function-get fmf :arg-info)) - (nreq (car arg-info)) - (restp (cdr arg-info))) + (arg-info (method-function-get fmf :arg-info)) + (nreq (car arg-info)) + (restp (cdr arg-info))) (setq method-function - (lambda (method-args next-methods) - (unless pv-table - (setq pv-table (method-function-pv-table fmf))) - (let* ((pv-cell (when pv-table - (get-method-function-pv-cell - method-function method-args pv-table))) - (nm (car next-methods)) - (nms (cdr next-methods)) - (nmc (when nm - (make-method-call - :function (if (std-instance-p nm) - (method-function nm) - nm) - :call-method-args (list nms))))) - (if restp - (let* ((rest (nthcdr nreq method-args)) - (args (ldiff method-args rest))) - (apply fmf pv-cell nmc (nconc args (list rest)))) - (apply fmf pv-cell nmc method-args))))) + (lambda (method-args next-methods) + (unless pv-table + (setq pv-table (method-function-pv-table fmf))) + (let* ((pv-cell (when pv-table + (get-method-function-pv-cell + method-function method-args pv-table))) + (nm (car next-methods)) + (nms (cdr next-methods)) + (nmc (when nm + (make-method-call + :function (if (std-instance-p nm) + (method-function nm) + nm) + :call-method-args (list nms))))) + (if restp + (let* ((rest (nthcdr nreq method-args)) + (args (ldiff method-args rest))) + (apply fmf pv-cell nmc (nconc args (list rest)))) + (apply fmf pv-cell nmc method-args))))) (let* ((fname (method-function-get fmf :name)) - (name `(,(or (get (car fname) 'method-sym) - (setf (get (car fname) 'method-sym) - (let ((str (symbol-name (car fname)))) - (if (string= "FAST-" str :end2 5) - (format-symbol *pcl-package* (subseq str 5)) - (car fname))))) - ,@(cdr fname)))) + (name (cons 'slow-method (cdr fname)))) (set-fun-name method-function name)) (setf (method-function-get method-function :fast-function) fmf) method-function)) (defun get-method-function-pv-cell (method-function - method-args - &optional pv-table) + method-args + &optional pv-table) (let ((pv-table (or pv-table (method-function-pv-table method-function)))) (when pv-table (let ((pv-wrappers (pv-wrappers-from-all-args pv-table method-args))) - (when pv-wrappers - (pv-table-lookup pv-table pv-wrappers)))))) + (when pv-wrappers + (pv-table-lookup pv-table pv-wrappers)))))) (defun pv-table-lookup-pv-args (pv-table &rest pv-parameters) (pv-table-lookup pv-table (pv-wrappers-from-pv-args pv-parameters))) @@ -1178,10 +1186,10 @@ (let (wrappers) (dolist (arg args (if (cdr wrappers) (nreverse wrappers) (car wrappers))) (let ((wrapper (wrapper-of arg))) - (push (if (invalid-wrapper-p wrapper) - (check-wrapper-validity wrapper) - wrapper) - wrappers))))) + (push (if (invalid-wrapper-p wrapper) + (check-wrapper-validity wrapper) + wrapper) + wrappers))))) (defun pv-wrappers-from-all-args (pv-table args) (loop for snl in (pv-table-slot-name-lists pv-table) and arg in args diff --git a/tests/clos-typechecking.impure.lisp b/tests/clos-typechecking.impure.lisp new file mode 100644 index 000000000..9422bd9d4 --- /dev/null +++ b/tests/clos-typechecking.impure.lisp @@ -0,0 +1,144 @@ +(load "assertoid.lisp") + +(defpackage "FOO" + (:use "CL" "ASSERTOID")) +(in-package "FOO") + +(defclass foo () + ((slot :initarg :slot :type fixnum :accessor slot))) +(defclass foo/gf (sb-mop:standard-generic-function) + ((slot/gf :initarg :slot/gf :type fixnum :accessor slot/gf)) + (:metaclass sb-mop:funcallable-standard-class)) +(defmethod succeed/sv ((x foo)) + (setf (slot-value x 'slot) 1)) +(defmethod fail/sv ((x foo)) + (setf (slot-value x 'slot) t)) +(defmethod succeed/acc ((x foo)) + (setf (slot x) 1)) +(defmethod fail/acc ((x foo)) + (setf (slot x) t)) +(defmethod succeed/sv/gf ((x foo/gf)) + (setf (slot-value x 'slot/gf) 1)) +(defmethod fail/sv/gf ((x foo/gf)) + (setf (slot-value x 'slot/gf) t)) +(defmethod succeed/acc/gf ((x foo/gf)) + (setf (slot/gf x) 1)) +(defmethod fail/acc/gf ((x foo/gf)) + (setf (slot/gf x) t)) +(defvar *t* t) +(defvar *one* 1) + +;; evaluator +(eval '(setf (slot-value (make-instance 'foo) 'slot) 1)) +(assert (raises-error? (eval '(setf (slot-value (make-instance 'foo) 'slot) t)) + type-error)) +(eval '(setf (slot (make-instance 'foo)) 1)) +(assert (raises-error? (eval '(setf (slot (make-instance 'foo)) t)) + type-error)) +(eval '(succeed/sv (make-instance 'foo))) +(assert (raises-error? (eval '(fail/sv (make-instance 'foo))) + type-error)) +(eval '(succeed/acc (make-instance 'foo))) +(assert (raises-error? (eval '(fail/acc (make-instance 'foo))) + type-error)) +(eval '(make-instance 'foo :slot 1)) +(assert (raises-error? (eval '(make-instance 'foo :slot t)) + type-error)) +(eval '(make-instance 'foo :slot *one*)) +(assert (raises-error? (eval '(make-instance 'foo :slot *t*)) + type-error)) +;; evaluator/gf +(eval '(setf (slot-value (make-instance 'foo/gf) 'slot/gf) 1)) +(assert (raises-error? + (eval '(setf (slot-value (make-instance 'foo/gf) 'slot/gf) t)) + type-error)) +(eval '(setf (slot/gf (make-instance 'foo/gf)) 1)) +(assert (raises-error? (eval '(setf (slot/gf (make-instance 'foo/gf)) t)) + type-error)) +(eval '(succeed/sv/gf (make-instance 'foo/gf))) +#+nil ; funcallable standard instance slot-value access go through + ; ACCESSOR-SLOT-VALUE because their classes are not + ; STANDARD-CLASS-P. +(assert (raises-error? (eval '(fail/sv/gf (make-instance 'foo/gf))) + type-error)) +(eval '(succeed/acc/gf (make-instance 'foo/gf))) +(assert (raises-error? (eval '(fail/acc/gf (make-instance 'foo/gf))) + type-error)) +(eval '(make-instance 'foo/gf :slot/gf 1)) +(assert (raises-error? (eval '(make-instance 'foo/gf :slot/gf t)) + type-error)) +(eval '(make-instance 'foo/gf :slot/gf *one*)) +(assert (raises-error? (eval '(make-instance 'foo/gf :slot/gf *t*)) + type-error)) + +;; compiler +(funcall (compile nil '(lambda () + (setf (slot-value (make-instance 'foo) 'slot) 1)))) +#+nil ; this one still fails goddamit. +(assert (raises-error? + (funcall + (compile nil '(lambda () + (setf (slot-value (make-instance 'foo) 'slot) t)))) + type-error)) +(funcall (compile nil '(lambda () (setf (slot (make-instance 'foo)) 1)))) +(assert (raises-error? + (funcall + (compile nil '(lambda () (setf (slot (make-instance 'foo)) t)))) + type-error)) +(funcall (compile nil '(lambda () (succeed/sv (make-instance 'foo))))) +(assert (raises-error? + (funcall (compile nil '(lambda () (fail/sv (make-instance 'foo))))) + type-error)) +(funcall (compile nil '(lambda () (succeed/acc (make-instance 'foo))))) +(assert (raises-error? + (funcall (compile nil '(lambda () (fail/acc (make-instance 'foo))))) + type-error)) +(funcall (compile nil '(lambda () (make-instance 'foo :slot 1)))) +(assert (raises-error? + (funcall (compile nil '(lambda () (make-instance 'foo :slot t)))) + type-error)) +(funcall (compile nil '(lambda () (make-instance 'foo :slot *one*)))) +(assert (raises-error? + (funcall (compile nil '(lambda () (make-instance 'foo :slot *t*)))) + type-error)) +;; compiler/gf +(funcall (compile nil + '(lambda () + (setf (slot-value (make-instance 'foo/gf) 'slot/gf) 1)))) +#+nil ; this one too +(assert (raises-error? + (funcall + (compile nil + '(lambda () + (setf (slot-value (make-instance 'foo/gf) 'slot/gf) t)))) + type-error)) +(funcall (compile nil '(lambda () (setf (slot/gf (make-instance 'foo/gf)) 1)))) +(assert (raises-error? + (funcall + (compile nil + '(lambda () (setf (slot/gf (make-instance 'foo/gf)) t)))) + type-error)) +(funcall (compile nil '(lambda () (succeed/sv/gf (make-instance 'foo/gf))))) +#+nil ; see above +(assert (raises-error? + (funcall (compile nil '(lambda () + (fail/sv/gf (make-instance 'foo/gf))))) + type-error)) +(funcall (compile nil '(lambda () (succeed/acc/gf (make-instance 'foo/gf))))) +(assert (raises-error? + (funcall (compile nil '(lambda () + (fail/acc/gf (make-instance 'foo/gf))))) + type-error)) +(funcall (compile nil '(lambda () (make-instance 'foo/gf :slot/gf 1)))) +(assert (raises-error? + (funcall (compile nil '(lambda () + (make-instance 'foo/gf :slot/gf t)))) + type-error)) +(funcall (compile nil '(lambda () (make-instance 'foo/gf :slot/gf *one*)))) +(assert (raises-error? + (funcall (compile nil '(lambda () + (make-instance 'foo/gf :slot/gf *t*)))) + type-error)) + +;;;; success +(sb-ext:quit :unix-status 104) diff --git a/tests/mop.impure-cload.lisp b/tests/mop.impure-cload.lisp index 56a0ddbbf..5299d4f7f 100644 --- a/tests/mop.impure-cload.lisp +++ b/tests/mop.impure-cload.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -23,9 +23,9 @@ ;;; A distilled test case from cmucl-imp for Kevin Rosenberg's ;;; hyperobject. Fix from Gerd Moellmann. (defclass hyperobject-class (standard-class) - ((user-name :initarg :user-name :type string :initform nil - :accessor user-name - :documentation "User name for class"))) + ((user-name :initarg :user-name :type (or null string) :initform nil + :accessor user-name + :documentation "User name for class"))) (defclass hyperobject-dsd (standard-direct-slot-definition) ()) @@ -34,7 +34,7 @@ ((vc :initform 42))) (defmethod validate-superclass ((class hyperobject-class) - (superclass standard-class)) + (superclass standard-class)) t) (defmethod compute-effective-slot-definition :around @@ -57,6 +57,3 @@ (eval '(make-instance 'person :name t)) - -;;; success -(sb-ext:quit :unix-status 104) \ No newline at end of file diff --git a/version.lisp-expr b/version.lisp-expr index d714bf7ad..d6c6025f3 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.18.11" +"0.9.6.56.clos-typechecking2.1"