From: Christophe Rhodes Date: Mon, 12 Jul 2004 19:34:02 +0000 (+0000) Subject: 0.8.12.28: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=b305d276b905654e4877cc49d03a2d3c9187cdff;p=sbcl.git 0.8.12.28: Better error messages for when the MOP instance structure protocol is violated (e.g. by the user defining a class with slots with non-standard :allocation, but no methods to go with it) ... new :amop reference source; ... new instance-structure-protocol-error condition. Should probably eventually become a subclass of MOP-ERROR, once we start accumulating those; ... move implementation of slot-valueish logic around a little to support these better error messages. (the ctor.lisp optimization is broken in the presence of non-standard slot allocation, and also in the presence of auxiliary methods on slot-value-using-classish generic functions. Working on it...) --- diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 65e9697..5b471c0 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -792,6 +792,13 @@ ;;; FIXME: this is not the right place for this. (defun print-reference (reference stream) (ecase (car reference) + (:amop + (format stream "AMOP") + (format stream ", ") + (destructuring-bind (type data) (cdr reference) + (ecase type + (:generic-function (format stream "Generic Function ~S" data)) + (:section (format stream "Section ~{~D~^.~}" data))))) (:ansi-cl (format stream "The ANSI Standard") (format stream ", ") diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 0c62370..6d3eb82 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -373,11 +373,11 @@ (set-val 'location index) (let ((fsc-p nil)) (set-val 'reader-function (make-optimized-std-reader-method-function - fsc-p slot-name index)) + fsc-p nil slot-name index)) (set-val 'writer-function (make-optimized-std-writer-method-function - fsc-p slot-name index)) + fsc-p nil slot-name index)) (set-val 'boundp-function (make-optimized-std-boundp-method-function - fsc-p slot-name index))) + fsc-p nil slot-name index))) (set-val 'accessor-flags 7) (let ((table (or (gethash slot-name *name->class->slotd-table*) (setf (gethash slot-name *name->class->slotd-table*) diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index 5a3dd01..fddc971 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -175,13 +175,11 @@ (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 () @@ -192,7 +190,6 @@ (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. @@ -208,7 +205,6 @@ (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) @@ -216,7 +212,6 @@ (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. @@ -239,12 +234,10 @@ ;;; Load-Time Constructor Function Generation ******* ;;; ************************************************** -;;; ;;; The system-supplied primary INITIALIZE-INSTANCE and -;;; SHARED-INITIALIZE methods. One cannot initialized these variables +;;; SHARED-INITIALIZE methods. One cannot initialize these variables ;;; to the right values here because said functions don't exist yet ;;; when this file is first loaded. -;;; (defvar *the-system-ii-method* nil) (defvar *the-system-si-method* nil) @@ -260,6 +253,9 @@ ;; 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)))))) (defun constructor-function-form (ctor) @@ -316,6 +312,11 @@ (defun fallback-generator (ctor ii-methods si-methods) (declare (ignore ii-methods si-methods)) `(instance-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, + ;; so removing the possibility of endless recursion. -- CSR, + ;; 2004-07-12 (make-instance ,(ctor-class ctor) ,@(ctor-initargs ctor)))) (defun optimizing-generator (ctor ii-methods si-methods) @@ -325,14 +326,12 @@ (declare #.*optimize-speed*) ,(wrap-in-allocate-forms ctor body before-method-p)))) -;;; ;;; Return a form wrapped around BODY that allocates an instance ;;; constructed by CTOR. BEFORE-METHOD-P set means we have to run ;;; before-methods, in which case we initialize instance slots to ;;; +SLOT-UNBOUND+. The resulting form binds the local variables ;;; .INSTANCE. to the instance, and .SLOTS. to the instance's slot ;;; vector around BODY. -;;; (defun wrap-in-allocate-forms (ctor body before-method-p) (let* ((class (ctor-class ctor)) (wrapper (class-wrapper class)) @@ -468,18 +467,16 @@ (if (consp location) (class-init location 'constant value) (instance-init location 'constant value))) - (dolist (location locations) + (dolist (location locations) (if (consp location) (class-init location 'param value) (instance-init location 'param value))))) - ;; ;; 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)) @@ -552,11 +549,9 @@ ,@(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. -;;; (defun compute-initarg-locations (class initkeys) (loop with slots = (class-slots class) for key in initkeys collect @@ -584,11 +579,9 @@ (dolist (subclass (class-direct-subclasses class)) (reset subclass ri-cache-p ctorsp)))) (ecase reason - ;; ;; CLASS must have been specified. (finalize-inheritance (reset class t)) - ;; ;; NAME must have been specified. (setf-find-class (loop for ctor in *all-ctors* @@ -596,7 +589,6 @@ (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) diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp index 236fc86..ee7e2e3 100644 --- a/src/pcl/init.lisp +++ b/src/pcl/init.lisp @@ -178,12 +178,13 @@ (setq legal (append keys legal)))) (values legal nil))) -(define-condition initarg-error (program-error) +(define-condition initarg-error (reference-condition program-error) ((class :reader initarg-error-class :initarg :class) (initargs :reader initarg-error-initargs :initarg :initargs)) + (:default-initargs :references (list '(:ansi-cl :section (7 1 2)))) (:report (lambda (condition stream) - (format stream "~@~I~_in call for class ~S.~:>" + (format stream "~@~I~_in call for class ~S.~:>" (length (initarg-error-initargs condition)) (list (initarg-error-initargs condition)) (initarg-error-class condition))))) diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index 354e3e5..dc7b804 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -138,6 +138,30 @@ (declare (ignore object)) t)) +(define-condition instance-structure-protocol-error + (reference-condition error) + ((slotd :initarg :slotd :reader instance-structure-protocol-error-slotd) + (fun :initarg :fun :reader instance-structure-protocol-error-fun)) + (:report + (lambda (c s) + (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))))) + +(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))))) + (defun get-optimized-std-accessor-method-function (class slotd name) (cond ((structure-class-p class) @@ -161,31 +185,38 @@ nil) (t (error "~S is not a STANDARD-CLASS." class)))) (slot-name (slot-definition-name slotd)) - (index (slot-definition-location 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))) - (value (funcall function fsc-p slot-name index))) + ;; 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 index))))) + (values value (slot-definition-location slotd)))))) -(defun make-optimized-std-reader-method-function (fsc-p slot-name index) +(defun make-optimized-std-reader-method-function + (fsc-p slotd slot-name location) (declare #.*optimize-speed*) (set-fun-name - (etypecase index + (etypecase location (fixnum (if fsc-p (lambda (instance) (check-obsolete-instance instance) - (let ((value (clos-slots-ref (fsc-instance-slots instance) index))) + (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) index))) + (let ((value (clos-slots-ref (std-instance-slots instance) + location))) (if (eq value +slot-unbound+) (values (slot-unbound (class-of instance) instance slot-name)) @@ -193,74 +224,74 @@ (cons (lambda (instance) (check-obsolete-instance instance) - (let ((value (cdr index))) + (let ((value (cdr location))) (if (eq value +slot-unbound+) (values (slot-unbound (class-of instance) instance slot-name)) value)))) (null (lambda (instance) - ;; maybe MOP-ERROR? You get here by making effective slot - ;; definitions with :ALLOCATION not :INSTANCE or :CLASS, and - ;; not defining any methods on SLOT-VALUE-USING-CLASS. - (error "~S called on ~S for the slot ~S (with no location information)" - 'slot-value instance slot-name)))) + (instance-structure-protocol-error slotd 'slot-value-using-class)))) `(reader ,slot-name))) -(defun make-optimized-std-writer-method-function (fsc-p slot-name index) +(defun make-optimized-std-writer-method-function + (fsc-p slotd slot-name location) (declare #.*optimize-speed*) (set-fun-name - (etypecase index + (etypecase location (fixnum (if fsc-p (lambda (nv instance) (check-obsolete-instance instance) - (setf (clos-slots-ref (fsc-instance-slots instance) index) + (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) index) + (setf (clos-slots-ref (std-instance-slots instance) + location) nv)))) - (cons (lambda (nv instance) - (check-obsolete-instance instance) - (setf (cdr index) nv))) + (cons (lambda (nv instance) + (check-obsolete-instance instance) + (setf (cdr location) nv))) (null (lambda (nv instance) (declare (ignore nv)) - ;; again, maybe MOP-ERROR (see above) - (error "~S called on ~S for the slot ~S (with no location information)" - '(setf slot-value) instance slot-name)))) + (instance-structure-protocol-error slotd + '(setf slot-value-using-class))))) `(writer ,slot-name))) -(defun make-optimized-std-boundp-method-function (fsc-p slot-name index) +(defun make-optimized-std-boundp-method-function + (fsc-p slotd slot-name location) (declare #.*optimize-speed*) (set-fun-name - (etypecase index + (etypecase location (fixnum (if fsc-p (lambda (instance) (check-obsolete-instance instance) (not (eq (clos-slots-ref (fsc-instance-slots instance) - index) + location) +slot-unbound+))) (lambda (instance) (check-obsolete-instance instance) (not (eq (clos-slots-ref (std-instance-slots instance) - index) + location) +slot-unbound+))))) (cons (lambda (instance) (check-obsolete-instance instance) - (not (eq (cdr index) +slot-unbound+)))) + (not (eq (cdr location) +slot-unbound+)))) (null (lambda (instance) - (error "~S called on ~S for the slot ~S (with no location information)" - 'slot-boundp instance slot-name)))) + (instance-structure-protocol-error slotd 'slot-boundp-using-class)))) `(boundp ,slot-name))) -(defun make-optimized-structure-slot-value-using-class-method-function (function) +(defun make-optimized-structure-slot-value-using-class-method-function + (function) (declare (type function function)) (lambda (class object slotd) (declare (ignore class slotd)) (funcall function object))) -(defun make-optimized-structure-setf-slot-value-using-class-method-function (function) +(defun make-optimized-structure-setf-slot-value-using-class-method-function + (function) (declare (type function function)) (lambda (nv class object slotd) (declare (ignore class slotd)) @@ -305,8 +336,6 @@ (let* ((fsc-p (cond ((standard-class-p class) nil) ((funcallable-standard-class-p class) t) (t (error "~S is not a standard-class" class)))) - (slot-name (slot-definition-name slotd)) - (index (slot-definition-location slotd)) (function (ecase name (reader @@ -316,90 +345,95 @@ (boundp #'make-optimized-std-slot-boundp-using-class-method-function)))) (declare (type function function)) - (values (funcall function fsc-p slot-name index) index))))) + (values (funcall function fsc-p slotd) + (slot-definition-location slotd)))))) -(defun make-optimized-std-slot-value-using-class-method-function - (fsc-p slot-name index) +(defun make-optimized-std-slot-value-using-class-method-function (fsc-p slotd) (declare #.*optimize-speed*) - (etypecase index - (fixnum (if fsc-p - (lambda (class instance slotd) - (declare (ignore slotd)) - (check-obsolete-instance instance) - (let ((value (clos-slots-ref (fsc-instance-slots instance) - index))) - (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) - index))) - (if (eq value +slot-unbound+) - (values (slot-unbound class instance slot-name)) - value))))) - (cons (lambda (class instance slotd) + (let ((location (slot-definition-location 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))))) + (cons (lambda (class instance slotd) (declare (ignore slotd)) (check-obsolete-instance instance) - (let ((value (cdr index))) + (let ((value (cdr location))) (if (eq value +slot-unbound+) (values (slot-unbound class instance slot-name)) value)))) - (null - (lambda (class instance slotd) - ;; FIXME: MOP-ERROR - (error "Standard ~S method called on arguments ~S." - 'slot-value-using-class (list class instance slotd)))))) + (null + (lambda (class instance slotd) + (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 slot-name index) + (fsc-p slotd) (declare #.*optimize-speed*) - (declare (ignore slot-name)) - (etypecase index - (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) index) - nv)) - (lambda (nv class instance slotd) - (declare (ignore class slotd)) - (check-obsolete-instance instance) - (setf (clos-slots-ref (std-instance-slots instance) index) - nv)))) - (cons (lambda (nv class instance slotd) + (let ((location (slot-definition-location 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 (cdr index) nv))) - (null (lambda (nv class instance slotd) - (error "Standard ~S method called on arguments ~S." - '(setf slot-value-using-class) - (list nv class instance slotd)))))) + (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))) + (null (lambda (nv class instance slotd) + (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 slot-name index) + (fsc-p slotd) (declare #.*optimize-speed*) - (declare (ignore slot-name)) - (etypecase index - (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) index) - +slot-unbound+))) - (lambda (class instance slotd) - (declare (ignore class slotd)) - (check-obsolete-instance instance) - (not (eq (clos-slots-ref (std-instance-slots instance) index) - +slot-unbound+))))) - (cons (lambda (class instance slotd) + (let ((location (slot-definition-location slotd))) + (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+))))) + (cons (lambda (class instance slotd) (declare (ignore class slotd)) (check-obsolete-instance instance) - (not (eq (cdr index) +slot-unbound+)))) - (null (lambda (class instance slotd) - (error "Standard ~S method called on arguments ~S." - 'slot-boundp-using-class (list class instance slotd)))))) + (not (eq (cdr location) +slot-unbound+)))) + (null + (lambda (class instance slotd) + (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) diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index 69232a7..7cae742 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -154,22 +154,22 @@ (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 (error "unrecognized instance type")))) - (cons - (cdr location)) - (t - (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))) @@ -188,13 +188,13 @@ ((fsc-instance-p object) (setf (clos-slots-ref (fsc-instance-slots object) location) new-value)) - (t (error "unrecognized instance type")))) + (t (bug "unrecognized instance type in ~S" + '(setf slot-value-using-class))))) (cons (setf (cdr location) new-value)) (t - (error "~@" - slotd '(setf slot-value-using-class)))))) + (instance-structure-protocol-error slotd + '(setf slot-value-using-class)))))) (defmethod slot-boundp-using-class ((class std-class) @@ -202,22 +202,22 @@ (slotd standard-effective-slot-definition)) (check-obsolete-instance object) (let* ((location (slot-definition-location slotd)) - (value (typecase location - (fixnum - (cond ((std-instance-p object) + (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 (error "unrecognized instance type")))) - (cons - (cdr location)) - (t - (error "~@" - slotd 'slot-boundp-using-class))))) + ((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 @@ -234,13 +234,13 @@ ((fsc-instance-p object) (setf (clos-slots-ref (fsc-instance-slots object) location) +slot-unbound+)) - (t (error "unrecognized instance type")))) + (t (bug "unrecognized instance type in ~S" + 'slot-makunbound-using-class)))) (cons (setf (cdr location) +slot-unbound+)) (t - (error "~@" - slotd 'slot-makunbound-using-class)))) + (instance-structure-protocol-error slotd + 'slot-makunbound-using-class)))) object) (defmethod slot-value-using-class diff --git a/version.lisp-expr b/version.lisp-expr index e738aa2..5b35b85 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.12.27" +"0.8.12.28"