mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-20 02:30:23 +02:00
Code Activity

remove class-environment slot, goops grubs less in the evaluator

Browse source 
* libguile/goops.h (scm_sys_tag_body): Remove declaration of undefined
  function.
  (SCM_CLASS_CLASS_LAYOUT, scm_si_environment, SCM_N_CLASS_SLOTS)
  (scm_class_environment) Remove class environment slot and getter.

* libguile/goops.c (compute_getters_n_setters): Use scm_primitive_eval
  to produce the init thunk, instead of scm_i_eval_x; though really we
  should be doing this in Scheme.
  (scm_basic_basic_make_class, build_class_class_slots)
  (create_basic_classes, scm_class_environment): Remove class
  environment slot.
  (get_slot_value, set_slot_value): Use scm_call_1 instead of evaluator
  tricks.

* module/oop/goops.scm: Remove class-environment export, and
  environments throughout the file.
This commit is contained in:
Andy Wingo 2009-11-27 20:50:40 +01:00
parent c2c4e28198
commit 9d019f9be0
3 changed files with 41 additions and 99 deletions
Download patch file Download diff file Expand all files Collapse all files

60
libguile/goops.c
View file

@ -465,11 +465,10 @@ compute_getters_n_setters (SCM slots)
init = scm_get_keyword (k_init_value, options, 0);
if (init)
{
init = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
SCM_EOL,
scm_list_2 (scm_sym_quote,
init)),
SCM_EOL);
init = scm_primitive_eval (scm_list_3 (scm_sym_lambda,
SCM_EOL,
scm_list_2 (scm_sym_quote,
init)));
}
else
init = scm_get_keyword (k_init_thunk, options, SCM_BOOL_F);
@ -785,8 +784,6 @@ scm_basic_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots)
SCM_SET_SLOT (z, scm_si_nfields, nfields);
SCM_SET_SLOT (z, scm_si_getters_n_setters, g_n_s);
SCM_SET_SLOT (z, scm_si_redefined, SCM_BOOL_F);
SCM_SET_SLOT (z, scm_si_environment,
scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE));
/* Add this class in the direct-subclasses slot of dsupers */
{
@ -840,7 +837,6 @@ SCM_SYMBOL (sym_slots, "slots");
SCM_SYMBOL (sym_getters_n_setters, "getters-n-setters");
SCM_SYMBOL (sym_keyword_access, "keyword-access");
SCM_SYMBOL (sym_nfields, "nfields");
SCM_SYMBOL (sym_environment, "environment");
static SCM
@ -876,7 +872,6 @@ build_class_class_slots ()
scm_list_1 (sym_getters_n_setters),
scm_list_1 (sym_keyword_access),
scm_list_1 (sym_nfields),
scm_list_1 (sym_environment),
SCM_UNDEFINED);
}
@ -905,8 +900,6 @@ create_basic_classes (void)
/* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
compute_getters_n_setters (slots_of_class)); */
SCM_SET_SLOT (scm_class_class, scm_si_redefined, SCM_BOOL_F);
SCM_SET_SLOT (scm_class_class, scm_si_environment,
scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE));
prep_hashsets (scm_class_class);
@ -1024,17 +1017,6 @@ SCM_DEFINE (scm_class_slots, "class-slots", 1, 0, 0,
}
#undef FUNC_NAME
SCM_DEFINE (scm_class_environment, "class-environment", 1, 0, 0,
(SCM obj),
"Return the environment of the class @var{obj}.")
#define FUNC_NAME s_scm_class_environment
{
SCM_VALIDATE_CLASS (1, obj);
return scm_slot_ref(obj, sym_environment);
}
#undef FUNC_NAME
SCM_DEFINE (scm_generic_function_name, "generic-function-name", 1, 0, 0,
(SCM obj),
"Return the name of the generic function @var{obj}.")
@ -1245,20 +1227,7 @@ get_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef)
access bits for us. */
return scm_struct_ref (obj, access);
else
{
/* We must evaluate (apply (car access) (list obj))
* where (car access) is known to be a closure of arity 1 */
register SCM code, env;
code = SCM_CAR (access);
if (!SCM_CLOSUREP (code))
return scm_call_1 (code, obj);
env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
scm_list_1 (obj),
SCM_ENV (code));
/* Evaluate the closure body */
return scm_eval_body (SCM_CLOSURE_BODY (code), env);
}
return scm_call_1 (SCM_CAR (access), obj);
}
#undef FUNC_NAME
@ -1288,23 +1257,8 @@ set_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef, SCM value)
/* obey permissions bits via going through struct-set! */
scm_struct_set_x (obj, access, value);
else
{
/* We must evaluate (apply (cadr l) (list obj value))
* where (cadr l) is known to be a closure of arity 2 */
register SCM code, env;
code = SCM_CADR (access);
if (!SCM_CLOSUREP (code))
scm_call_2 (code, obj, value);
else
{
env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
scm_list_2 (obj, value),
SCM_ENV (code));
/* Evaluate the closure body */
scm_eval_body (SCM_CLOSURE_BODY (code), env);
}
}
/* ((cadr l) obj value) */
scm_call_2 (SCM_CADR (access), obj, value);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

8
libguile/goops.h
View file

@ -80,8 +80,7 @@
"pw" /* slots */ \
"pw" /* getters-n-setters */ \
"pw" /* keyword access */ \
"pw" /* nfields */ \
"pw" /* environment */
"pw" /* nfields */
#define scm_si_redefined (scm_vtable_offset_user + 0)
#define scm_si_h0 (scm_vtable_offset_user + 1)
@ -104,8 +103,7 @@
#define scm_si_getters_n_setters scm_si_name_access
#define scm_si_keyword_access (scm_vtable_offset_user + 17)
#define scm_si_nfields (scm_vtable_offset_user + 18) /* an integer */
#define scm_si_environment (scm_vtable_offset_user + 19) /* The environment in which class is built */
#define SCM_N_CLASS_SLOTS (scm_vtable_offset_user + 20)
#define SCM_N_CLASS_SLOTS (scm_vtable_offset_user + 19)
typedef struct scm_t_method {
SCM generic_function;
@ -275,13 +273,11 @@ SCM_API SCM scm_class_direct_subclasses (SCM obj);
SCM_API SCM scm_class_direct_methods (SCM obj);
SCM_API SCM scm_class_precedence_list (SCM obj);
SCM_API SCM scm_class_slots (SCM obj);
SCM_API SCM scm_class_environment (SCM obj);
SCM_API SCM scm_generic_function_name (SCM obj);
SCM_API SCM scm_generic_function_methods (SCM obj);
SCM_API SCM scm_method_generic_function (SCM obj);
SCM_API SCM scm_method_specializers (SCM obj);
SCM_API SCM scm_method_procedure (SCM obj);
SCM_API SCM scm_sys_tag_body (SCM body);
SCM_API SCM scm_sys_fast_slot_ref (SCM obj, SCM index);
SCM_API SCM scm_sys_fast_slot_set_x (SCM obj, SCM index, SCM value);
SCM_API SCM scm_slot_ref_using_class (SCM cls, SCM obj, SCM slot_name);