mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-02 07:30:55 -08:00
Code Issues Projects Releases Packages Wiki Activity

Implemented the class redefinition protocol, and forward referenced classes.

Browse source
This commit is contained in:
jjgarcia 2003-12-15 08:54:10 +00:00
parent d4e8230777
commit 0290efd01c
18 changed files with 322 additions and 268 deletions
Download patch file Download diff file Expand all files Collapse all files

4
src/CHANGELOG
View file

@ -1790,6 +1790,10 @@ ECL 0.9d
- SXHASH now always returns positive fixnums and produces the same key for
two bitvectors which are EQUAL.
- Implemented the class redefinition protocol, which involves
CHANGE-CLASS, UPDATE-INSTANCE-FOR-{REDEFINED,NEW}-CLASS, and
MAKE-INSTANCES-OBSOLETE.
TODO:
=====

48
src/c/instance.d
View file

@ -27,40 +27,29 @@ ecl_allocate_instance(cl_object clas, int size)
}
cl_object
si_allocate_raw_instance(cl_object clas, cl_object size)
si_allocate_raw_instance(cl_object orig, cl_object clas, cl_object size)
{
@(return ecl_allocate_instance(clas, fixnnint(size)))
cl_object output = ecl_allocate_instance(clas, fixnnint(size));
if (orig == Cnil) {
orig = output;
} else {
orig->instance.clas = clas;
orig->instance.length = output->instance.length;
orig->instance.slots = output->instance.slots;
}
@(return orig)
}
/* corr is a list of (newi . oldi) describing which of the new slots
retains a value from an old slot
*/
cl_object
si_change_instance(cl_object x, cl_object clas, cl_object size, cl_object corr)
si_instance_sig(cl_object x)
{
int nslot, i;
cl_object * oldslots;
@(return x->instance.sig);
}
if (type_of(x) != t_instance)
FEwrong_type_argument(@'ext::instance', x);
if (type_of(clas) != t_instance)
FEwrong_type_argument(@'ext::instance', clas);
nslot = fixnnint(size);
CLASS_OF(x) = clas;
x->instance.length = nslot;
oldslots = x->instance.slots;
x->instance.slots = (cl_object *)cl_alloc_align(sizeof(cl_object)*nslot,sizeof(cl_object));
for (i = 0; i < nslot; i++) {
if (!Null(corr) && fix(CAAR(corr)) == i) {
x->instance.slots[i] = oldslots[fix(CDAR(corr))];
corr = CDR(corr);
}
else
x->instance.slots[i] = ECL_UNBOUND;
}
@(return) /* FIXME! Is this what we need? */
cl_object
si_instance_sig_set(cl_object x)
{
@(return (x->instance.sig = CLASS_SLOTS(CLASS_OF(x))));
}
cl_object
@ -181,13 +170,14 @@ si_sl_makunbound(cl_object x, cl_object index)
}
cl_object
ecl_copy_instance(cl_object x)
si_copy_instance(cl_object x)
{
cl_object y;
if (type_of(x) != t_instance)
FEwrong_type_argument(@'ext::instance', x);
y = ecl_allocate_instance(x->instance.clas, x->instance.length);
y->instance.sig = x->instance.sig;
memcpy(y->instance.slots, x->instance.slots,
x->instance.length * sizeof(cl_object));
@(return y)

2
src/c/structure.d
View file

@ -90,7 +90,7 @@ structure_to_list(cl_object x)
@)
#ifdef CLOS
#define ecl_copy_structure ecl_copy_instance
#define ecl_copy_structure si_copy_instance
#else
cl_object
ecl_copy_structure(cl_object x)

7
src/c/symbols_list.h
View file

@ -1025,7 +1025,7 @@ cl_symbols[] = {
{SYS_ ",", SI_ORDINARY, NULL, -1, OBJNULL},
{SYS_ ",.", SI_ORDINARY, NULL, -1, OBJNULL},
{SYS_ ",@", SI_ORDINARY, NULL, -1, OBJNULL},
{SYS_ "ALLOCATE-RAW-INSTANCE", SI_ORDINARY, si_allocate_raw_instance, 2, OBJNULL},
{SYS_ "ALLOCATE-RAW-INSTANCE", SI_ORDINARY, si_allocate_raw_instance, 3, OBJNULL},
{SYS_ "ARGC", SI_ORDINARY, si_argc, 0, OBJNULL},
{SYS_ "ARGV", SI_ORDINARY, si_argv, 1, OBJNULL},
{SYS_ "ASET", SI_ORDINARY, si_aset, -1, OBJNULL},
@ -1157,12 +1157,15 @@ cl_symbols[] = {
#ifndef CLOS
{SYS_ "STRUCTURE-INCLUDE", SI_ORDINARY, NULL, -1, OBJNULL},
#else
{SYS_ "CHANGE-INSTANCE", SI_ORDINARY, si_change_instance, 4, OBJNULL},
{SYS_ "CHANGE-INSTANCE", SI_ORDINARY, NULL, 4, OBJNULL},
{SYS_ "COMPUTE-EFFECTIVE-METHOD", SI_ORDINARY, NULL, -1, OBJNULL},
{SYS_ "COPY-INSTANCE", SI_ORDINARY, si_copy_instance, 1, OBJNULL},
{SYS_ "GENERIC-FUNCTION-P", SI_ORDINARY, si_generic_function_p, 1, OBJNULL},
{SYS_ "INSTANCE-REF-SAFE", SI_ORDINARY, si_instance_ref_safe, 2, OBJNULL},
{SYS_ "INSTANCE-REF", SI_ORDINARY, si_instance_ref, 2, OBJNULL},
{SYS_ "INSTANCE-SET", SI_ORDINARY, si_instance_set, 3, OBJNULL},
{SYS_ "INSTANCE-SIG", SI_ORDINARY, si_instance_sig, 1, OBJNULL},
{SYS_ "INSTANCE-SIG-SET", SI_ORDINARY, si_instance_sig_set, 1, OBJNULL},
{SYS_ "INSTANCE-CLASS", SI_ORDINARY, si_instance_class, 1, OBJNULL},
{SYS_ "INSTANCE-CLASS-SET", SI_ORDINARY, si_instance_class_set, 2, OBJNULL},
{SYS_ "INSTANCEP", SI_ORDINARY, si_instancep, 1, OBJNULL},

10
src/clos/boot.lsp
View file

@ -17,7 +17,7 @@
;;; SLOT-VALUE does not work.
(defun make-empty-standard-class (name metaclass)
(let ((class (si:allocate-raw-instance metaclass 12)))
(let ((class (si:allocate-raw-instance nil metaclass 12)))
(unless metaclass
(si:instance-class-set class class))
(setf (class-name class) name
@ -72,6 +72,11 @@
(class-direct-subclasses the-class) (list standard-class)
(class-direct-superclasses standard-class) (list the-class))
(si::instance-sig-set the-class)
(si::instance-sig-set standard-class)
(si::instance-sig-set standard-object)
(si::instance-sig-set the-t)
;; 4) Fix the class precedence list
(let ((cpl (list standard-class the-class standard-object the-t)))
(setf (class-precedence-list standard-class) cpl
@ -91,6 +96,7 @@
;;;
(defmethod slot-value ((self class) slot-name)
(ensure-up-to-date-instance self)
(let* ((class (si:instance-class self))
(index (position slot-name (class-slots class)
:key #'slotd-name :test #'eq)))
@ -104,6 +110,7 @@
'SLOT-VALUE)))))
(defmethod slot-boundp ((self class) slot-name)
(ensure-up-to-date-instance self)
(let* ((class (si:instance-class self))
(index (position slot-name (class-slots class)
:key #'slotd-name :test #'eq)))
@ -114,6 +121,7 @@
'SLOT-VALUE)))))
(defmethod (setf slot-value) (val (self class) slot-name)
(ensure-up-to-date-instance self)
(let* ((class (si:instance-class self))
(index (position slot-name (class-slots class)
:key #'slotd-name :test #'eq)))

3
src/clos/builtin.lsp
View file

@ -15,9 +15,6 @@
(defmethod make-instance ((class-name symbol) &rest initargs)
(apply #'make-instance (find-class class-name) initargs))
(defmethod change-class ((instance t) (new-class symbol))
(funcall #'change-class instance (find-class new-class)))
;;; ======================================================================
;;; STRUCTURES
;;;

232
src/clos/change.lsp
View file

@ -11,83 +11,185 @@
;;; The mechanism for updating classes.
;;; ----------------------------------------------------------------------
;;; Invalid Class
;;; ----------------------------------------------------------------------
(defclass forward-referenced-class (class) ())
(defclass invalid () ())
;;; ----------------------------------------------------------------------
(defmethod OPTIMIZE-SLOT-VALUE ((class class) form) form)
(defmethod OPTIMIZE-SET-SLOT-VALUE ((class class) form) form)
(defmethod slot-value ((object invalid) slot-name)
;; first update the instance
(update-instance object)
;; now access the slot
(slot-value object slot-name))
(defmethod (setf slot-value) (val (object invalid) slot-name)
;; first update the instance
(update-instance object)
;; now modify the slot
(setf (slot-value object slot-name) val))
;;; ----------------------------------------------------------------------
;;; INSTANCE UPDATE PROTOCOL
;;;
;;;
;;; PART 1: CHANGING THE CLASS OF AN INSTANCE
;;;
;;; The method CHANGE-CLASS performs most of the work.
;;;
;;; a) The structure of the instance is changed to match the new
;;; number of local slots.
;;; b) The new local slots are filled with the value of the old
;;; slots. Only the name is used, so that a new local slot may
;;; get the value of old slots that were eithe local or shared.
;;; c) Finally, UPDATE-INSTANCE-FOR-DIFFERENT-CLASS is invoked
;;; with a copy of the instance as it looked before the change,
;;; the changed instance and enough information to perform any
;;; extra processing.
;;;
(defmethod update-instance-for-different-class
((old-data standard-object) (new-data standard-object) &rest initargs)
(let ((old-local-slotds (si::instance-sig old-data))
(new-local-slotds (remove :instance (si::instance-sig new-data)
:test-not #'eq :key #'slotd-allocation))
added-slots)
(setf added-slots (set-difference (mapcar #'slotd-name new-local-slotds)
(mapcar #'slotd-name old-local-slotds)))
(apply #'shared-initialize new-data added-slots initargs)))
(defmethod change-class ((instance standard-object) (new-class standard-class)
&rest initargs)
(let* ((old-instance (si::copy-instance instance))
(new-size (count-instance-slots new-class))
(instance (si::allocate-raw-instance instance new-class new-size)))
(si::instance-sig-set instance)
;; "The values of local slots specified by both the class Cto and
;; Cfrom are retained. If such a local slot was unbound, it remains
;; unbound."
;; "The values of slots specified as shared in the class Cfrom and
;; as local in the class Cto are retained."
(let* ((old-local-slotds (class-slots (class-of old-instance)))
(new-local-slotds (class-slots (class-of instance))))
(dolist (new-slot new-local-slotds)
;; CHANGE-CLASS can only operate on the value of local slots.
(when (eq (slotd-allocation new-slot) :INSTANCE)
(let ((name (slotd-name new-slot)))
(if (and (slot-exists-p old-instance name)
(slot-boundp old-instance name))
(setf (slot-value instance name) (slot-value old-instance name))
(slot-makunbound instance name))))))
(apply #'update-instance-for-different-class old-instance instance
initargs)
instance))
(defmethod change-class ((instance class) new-class &rest initargs)
(if (forward-referenced-class-p instance)
(call-next-method)
(error "The metaclass of a class metaobject cannot be changed.")))
(defmethod change-class ((instance t) (new-class symbol) &rest initargs)
(apply #'change-class instance (find-class new-class) initargs))
;;;
;;; PART 2: UPDATING AN INSTANCE THAT BECAME OBSOLETE
;;;
;;; Each instance has a hidden field (readable with SI::INSTANCE-SIG), which
;;; contains the list of slots of its class. This field is updated every time
;;; the class is initialized or reinitialized. Generally
;;; (EQ (SI::INSTANCE-SIG x) (CLASS-SLOTS (CLASS-OF x)))
;;; returns NIL whenever the class became obsolete.
;;;
;;; There are two circumstances under which a instance may become obsolete:
;;; either the class has been modified using REDEFINE-INSTANCE (and thus the
;;; list of slots changed), or MAKE-INSTANCES-OBSOLETE has been used.
;;;
;;; The function UPDATE-INSTANCE (hidden to the user) does the job of
;;; updating an instance that has become obsolete.
;;;
;;; a) A copy of the instance is saved to check the old values.
;;; b) The structure of the instance is changed to match the new
;;; number of local slots.
;;; c) The new local slots are filled with the value of the old
;;; local slots.
;;; d) Finally, UPDATE-INSTANCE-FOR-REDEFINED-CLASS is invoked
;;; with enough information to perform any extra initialization,
;;; for instance of new slots.
;;;
;;; It is not clear when the function UPDATE-INSTANCE is invoked. At least
;;; this will happen whenever the functions SLOT-VALUE, (SETF SLOT-VALUE),
;;; SLOT-BOUNDP or SLOT-EXISTS-P are used.
;;;
(defmethod update-instance-for-redefined-class
((instance standard-object) added-slots discarded-slots property-list
&rest initargs)
(declare (ignore discarded-slots property-list))
(check-initargs (class-of instance) initargs)
(apply #'shared-initialize instance added-slots initargs))
(defun update-instance (instance)
(let* ((old-class (class-of instance))
(new-class (slot-value old-class 'FORWARD))
; was saved here by redefine-class
(old-slots (class-slots old-class))
(new-slots (class-slots new-class))
discarded-slots
added-slots
retained-correspondance
property-list
position)
;; dont (declare (fixnum position)) otherwise if position will fail.
(unless (equal old-slots new-slots)
(setq discarded-slots
(set-difference (mapcar #'slotd-name old-slots)
(mapcar #'slotd-name new-slots)))
;; compute the property list
(dolist (slot-name discarded-slots)
;; can't use slot-value or we loop
(push (cons slot-name (standard-instance-get instance slot-name))
property-list)))
(let* ((class (class-of instance))
(old-slotds (si::instance-sig instance))
(new-slotds (class-slots class))
(old-instance (si::copy-instance instance))
(discarded-slots '())
(added-slots '())
(property-list '()))
(unless (equal old-slotds new-slotds)
(setf instance (si::allocate-raw-instance instance class
(count-instance-slots class)))
(si::instance-sig-set instance)
(let* ((new-i 0)
(old-local-slotds (remove :instance old-slotds :test-not #'eq
:key #'slotd-allocation))
(new-local-slotds (remove :instance new-slotds :test-not #'eq
:key #'slotd-allocation)))
(declare (fixnum new-i))
(setq discarded-slots
(set-difference (mapcar #'slotd-name old-local-slotds)
(mapcar #'slotd-name new-local-slotds)))
(dolist (slot-name discarded-slots)
(let* ((ndx (position slot-name old-local-slotds :key #'slotd-name)))
(push (cons slot-name (si::instance-ref old-instance ndx))
property-list)))
(dolist (new-slot new-local-slotds)
(let* ((name (slotd-name new-slot))
(old-i (position name old-local-slotds :key #'slotd-name)))
(if old-i
(si::instance-set instance new-i
(si::instance-ref old-instance old-i))
(push name added-slots))
(incf new-i))))
(update-instance-for-redefined-class instance added-slots
discarded-slots property-list))))
;; compute retained local slots and update instance:
(let*((new-i 0)
(old-i 0)
(index-table (slot-index-table old-class))
name
old-slot)
(declare (fixnum new-i old-i))
(dolist (new-slot new-slots)
(setq name (slotd-name new-slot)
old-slot (find name old-slots :key #'slotd-name :test #'eq))
(if old-slot
(when (and (eq :INSTANCE (slotd-allocation new-slot))
(eq :INSTANCE (slotd-allocation old-slot)))
(push (cons new-i (gethash name index-table))
retained-correspondance))
(push new-slot added-slots))
(incf new-i))
;;; ----------------------------------------------------------------------
;;; CLASS REDEFINITION PROTOCOL
(si:change-instance instance new-class
(count-instance-slots new-class)
(nreverse retained-correspondance)))
(defmethod reinitialize-instance ((class class) &rest initargs
&key direct-superclasses &allow-other-keys)
(let ((name (class-name class)))
(if (member name '(CLASS BUILT-IN-CLASS) :test #'eq)
(error "The kernel CLOS class ~S cannot be changed." name)
(warn "Redefining class ~S" name)))
;; initialize newly added slots
(update-instance-for-redefined-class instance added-slots
discarded-slots property-list)
))
;; remove previous defined accessor methods
(when (class-finalized-p class)
(remove-optional-slot-accessors class))
(call-next-method)
;; set up inheritance checking that it makes sense
(dolist (l (setf (class-direct-superclasses class)
(check-direct-superclasses class direct-superclasses)))
(add-direct-subclass l class))
(setf (class-finalized-p class) nil)
(unless (find-if #'forward-referenced-class-p
(class-direct-superclasses class))
(finalize-inheritance class))
class)
(defmethod make-instances-obsolete ((class class))
(setf (class-slots class) (copy-list (class-slots class))))
(defmethod make-instances-obsolete ((class symbol))
(make-instances-obsolete (find-class class)))
(defun remove-optional-slot-accessors (class)
(let ((class-name (class-name class)))
(dolist (slotd (class-slots class))
(dolist (accessor (slotd-accessors slotd))
(let* ((gf-object (symbol-function accessor))
(setf-accessor (list 'setf accessor))
@ -121,7 +223,7 @@
(remove-method setf-gf-object found))
(when (null (generic-function-methods gf-object))
(fmakunbound setf-accessor))))
;; remove previous defined reader methods
(dolist (reader (slotd-readers slotd))
(let* ((gf-object (symbol-function reader))
@ -140,7 +242,7 @@
(remove-method gf-object found))
(when (null (generic-function-methods gf-object))
(fmakunbound reader))))
;; remove previous defined writer methods
(dolist (writer (slotd-writers slotd))
(let* ((gf-object (symbol-function writer))
@ -160,5 +262,3 @@
(when (null (generic-function-methods gf-object))
(fmakunbound writer)))))))
;;; ----------------------------------------------------------------------

48
src/clos/fixup.lsp
View file

@ -19,10 +19,14 @@
(when (eq 'T (class-name (si:instance-class gfun)))
;; complete the generic function object
(si:instance-class-set gfun (find-class 'STANDARD-GENERIC-FUNCTION))
(setf (generic-function-method-class gfun) standard-method-class))
(si::instance-sig-set gfun)
(setf (generic-function-method-class gfun) standard-method-class)
)
(dolist (method (cdr method-info))
;; complete the method object
(si::instance-class-set method (find-class 'standard-method)))
(si::instance-class-set method (find-class 'standard-method))
(si::instance-sig-set gfun)
)
(makunbound '*EARLY-METHODS*)))
@ -74,44 +78,6 @@
(error "Generic function: ~A. No primary method given arguments: ~S"
(generic-function-name gf) args))
;;; ----------------------------------------------------------------------
;;; Redefinition Protocol
(defun redefine-class (class new-class)
(when (typep class 'STRUCTURE-CLASS)
(return-from redefine-class new-class))
(unless (typep class 'STANDARD-CLASS)
(error "Class ~A cannot be redefined: it is not a standard class" class))
;; remove previous defined accessor methods
(remove-optional-slot-accessors class)
(warn "Redefining class ~S" (class-name class))
;; update subclasses
(dolist (subclass (reverse (class-direct-subclasses class)))
(ensure-class-using-class
subclass (class-name subclass)
:metaclass (class-name (class-of subclass))
:direct-superclasses
(subst new-class class (class-direct-superclasses subclass))
:direct-slots (class-direct-slots subclass)
:direct-default-initargs (class-direct-default-initargs subclass)
:documentation (and (slot-boundp subclass 'documentation)
(slot-value subclass 'documentation))))
;; remove the class from the inheritance tree
(dolist (superclass (class-direct-superclasses class))
(remove-direct-subclass superclass class))
(when (eql (find-class (class-name class) nil) class)
(setf (find-class (class-name new-class)) new-class))
;; invalidate the class
(setf (class-name class) 'INVALID)
(setf (slot-value class 'FORWARD) new-class)
new-class)
;;; Now we protect classes from redefinition:
(eval-when (compile load)
(defun setf-find-class (new-value name &optional errorp env)
@ -128,5 +94,3 @@
(t (error "~A is not a class." new-value))))
new-value)
)
;;;----------------------------------------------------------------------

10
src/clos/kernel.lsp
View file

@ -192,7 +192,7 @@
(if (and (fboundp name) (si::instancep (fdefinition name)))
(fdefinition name)
;; create a fake standard-generic-function object:
(let ((gfun (si:allocate-raw-instance (find-class 't)
(let ((gfun (si:allocate-raw-instance nil (find-class 't)
#.(length +standard-generic-function-slots+)))
(hash (make-hash-table
:test #'eql
@ -202,6 +202,7 @@
:rehash-threshold 0.5s0)))
(declare (type standard-object gfun))
;; create a new gfun
(si::instance-sig-set gfun)
(setf (generic-function-name gfun) name
(generic-function-lambda-list gfun) lambda-list
(generic-function-argument-precedence-order gfun) 'default
@ -222,8 +223,6 @@
(let* ((methods (generic-function-methods gf))
applicable-list
args-specializers)
;(print (generic-function-name gf))
;(print (mapcar #'method-specializers methods))
;; first compute the applicable method list
(dolist (method methods)
;; for each method in the list
@ -240,10 +239,7 @@
spec (first scan-specializers))
(unless (or (null spec)
(and (consp spec) (eql arg (cadr spec)))
(typep arg spec)
(and (eq 'INVALID spec)
(si:instancep arg)
(eq 'INVALID (class-name (class-of arg)))))
(typep arg spec))
(return))))
(dolist (arg args)
(push (type-of arg) args-specializers))

6
src/clos/macros.lsp
View file

@ -61,3 +61,9 @@
(defun mapappend (fun &rest args)
(reduce #'append (apply #'mapcar fun args)))
(defmacro ensure-up-to-date-instance (instance)
`(let ((i ,instance))
(unless (eq (si::instance-sig i) (class-slots (si::instance-class i)))
(update-instance i))))

2
src/clos/method.lsp
View file

@ -556,7 +556,7 @@
(defun make-method (qualifiers specializers lambda-list
fun plist options gf method-class)
(let ((method (si:allocate-raw-instance (find-class 'standard-method nil)
(let ((method (si:allocate-raw-instance nil (find-class 'standard-method nil)
#.(length +standard-method-slots+))))
(setf (method-generic-function method) gf
(method-lambda-list method) lambda-list

162
src/clos/standard.lsp
View file

@ -75,7 +75,12 @@
(count :instance (class-slots class) :key #'slotd-allocation))
(defmethod allocate-instance ((class class) &key &allow-other-keys)
(si::allocate-raw-instance class (count-instance-slots class)))
;; FIXME! Inefficient! We should keep a list of dependent classes.
(unless (class-finalized-p class)
(finalize-inheritance class))
(let ((x (si::allocate-raw-instance nil class (count-instance-slots class))))
(si::instance-sig-set x)
x))
(defmethod make-instance ((class class) &rest initargs)
(let ((instance (allocate-instance class)))
@ -122,8 +127,9 @@
(dolist (l (setf (class-direct-superclasses class)
(check-direct-superclasses class direct-superclasses)))
(add-direct-subclass l class))
(finalize-inheritance class)
(if (find-if #'forward-referenced-class-p (class-direct-superclasses class))
(print (find-if #'forward-referenced-class-p (class-direct-superclasses class)))
(finalize-inheritance class))
)
(defmethod add-direct-subclass ((parent class) child)
@ -147,21 +153,54 @@ argument was supplied for metaclass ~S." (class-of class))))))))
;; etc, are the first classes.
supplied-superclasses)
(defmethod reinitialize-instance ((class class) &rest initargs)
(error "Class reinitialization is not supported. If you wish to reinitialize ~
a class metaobject, use REDEFINE-CLASS instead."))
;;; ----------------------------------------------------------------------
;;; FINALIZATION OF CLASS INHERITANCE
;;;
(defun forward-referenced-class-p (x)
(let ((y (find-class 'FORWARD-REFERENCED-CLASS nil)))
(and y (si::subclassp (class-of x) y))))
(defmethod finalize-inheritance ((class class))
(unless (class-finalized-p class)
(setf (class-precedence-list class) (compute-class-precedence-list class)
;; FINALIZE-INHERITANCE computes the guts of what defines a class: the
;; slots, the list of parent class, etc. It is called when either the
;; class was not finalized before, or when one of the parents has been
;; modified.
;;
(let ((cpl (compute-class-precedence-list class)))
;; A class cannot be finalized if any of its parents is either
;; a not yet defined class or it has not yet been finalized.
;; In the first case we can just signal an error...
;;
(let ((x (find-if #'forward-referenced-class-p (rest cpl))))
(when x
(error "Cannot finish building the class~% ~A~%~
because it contains a reference to the undefined class~% ~A"
(class-name class) (class-name x))))
;;
;; ... and in the second case we just finalize the top-most class
;; which is not yet finalized and rely on the fact that this
;; class will also try to finalize all of its children.
;;
(let ((x (find-if-not #'class-finalized-p cpl :from-end t)))
(unless (or (null x) (eq x class))
(return-from finalize-inheritance
(finalize-inheritance x))))
(setf (class-precedence-list class) cpl
(class-slots class) (compute-slots class)
(class-default-initargs class) (compute-default-initargs class)
(class-finalized-p class) t))
)
(class-finalized-p class) t)
;;
;; This is not really needed, because when we modify the list of slots
;; all instances automatically become obsolete (See change.lsp)
;(make-instances-obsolete class)
)
;; As mentioned above, when a parent is finalized, it is responsible for
;; invoking FINALIZE-INHERITANCE on all of its children. Obviously,
;; this only makes sense when the class has been defined.
(dolist (subclass (reverse (class-direct-subclasses class)))
(reinitialize-instance subclass
:direct-superclasses (class-direct-superclasses subclass)))
)
(defmethod finalize-inheritance ((class standard-class))
(call-next-method)
@ -221,59 +260,47 @@ a class metaobject, use REDEFINE-CLASS instead."))
;;; ======================================================================
;;; STANDARD-CLASS specializations
;;;
;;; IMPORTANT:
;;; IMPORTANT: The following implementation of ENSURE-CLASS-USING-CLASS is
;;; shared by the metaclasses STANDARD-CLASS and STRUCTURE-CLASS.
;;;
;;; 1) The following implementation of ENSURE-CLASS-USING-CLASS is shared by
;;; the metaclasses STANDARD-CLASS and STRUCTURE-CLASS.
;;;
;;; 2) The implementation does not follow the AMOP in that a call to
;;; ENSURE-CLASS-... with a valid class does not reinitialize the class,
;;; but replace it with a new one using the function REDEFINE-CLASS.
;;;
(defmethod ensure-class-using-class ((class class) name &rest rest
&key direct-slots direct-default-initargs
&allow-other-keys)
(multiple-value-bind (metaclass direct-superclasses options)
(apply #'help-ensure-class rest)
(let ((new-class (apply #'ensure-class-using-class nil name rest)))
(if (and (eq metaclass (si:instance-class class))
(every #'eql (class-precedence-list new-class)
(class-precedence-list class))
(equal (class-slots new-class)
(class-slots class))
(equal (class-default-initargs new-class)
(class-default-initargs class)))
class
(redefine-class class new-class))
)))
(cond ((forward-referenced-class-p class)
(change-class class metaclass))
((not (eq (class-of class) metaclass))
(error "When redefining a class, the metaclass can not change.")))
(apply #'reinitialize-instance class :name name options)))
(defmethod ensure-class-using-class ((class null) name &rest rest)
(multiple-value-bind (metaclass direct-superclasses options)
(apply #'help-ensure-class rest)
(apply #'make-instance metaclass :name name options)))
(defun coerce-to-class (class-or-symbol)
(if (si::instancep class-or-symbol)
class-or-symbol
(find-class class-or-symbol t)))
(defun coerce-to-class (class-or-symbol &optional (fail nil))
(cond ((si:instancep class-or-symbol) class-or-symbol)
((not (symbolp class-or-symbol))
(error "~a is not a valid class specifier." class-or-symbol))
((find-class class-or-symbol fail))
(t
(warn "Class ~A has been forward referenced." class-or-symbol)
(ensure-class class-or-symbol
:metaclass 'forward-referenced-class
:direct-superclasses (list (find-class 'standard-object))
:direct-slots '()))))
(defun help-ensure-class (&rest options
&key (metaclass 'standard-class) direct-superclasses
&allow-other-keys)
(remf options :metaclass)
(remf options :direct-superclasses)
(setf metaclass (coerce-to-class metaclass)
(setf metaclass (coerce-to-class metaclass t)
direct-superclasses (mapcar #'coerce-to-class direct-superclasses))
(values metaclass direct-superclasses
(list* :direct-superclasses direct-superclasses options)))
;;; Bootstrap version
(defun redefine-class (class new-class)
(declare (ignore superclasses-names inferiors))
(format t "~%Redefinition of class ~A." (class-name class))
new-class)
;;; ----------------------------------------------------------------------
;;; Slots hashing for standard classes
;;;
@ -403,54 +430,6 @@ a class metaobject, use REDEFINE-CLASS instead."))
'SLOT-MAKUNBOUND)))
instance)
(defmethod change-class ((instance standard-object) (new-class standard-class))
(let* ((old-class (si:instance-class instance))
(old-slotds (class-slots old-class))
(new-slotds (class-slots new-class)))
;; "The values of local slots specified by both the class Cto and
;; Cfrom are retained. If such a local slot was unbound, it remains
;; unbound."
;; "The values of slots specified as shared in the class Cfrom and
;; as local in the class Cto are retained."
(let* ((new-i 0)
(old-i 0)
retained-correspondance)
(declare (fixnum new-i))
(dolist (new-slot new-slotds)
(setq old-i (position (slotd-name new-slot) old-slotds
:key #'slotd-name :test #'eq))
(when old-i
(push (cons new-i old-i) retained-correspondance))
(incf new-i))
(si:change-instance instance new-class
(count-instance-slots new-class)
(nreverse retained-correspondance)))
;; Compute the newly added slots. The spec defines
;; newly added slots as "those local slots for which no slot of
;; the same name exists in the previous class."
(let (added-slots)
(dolist (slotd new-slotds)
(if (and (not (member slotd old-slotds :key #'slotd-name :test #'eq))
(eq (slotd-allocation slotd) ':INSTANCE))
(push (slotd-name slotd) added-slots)))
(shared-initialize instance added-slots)))
instance)
(defmethod update-instance-for-redefined-class ((instance standard-object)
added-slots
discarded-slots
property-list
&rest initargs)
(declare (ignore discarded-slots property-list))
;; ***
;; *** Later we need to do initarg checking here.
;; ***
(apply #'shared-initialize instance added-slots initargs))
(defmethod describe-object ((obj standard-object))
(let* ((class (si:instance-class obj))
(slotds (class-slots class))
@ -486,7 +465,6 @@ a class metaobject, use REDEFINE-CLASS instead."))
;;; check-initargs
(defun check-initargs (class initargs)
(declare (si::c-local))
;; scan initarg list
(do* ((name-loc initargs (cddr name-loc))
(allow-other-keys nil)
@ -518,6 +496,7 @@ a class metaobject, use REDEFINE-CLASS instead."))
;;; Basic access to instances
(defun standard-instance-get (instance slot-name)
(ensure-up-to-date-instance instance)
(let* ((class (si:instance-class instance))
(index (gethash slot-name (slot-index-table class))))
(declare (type standard-class class))
@ -533,6 +512,7 @@ a class metaobject, use REDEFINE-CLASS instead."))
(values nil :UNBOUND))))))
(defun standard-instance-set (val instance slot-name)
(ensure-up-to-date-instance instance)
(let* ((class (si:instance-class instance))
(index (gethash slot-name (slot-index-table class))))
(declare (type standard-class class))

2
src/cmp/sysfun.lsp
View file

@ -1036,7 +1036,7 @@ type_of(#0)==t_bitvector"))
#+clos
(mapcar #'(lambda (x) (apply #'defsysfun x)) '(
; file instance.c
(si::ALLOCATE-RAW-INSTANCE (t fixnum) T)
(si::ALLOCATE-RAW-INSTANCE (t t fixnum) T)
(si::INSTANCE-REF-SAFE (t fixnum) T nil nil)
(si::INSTANCE-REF (t fixnum) T nil nil
:inline-always ((t fixnum) t nil nil "instance_ref((#0),(#1))")

39
src/doc/todo.txt
View file

@ -32,24 +32,29 @@ Unknown variables
KNOWN BUGS:
===========
(From Paul F. Dietz' test suite)
* When building :AROUND, :AFTER or :BEFORE methods for REINITIALIZE-INSTANCE,
one may introduce new initialization options, that CHECK-INITARGS ignores.
(See REINITIALIZE-INSTANCE.10 in Paul Dietz' test suite).
Test DEPOSIT-FIELD.1 failed
Form: (LOOP FOR POS = (RANDOM 32) FOR SIZE = (RANDOM 32) FOR NEWBYTE =
(RANDOM (ASH 1 (+ POS SIZE))) FOR VAL =
(RANDOM (1+ (RANDOM (ASH 1 (+ POS SIZE))))) FOR RESULT =
(DEPOSIT-FIELD NEWBYTE (BYTE SIZE POS) VAL) REPEAT 100
UNLESS
(LOOP FOR I FROM 0 TO (+ POS SIZE) ALWAYS
(IF (OR (< I POS) (>= I (+ POS SIZE)))
(IF (LOGBITP I VAL) (LOGBITP I RESULT)
(NOT (LOGBITP I RESULT)))
(IF (LOGBITP I NEWBYTE) (LOGBITP I RESULT)
(NOT (LOGBITP I RESULT)))))
COLLECT (LIST POS SIZE NEWBYTE VAL RESULT))
Expected value: NIL
Actual value: ((11 21 1980658428 89050977 1980659553)
(9 23 154003420 2827351845 154003237)).
* Why is this considered a failure? What does (SETF CLASS-NAME) have to do?
Test CLASS-0309.1 failed
Form: (PROGN
(SETF (FIND-CLASS 'CLASS-0309) NIL)
(LET* ((CLASS1 (EVAL '(DEFCLASS CLASS-0309 NIL ((A) (B) (C)))))
(OBJ1 (MAKE-INSTANCE 'CLASS-0309)))
(SETF (CLASS-NAME CLASS1) NIL)
(LET ((CLASS2 (EVAL '(DEFCLASS CLASS-0309 NIL ((A) (B) (C))))))
(VALUES (EQT (CLASS-OF OBJ1) CLASS1) (EQT CLASS1 CLASS2)
(TYPEP* OBJ1 CLASS1) (TYPEP* OBJ1 CLASS2)))))
Expected values: T
NIL
T
NIL
Actual values: T
T
T
T.
OLD: (Maybe out of date)

9
src/h/external.h
View file

@ -620,8 +620,7 @@ extern struct ecl_hashtable_entry *ecl_search_hash(cl_object key, cl_object hash
/* instance.c */
#ifdef CLOS
extern cl_object si_allocate_raw_instance(cl_object clas, cl_object size);
extern cl_object si_change_instance(cl_object x, cl_object clas, cl_object size, cl_object corr);
extern cl_object si_allocate_raw_instance(cl_object orig, cl_object clas, cl_object size);
extern cl_object si_instance_class(cl_object x);
extern cl_object si_instance_class_set(cl_object x, cl_object y);
extern cl_object si_instance_ref(cl_object x, cl_object index);
@ -631,11 +630,13 @@ extern cl_object si_instancep(cl_object x);
extern cl_object si_unbound();
extern cl_object si_sl_boundp(cl_object x);
extern cl_object si_sl_makunbound(cl_object x, cl_object index);
extern cl_object si_instance_sig(cl_object x);
extern cl_object si_instance_sig_set(cl_object x);
extern cl_object ecl_allocate_instance(cl_object clas, int size);
extern cl_object instance_ref(cl_object x, int i);
extern cl_object instance_set(cl_object x, int i, cl_object v);
extern cl_object ecl_copy_instance(cl_object x);
extern cl_object si_copy_instance(cl_object x);
#endif /* CLOS */
@ -796,7 +797,7 @@ extern cl_object cl_P _ARGS((int narg, ...));
extern cl_object cl_M _ARGS((int narg, cl_object num, ...));
extern cl_object cl_N _ARGS((int narg, cl_object num, ...));
extern cl_object cl_gcd _ARGS((int narg, ...));
extern cl_object cl_lcm _ARGS((int narg, cl_object lcm, ...));
extern cl_object cl_lcm _ARGS((int narg, ...));
extern cl_object fixnum_times(cl_fixnum i, cl_fixnum j);
extern cl_object number_times(cl_object x, cl_object y);

1
src/h/object.h
View file

@ -437,6 +437,7 @@ struct ecl_instance { /* instance header */
HEADER1(isgf);
cl_index length; /* instance length */
cl_object clas; /* instance class */
cl_object sig; /* generation signature */
cl_object *slots; /* instance slots */
};
#endif /* CLOS */

4
src/lsp/predlib.lsp
View file

@ -908,9 +908,9 @@ if not possible."
(throw '+canonical-type-failure+ nil)))))))
((clos::classp type)
(register-class type))
((function-type-p type)
((and (fboundp 'function-type-p) (function-type-p type))
(register-function-type type))
((values-type-p type)
((and (fboundp 'values-type-p) (values-type-p type))
(register-values-type type))
(t
(error-type-specifier type))))

1
src/lsp/top.lsp
View file

@ -480,7 +480,6 @@ file. When the saved image is invoked, it will start the redefined top-level."
(when (catch *quit-tag*
(tpl-prompt)
(setq - (notinline (tpl-read)))
(cos 1.0)
(setq values
(multiple-value-list
(eval-with-env - *break-env*)))