-static SCM
-default_setter (SCM obj SCM_UNUSED, SCM c SCM_UNUSED)
-{
- scm_misc_error ("slot-set!", "read-only slot", SCM_EOL);
- return 0;
-}
-
-void
-scm_add_slot (SCM class, char *slot_name, SCM slot_class,
- SCM (*getter) (SCM obj),
- SCM (*setter) (SCM obj, SCM x),
- char *accessor_name)
-{
- {
- SCM get = scm_c_make_subr ("goops:get", scm_tc7_subr_1, getter);
- SCM set = scm_c_make_subr ("goops:set", scm_tc7_subr_2,
- setter ? setter : default_setter);
-
- /* Dirk:FIXME:: The following two expressions make use of the fact that
- * the memoizer will accept a subr-object in the place of a function.
- * This is not guaranteed to stay this way. */
- SCM getm = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
- scm_list_1 (sym_o),
- scm_list_2 (get, sym_o)),
- SCM_EOL);
- SCM setm = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
- scm_list_2 (sym_o, sym_x),
- scm_list_3 (set, sym_o, sym_x)),
- SCM_EOL);
-
- {
- SCM name = scm_from_locale_symbol (slot_name);
- SCM aname = scm_from_locale_symbol (accessor_name);
- SCM gf = scm_ensure_accessor (aname);
- SCM slot = scm_list_5 (name,
- k_class,
- slot_class,
- setter ? k_accessor : k_getter,
- gf);
- scm_add_method (gf, scm_make (scm_list_5 (scm_class_accessor_method,
- k_specializers,
- scm_list_1 (class),
- k_procedure,
- getm)));
- scm_add_method (scm_setter (gf),
- scm_make (scm_list_5 (scm_class_accessor_method,
- k_specializers,
- scm_list_2 (class, scm_class_top),
- k_procedure,
- setm)));
- DEFVAR (aname, gf);
-
- SCM_SET_SLOT (class, scm_si_slots,
- scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots),
- scm_list_1 (slot))));
- {
- SCM n = SCM_SLOT (class, scm_si_nfields);
- SCM gns = scm_list_n (name, SCM_BOOL_F, get, set, n, scm_from_int (1),
- SCM_UNDEFINED);
- SCM_SET_SLOT (class, scm_si_getters_n_setters,
- scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters),
- scm_list_1 (gns))));
- SCM_SET_SLOT (class, scm_si_nfields, scm_sum (n, scm_from_int (1)));
- }
- }
- }
-}
-
-SCM
-scm_wrap_object (SCM class, void *data)
-{
- return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct,
- (scm_t_bits) data,
- 0, 0);
-}
-
-SCM scm_components;
-
-SCM
-scm_wrap_component (SCM class, SCM container, void *data)
-{
- SCM obj = scm_wrap_object (class, data);
- SCM handle = scm_hash_fn_create_handle_x (scm_components,
- obj,
- SCM_BOOL_F,
- scm_struct_ihashq,
- scm_sloppy_assq,
- 0);
- SCM_SETCDR (handle, container);
- return obj;
-}
-