common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

0.9.6.56.clos-typechecking2.1:

Browse source 
Forward-port clos-typechecking-branch to HEAD.
	... no new fixes, but I think I have some ideas for how to move
		forward:
	* the optimized slot setters, and probably also the
	  non-optimized path through (setf slot-value-using-class),
	  should cache the type checking predicate, rather than calling
	  TYPEP or %%TYPEP every time
	* (SAFETY 3) should probably be replaced with (SB-C::TYPE-CHECKS
	  3) or whatever it's called
	* FUNCTION types...
	* need tests of redefinition &
	  UPDATE-INSTANCE-FOR-REDEFINED-CLASS; subclasses with
	  intersection types.
	* it might be possible to perform some limited inference in
	  method functions.
This commit is contained in:
Christophe Rhodes 2005-11-24 14:30:31 +00:00
parent 5771a50eef
commit bd706ec62f
9 changed files with 3391 additions and 3054 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

773
src/pcl/ctor.lisp
View file

@ -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))))

1919
src/pcl/dfun.lisp
View file

File diff suppressed because it is too large Load diff

671
src/pcl/slots-boot.lisp
View file

@ -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 "~@<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)))))
(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 "~@<The wrapper for class ~S does not have ~
(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 "~@<The wrapper for class ~S does not have ~
the slot ~S~@:>"
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))))

276
src/pcl/slots.lisp
View file

@ -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 "~@<When attempting to ~A, the slot ~S is missing from the ~
object ~S.~@:>"
(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

1333
src/pcl/std-class.lisp
View file

File diff suppressed because it is too large Load diff

1314
src/pcl/vector.lisp
View file

File diff suppressed because it is too large Load diff

144
tests/clos-typechecking.impure.lisp Normal file
View file

@ -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)

13
tests/mop.impure-cload.lisp
View file

@ -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)

2
version.lisp-expr
View file

@ -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"