(defun make-structure-class-defstruct-form (name direct-slots include)
(let* ((conc-name (intern (format nil "~S structure class " name)))
- (constructor (intern (format nil "~A constructor" conc-name)))
+ (constructor (intern (format nil "~Aconstructor" conc-name)))
(defstruct `(defstruct (,name
,@(when include
`((:include ,(class-name include))))
- (:print-function print-std-instance)
(:predicate nil)
(:conc-name ,conc-name)
(:constructor ,constructor ())
(let ((method (get-method generic-function () (list class) nil)))
(when method (remove-method generic-function method))))
\f
-;;; make-reader-method-function and make-write-method function are NOT part of
-;;; the standard protocol. They are however useful, PCL makes uses makes use
-;;; of them internally and documents them for PCL users.
+;;; MAKE-READER-METHOD-FUNCTION and MAKE-WRITE-METHOD function are NOT
+;;; part of the standard protocol. They are however useful, PCL makes
+;;; use of them internally and documents them for PCL users.
;;;
;;; *** This needs work to make type testing by the writer functions which
;;; *** do type testing faster. The idea would be to have one constructor
;;;
;;; *** There is a subtle bug here which is going to have to be fixed.
;;; *** Namely, the simplistic use of the template has to be fixed. We
-;;; *** have to give the optimize-slot-value method the user might have
+;;; *** have to give the OPTIMIZE-SLOT-VALUE method the user might have
;;; *** defined for this metaclass a chance to run.
(defmethod make-reader-method-function ((class slot-class) slot-name)
(eq (class-of class) new-super-meta-class))))
\f
(defun force-cache-flushes (class)
- (let* ((owrapper (class-wrapper class))
- (state (wrapper-state owrapper)))
+ (let* ((owrapper (class-wrapper class)))
;; We only need to do something if the state is still T. If the
;; state isn't T, it will be FLUSH or OBSOLETE, and both of those
;; will already be doing what we want. In particular, we must be
;; sure we never change an OBSOLETE into a FLUSH since OBSOLETE
;; means do what FLUSH does and then some.
- (when (eq state t) ; FIXME: should be done through INVALID-WRAPPER-P
+ (unless (invalid-wrapper-p owrapper)
(let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
class)))
(setf (wrapper-instance-slots-layout nwrapper)
(declare (ignore owrapper))
(set-wrapper instance nwrapper))
\f
-;;; make-instances-obsolete can be called by user code. It will cause the
-;;; next access to the instance (as defined in 88-002R) to trap through the
-;;; update-instance-for-redefined-class mechanism.
+;;; MAKE-INSTANCES-OBSOLETE can be called by user code. It will cause
+;;; the next access to the instance (as defined in 88-002R) to trap
+;;; through the UPDATE-INSTANCE-FOR-REDEFINED-CLASS mechanism.
(defmethod make-instances-obsolete ((class std-class))
(let* ((owrapper (class-wrapper class))
(nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
(defmethod make-instances-obsolete ((class symbol))
(make-instances-obsolete (find-class class)))
-;;; obsolete-instance-trap is the internal trap that is called when we see
-;;; an obsolete instance. The times when it is called are:
+;;; OBSOLETE-INSTANCE-TRAP is the internal trap that is called when we
+;;; see an obsolete instance. The times when it is called are:
;;; - when the instance is involved in method lookup
;;; - when attempting to access a slot of an instance
;;;
;;; sure that the traps are only happening when they should, and that
;;; the trap methods are computing appropriate new wrappers.
-;;; obsolete-instance-trap might be called on structure instances
-;;; after a structure is redefined. In most cases, obsolete-instance-trap
-;;; will not be able to fix the old instance, so it must signal an
-;;; error. The hard part of this is that the error system and debugger
-;;; might cause obsolete-instance-trap to be called again, so in that
-;;; case, we have to return some reasonable wrapper, instead.
+;;; OBSOLETE-INSTANCE-TRAP might be called on structure instances
+;;; after a structure is redefined. In most cases,
+;;; OBSOLETE-INSTANCE-TRAP will not be able to fix the old instance,
+;;; so it must signal an error. The hard part of this is that the
+;;; error system and debugger might cause OBSOLETE-INSTANCE-TRAP to be
+;;; called again, so in that case, we have to return some reasonable
+;;; wrapper, instead.
(defvar *in-obsolete-instance-trap* nil)
(defvar *the-wrapper-of-structure-object*
plist)
nwrapper)))
\f
-(defmacro copy-instance-internal (instance)
- `(progn
- (let* ((class (class-of instance))
- (copy (allocate-instance class)))
- (if (std-instance-p ,instance)
- (setf (std-instance-slots ,instance)
- (std-instance-slots ,instance))
- (setf (fsc-instance-slots ,instance)
- (fsc-instance-slots ,instance)))
- copy)))
-
-(defun change-class-internal (instance new-class)
+(defun change-class-internal (instance new-class initargs)
(let* ((old-class (class-of instance))
(copy (allocate-instance new-class))
(new-wrapper (get-wrapper copy))
;; old instance point to the new storage.
(swap-wrappers-and-slots instance copy)
- (update-instance-for-different-class copy instance)
+ (apply #'update-instance-for-different-class copy instance initargs)
instance))
(defmethod change-class ((instance standard-object)
- (new-class standard-class))
- (change-class-internal instance new-class))
+ (new-class standard-class)
+ &rest initargs)
+ (change-class-internal instance new-class initargs))
(defmethod change-class ((instance funcallable-standard-object)
- (new-class funcallable-standard-class))
- (change-class-internal instance new-class))
+ (new-class funcallable-standard-class)
+ &rest initargs)
+ (change-class-internal instance new-class initargs))
(defmethod change-class ((instance standard-object)
- (new-class funcallable-standard-class))
+ (new-class funcallable-standard-class)
+ &rest initargs)
+ (declare (ignore initargs))
(error "You can't change the class of ~S to ~S~@
because it isn't already an instance with metaclass ~S."
instance new-class 'standard-class))
(defmethod change-class ((instance funcallable-standard-object)
- (new-class standard-class))
+ (new-class standard-class)
+ &rest initargs)
+ (declare (ignore initargs))
(error "You can't change the class of ~S to ~S~@
because it isn't already an instance with metaclass ~S."
instance new-class 'funcallable-standard-class))
-(defmethod change-class ((instance t) (new-class-name symbol))
- (change-class instance (find-class new-class-name)))
+(defmethod change-class ((instance t) (new-class-name symbol) &rest initargs)
+ (apply #'change-class instance (find-class new-class-name) initargs))
\f
;;;; The metaclass BUILT-IN-CLASS
;;;;
projects / sbcl.git / blobdiff