From 8ac2ec408cda4334baba1f0f03e8d1fa288ae504 Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Tue, 18 Dec 2012 23:24:13 +0100 Subject: [PATCH] The accessor dispatch code must contemplate the possibility that it gets a non-standard class. In order to implement this, we ensure that SLOT-VALUE and (SETF SLOT-VALUE) are availabe as C functions right at boot time. --- src/c/cinit.d | 12 ++++++++++++ src/c/clos/accessor.d | 20 ++++++++++++++------ src/c/symbols_list.h | 3 ++- src/c/symbols_list2.h | 3 ++- src/clos/std-slot-value.lsp | 4 +++- src/cmp/proclamations.lsp | 2 ++ src/cmp/sysfun.lsp | 1 + src/h/external.h | 6 +++++- 8 files changed, 41 insertions(+), 10 deletions(-) diff --git a/src/c/cinit.d b/src/c/cinit.d index a52668f0c..219930963 100644 --- a/src/c/cinit.d +++ b/src/c/cinit.d @@ -46,6 +46,18 @@ si_safe_eval(cl_narg narg, cl_object form, cl_object env, ...) return _ecl_funcall3(@'ext::safe-eval', form, env); } +extern cl_object +cl_slot_value(cl_object instance, cl_object name) +{ + return _ecl_funcall3(@'slot-value', instance, name); +} + +extern cl_object +clos_slot_value_set(cl_object value, cl_object instance, cl_object name) +{ + return _ecl_funcall4(@'clos::slot-value-set', value, instance, name); +} + extern cl_object clos_std_compute_applicable_methods(cl_object gf, cl_object arglist) { diff --git a/src/c/clos/accessor.d b/src/c/clos/accessor.d index 3ed00ee34..fff0d8d50 100644 --- a/src/c/clos/accessor.d +++ b/src/c/clos/accessor.d @@ -60,6 +60,12 @@ slot_method_index(cl_object gfun, cl_object instance, cl_object args) cl_object table = _ecl_funcall3(@'slot-value', ECL_CLASS_OF(instance), @'clos::location-table'); + /* The class might not be a standard class. This happens + * when a nonstandard class inherits from a standard class + * and does not add any new slot accessor. + */ + unlikely_if (Null(table)) + return slot_name; return ecl_gethash_safe(slot_name, table, OBJNULL); } } @@ -132,10 +138,11 @@ ecl_slot_reader_dispatch(cl_narg narg, cl_object instance) index = e->value; if (ECL_FIXNUMP(index)) { value = instance->instance.slots[ecl_fixnum(index)]; + } else if (ecl_unlikely(!ECL_LISTP(index))) { + value = cl_slot_value(instance, index); + } else if (ecl_unlikely(Null(index))) { + FEerror("Error when accessing method cache for ~A", 1, gfun); } else { - unlikely_if (!ECL_CONSP(index)) { - FEerror("Error when accessing method cache for ~A", 1, gfun); - } value = ECL_CONS_CAR(index); } unlikely_if (value == ECL_UNBOUND) { @@ -175,10 +182,11 @@ ecl_slot_writer_dispatch(cl_narg narg, cl_object value, cl_object instance) index = e->value; if (ECL_FIXNUMP(index)) { instance->instance.slots[ecl_fixnum(index)] = value; + } else if (ecl_unlikely(!ECL_LISTP(index))) { + clos_slot_value_set(value, instance, index); + } else if (ecl_unlikely(Null(index))) { + FEerror("Error when accessing method cache for ~A", 1, gfun); } else { - unlikely_if (!ECL_CONSP(index)) { - FEerror("Error when accessing method cache for ~A", 1, gfun); - } ECL_RPLACA(index, value); } @(return value) diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 8e41d57af..fa085643e 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1065,7 +1065,7 @@ cl_symbols[] = { {"SLOT-MAKUNBOUND", CL_ORDINARY, ECL_NAME(cl_slot_makunbound), 2, OBJNULL}, {"SLOT-MISSING", CL_ORDINARY, NULL, -1, OBJNULL}, {"SLOT-UNBOUND", CL_ORDINARY, NULL, -1, OBJNULL}, -{"SLOT-VALUE", CL_ORDINARY, ECL_NAME(cl_slot_value), 2, OBJNULL}, +{"SLOT-VALUE", CL_ORDINARY, cl_slot_value, 2, OBJNULL}, {"STANDARD", CL_ORDINARY, NULL, -1, OBJNULL}, {"STANDARD-CLASS", CL_ORDINARY, NULL, -1, OBJNULL}, {"STANDARD-GENERIC-FUNCTION", CL_ORDINARY, NULL, -1, OBJNULL}, @@ -1705,6 +1705,7 @@ cl_symbols[] = { {CLOS_ "SLOT-DEFINITION-WRITERS", CLOS_ORDINARY, NULL, -1, OBJNULL}, {CLOS_ "SLOT-MAKUNBOUND-USING-CLASS", CLOS_ORDINARY, NULL, -1, OBJNULL}, {CLOS_ "SLOT-VALUE-USING-CLASS", CLOS_ORDINARY, NULL, -1, OBJNULL}, +{CLOS_ "SLOT-VALUE-SET", CLOS_ORDINARY, clos_slot_value_set, 3, OBJNULL}, {CLOS_ "SLOT-TABLE", CLOS_ORDINARY, NULL, -1, OBJNULL}, {CLOS_ "SPECIALIZER", CLOS_ORDINARY, NULL, -1, OBJNULL}, {CLOS_ "SPECIALIZER-DIRECT-GENERIC-FUNCTIONS", CLOS_ORDINARY, NULL, -1, OBJNULL}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 1e01fd824..be8fb5eec 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1065,7 +1065,7 @@ cl_symbols[] = { {"SLOT-MAKUNBOUND","ECL_NAME(cl_slot_makunbound)"}, {"SLOT-MISSING",NULL}, {"SLOT-UNBOUND",NULL}, -{"SLOT-VALUE","ECL_NAME(cl_slot_value)"}, +{"SLOT-VALUE","cl_slot_value"}, {"STANDARD",NULL}, {"STANDARD-CLASS",NULL}, {"STANDARD-GENERIC-FUNCTION",NULL}, @@ -1705,6 +1705,7 @@ cl_symbols[] = { {CLOS_ "SLOT-DEFINITION-WRITERS",NULL}, {CLOS_ "SLOT-MAKUNBOUND-USING-CLASS",NULL}, {CLOS_ "SLOT-VALUE-USING-CLASS",NULL}, +{CLOS_ "SLOT-VALUE-SET","clos_slot_value_set"}, {CLOS_ "SLOT-TABLE",NULL}, {CLOS_ "SPECIALIZER",NULL}, {CLOS_ "SPECIALIZER-DIRECT-GENERIC-FUNCTIONS",NULL}, diff --git a/src/clos/std-slot-value.lsp b/src/clos/std-slot-value.lsp index 294b35f14..4726bc49d 100644 --- a/src/clos/std-slot-value.lsp +++ b/src/clos/std-slot-value.lsp @@ -227,7 +227,7 @@ (slot-boundp-using-class class self slotd) (values (slot-missing class self slot-name 'SLOT-BOUNDP)))))))) -(defun (setf slot-value) (value self slot-name) +(defun clos::slot-value-set (value self slot-name) (with-early-accessors (+standard-class-slots+ +slot-definition-slots+) (let* ((class (class-of self)) @@ -243,6 +243,8 @@ (slot-missing class self slot-name 'SETF value)))))) value) +(setf (fdefinition '(setf slot-value)) #'clos::slot-value-set) + ;;; ;;; 2) Overloadable methods on which the previous functions are based ;;; diff --git a/src/cmp/proclamations.lsp b/src/cmp/proclamations.lsp index 39933685a..b45e503cf 100644 --- a/src/cmp/proclamations.lsp +++ b/src/cmp/proclamations.lsp @@ -302,6 +302,8 @@ (proclamation clos:compute-effective-method-function (generic-function method-combination list) function) #+clos (proclamation clos::update-instance (ext:instance) (values)) +#+clos +(proclamation clos::slot-value-set (t si::instance symbol) t) ;;; ;;; 8. STRUCTURES diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp index ad5378156..2439c512d 100644 --- a/src/cmp/sysfun.lsp +++ b/src/cmp/sysfun.lsp @@ -945,6 +945,7 @@ slot-boundp slot-makunbound slot-value + clos::slot-value-set slot-exists-p clos::need-to-make-load-form-p ;; defclass diff --git a/src/h/external.h b/src/h/external.h index 5329e0830..7936fcd5e 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -2117,7 +2117,6 @@ extern ECL_API cl_object clos_compute_effective_method_function(cl_object gf, cl /* boot.lsp */ extern ECL_API cl_object cl_slot_boundp(cl_object object, cl_object slot); extern ECL_API cl_object cl_slot_makunbound(cl_object object, cl_object slot); -extern ECL_API cl_object cl_slot_value(cl_object object, cl_object slot); extern ECL_API cl_object cl_slot_exists_p(cl_object object, cl_object slot); /* print.lsp */ @@ -2154,8 +2153,13 @@ extern ECL_API cl_object clos_install_method _ECL_ARGS((cl_narg narg, cl_object /* standard.lsp */ extern ECL_API cl_object clos_standard_instance_set _ECL_ARGS((cl_narg narg, cl_object V1, cl_object V2, cl_object V3, ...)); + #endif +/* std-slot-value */ +extern ECL_API cl_object cl_slot_value(cl_object object, cl_object slot); +extern ECL_API cl_object clos_slot_value_set(cl_object value, cl_object instance, cl_object name); + #endif /* conditions.lsp */