:initial-element +slot-unbound+))))
instance))
-(defmacro allocate-funcallable-instance-slots (wrapper &optional
- slots-init-p slots-init)
+(defmacro allocate-standard-funcallable-instance-slots
+ (wrapper &optional slots-init-p slots-init)
`(let ((no-of-slots (wrapper-no-of-instance-slots ,wrapper)))
- ,(if slots-init-p
- `(if ,slots-init-p
- (make-array no-of-slots :initial-contents ,slots-init)
- (make-array no-of-slots :initial-element +slot-unbound+))
- `(make-array no-of-slots :initial-element +slot-unbound+))))
-
-(defun allocate-funcallable-instance (wrapper &optional
- (slots-init nil slots-init-p))
- (let ((fin (%make-pcl-funcallable-instance nil nil
- (get-instance-hash-code))))
+ ,(if slots-init-p
+ `(if ,slots-init-p
+ (make-array no-of-slots :initial-contents ,slots-init)
+ (make-array no-of-slots :initial-element +slot-unbound+))
+ `(make-array no-of-slots :initial-element +slot-unbound+))))
+
+(define-condition unset-funcallable-instance-function
+ (reference-condition simple-error)
+ ()
+ (:default-initargs
+ :references (list '(:amop :generic-function allocate-instance)
+ '(:amop :function set-funcallable-instance-function))))
+
+(defun allocate-standard-funcallable-instance
+ (wrapper &optional (slots-init nil slots-init-p))
+ (let ((fin (%make-standard-funcallable-instance
+ nil nil (get-instance-hash-code))))
(set-funcallable-instance-function
fin
#'(lambda (&rest args)
(declare (ignore args))
- (error "The function of the funcallable-instance ~S has not been set."
- fin)))
+ (error 'unset-funcallable-instance-function
+ :format-control "~@<The function of funcallable instance ~
+ ~S has not been set.~@:>"
+ :format-arguments (list fin))))
(setf (fsc-instance-wrapper fin) wrapper
- (fsc-instance-slots fin) (allocate-funcallable-instance-slots
- wrapper slots-init-p slots-init))
+ (fsc-instance-slots fin)
+ (allocate-standard-funcallable-instance-slots
+ wrapper slots-init-p slots-init))
fin))
(defun allocate-structure-instance (wrapper &optional
()))
(setq proto (if (eq meta 'funcallable-standard-class)
- (allocate-funcallable-instance wrapper)
+ (allocate-standard-funcallable-instance wrapper)
(allocate-standard-instance wrapper)))
(setq direct-slots
(list class-name)
(list class-name)
"automatically generated boundp method")))
- (let ((gf (ensure-generic-function accessor-name
- :lambda-list arglist)))
+ (let ((gf (ensure-generic-function accessor-name :lambda-list arglist)))
(if (find specls (early-gf-methods gf)
:key #'early-method-specializers
:test 'equal)
(funcall make-method-function
class-name slot-name)
doc
- slot-name))))))
+ :slot-name slot-name
+ :object-class class-name
+ :method-class-function (constantly (find-class accessor-class))))))))
(defun !bootstrap-accessor-definitions1 (class-name
slot-name
(pushnew 'ensure-deffoo-class sb-kernel::*defstruct-hooks*)
(pushnew 'ensure-deffoo-class sb-kernel::*define-condition-hooks*)
\f
+;;; FIXME: only needed during bootstrap
(defun make-class-predicate (class name)
(let* ((gf (ensure-generic-function name :lambda-list '(object)))
(mlist (if (eq *boot-state* 'complete)
(unless mlist
(unless (eq class *the-class-t*)
(let* ((default-method-function #'constantly-nil)
- (default-method-initargs (list :function
- default-method-function))
+ (default-method-initargs (list :function default-method-function
+ 'plist '(:constant-value nil)))
(default-method (make-a-method
'standard-method
()
(list *the-class-t*)
default-method-initargs
"class predicate default method")))
- (setf (method-function-get default-method-function :constant-value)
- nil)
(add-method gf default-method)))
(let* ((class-method-function #'constantly-t)
- (class-method-initargs (list :function
- class-method-function))
+ (class-method-initargs (list :function class-method-function
+ 'plist '(:constant-value t)))
(class-method (make-a-method 'standard-method
()
(list 'object)
(list class)
class-method-initargs
"class predicate class method")))
- (setf (method-function-get class-method-function :constant-value) t)
(add-method gf class-method)))
gf))