(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 ()
(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.
(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)
(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.
;;; 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)
;; 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)
(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)
(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))
(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))
,@(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
(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*
(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)
(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 "~@<The slot ~S has neither ~S nor ~S ~
+ allocation, so it can't be ~A by the default ~
+ ~S method.~@:>"
+ (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)
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))
(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))
(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
(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)
(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 "~@<The slot ~S has neither :INSTANCE nor :CLASS ~
- allocation, so it can't be read by the default ~
- ~S method.~@:>"
- 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)))
((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 "~@<The slot ~S has neither :INSTANCE nor :CLASS allocation, ~
- so it can't be written by the default ~S method.~:@>"
- slotd '(setf slot-value-using-class))))))
+ (instance-structure-protocol-error slotd
+ '(setf slot-value-using-class))))))
(defmethod slot-boundp-using-class
((class std-class)
(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 "~@<The slot ~S has neither :INSTANCE nor :CLASS ~
- allocation, so it can't be read by the default ~S ~
- method.~@:>"
- 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
((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 "~@<The slot ~S has neither :INSTANCE nor :CLASS allocation, ~
- so it can't be written by the default ~S method.~@:>"
- slotd 'slot-makunbound-using-class))))
+ (instance-structure-protocol-error slotd
+ 'slot-makunbound-using-class))))
object)
(defmethod slot-value-using-class
projects / sbcl.git / commitdiff