From 0290efd01c5de3a601edebfa027d6870f074e8db Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Mon, 15 Dec 2003 08:54:10 +0000 Subject: [PATCH] Implemented the class redefinition protocol, and forward referenced classes. --- src/CHANGELOG | 4 + src/c/instance.d | 48 ++++----- src/c/structure.d | 2 +- src/c/symbols_list.h | 7 +- src/clos/boot.lsp | 10 +- src/clos/builtin.lsp | 3 - src/clos/change.lsp | 232 ++++++++++++++++++++++++++++++------------ src/clos/fixup.lsp | 48 ++------- src/clos/kernel.lsp | 10 +- src/clos/macros.lsp | 6 ++ src/clos/method.lsp | 2 +- src/clos/standard.lsp | 162 +++++++++++++---------------- src/cmp/sysfun.lsp | 2 +- src/doc/todo.txt | 39 +++---- src/h/external.h | 9 +- src/h/object.h | 1 + src/lsp/predlib.lsp | 4 +- src/lsp/top.lsp | 1 - 18 files changed, 322 insertions(+), 268 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 550ccbe7a..2e08abd6b 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -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: ===== diff --git a/src/c/instance.d b/src/c/instance.d index 460f40d89..52219893e 100644 --- a/src/c/instance.d +++ b/src/c/instance.d @@ -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) diff --git a/src/c/structure.d b/src/c/structure.d index d7eda2ea8..b476f6e77 100644 --- a/src/c/structure.d +++ b/src/c/structure.d @@ -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) diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 93df927d7..02816efb8 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -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}, diff --git a/src/clos/boot.lsp b/src/clos/boot.lsp index 5077c3773..b2e391878 100644 --- a/src/clos/boot.lsp +++ b/src/clos/boot.lsp @@ -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))) diff --git a/src/clos/builtin.lsp b/src/clos/builtin.lsp index 6d1868899..deb6777a9 100644 --- a/src/clos/builtin.lsp +++ b/src/clos/builtin.lsp @@ -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 ;;; diff --git a/src/clos/change.lsp b/src/clos/change.lsp index d6a68e48b..0f1dab9e0 100644 --- a/src/clos/change.lsp +++ b/src/clos/change.lsp @@ -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))))))) - -;;; ---------------------------------------------------------------------- diff --git a/src/clos/fixup.lsp b/src/clos/fixup.lsp index d98757516..8f7d1bed6 100644 --- a/src/clos/fixup.lsp +++ b/src/clos/fixup.lsp @@ -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) ) - -;;;---------------------------------------------------------------------- diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index 2b2ef3769..c44265232 100644 --- a/src/clos/kernel.lsp +++ b/src/clos/kernel.lsp @@ -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)) diff --git a/src/clos/macros.lsp b/src/clos/macros.lsp index 9d65f536d..b2cfacf4b 100644 --- a/src/clos/macros.lsp +++ b/src/clos/macros.lsp @@ -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)))) + diff --git a/src/clos/method.lsp b/src/clos/method.lsp index e60b742b3..43e8d23c9 100644 --- a/src/clos/method.lsp +++ b/src/clos/method.lsp @@ -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 diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp index ca354fecc..c635f1a6d 100644 --- a/src/clos/standard.lsp +++ b/src/clos/standard.lsp @@ -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)) diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp index 0ee3352cf..32d6805a6 100644 --- a/src/cmp/sysfun.lsp +++ b/src/cmp/sysfun.lsp @@ -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))") diff --git a/src/doc/todo.txt b/src/doc/todo.txt index eb0ea577a..1be87656e 100644 --- a/src/doc/todo.txt +++ b/src/doc/todo.txt @@ -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) diff --git a/src/h/external.h b/src/h/external.h index 7d97d12e9..ec033f475 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -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); diff --git a/src/h/object.h b/src/h/object.h index 8efc276cd..31bccb1a0 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -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 */ diff --git a/src/lsp/predlib.lsp b/src/lsp/predlib.lsp index e22dc9cd3..4c287df36 100644 --- a/src/lsp/predlib.lsp +++ b/src/lsp/predlib.lsp @@ -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)))) diff --git a/src/lsp/top.lsp b/src/lsp/top.lsp index c24ce67bc..e2a8430ad 100644 --- a/src/lsp/top.lsp +++ b/src/lsp/top.lsp @@ -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*)))