mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-21 03:51:47 -08:00
Code Issues Projects Releases Packages Wiki Activity

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.

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2012-12-18 23:24:13 +01:00
parent 3c4986d389
commit 8ac2ec408c
8 changed files with 41 additions and 10 deletions
Download patch file Download diff file Expand all files Collapse all files

12
src/c/cinit.d
View file

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

20
src/c/clos/accessor.d
View file

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

3
src/c/symbols_list.h
View file

@ -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},

3
src/c/symbols_list2.h
View file

@ -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},

4
src/clos/std-slot-value.lsp
View file

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

2
src/cmp/proclamations.lsp
View file

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

1
src/cmp/sysfun.lsp
View file

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

6
src/h/external.h
View file

@ -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 */