-/******************************************************************************
- *
- * initialize-object
- *
- ******************************************************************************/
-
-/*fixme* Manufacture keywords in advance */
-SCM
-scm_i_get_keyword (SCM key, SCM l, long len, SCM default_value, const char *subr)
-{
- long i;
-
- for (i = 0; i != len; i += 2)
- {
- SCM obj = SCM_CAR (l);
-
- if (!scm_is_keyword (obj))
- scm_misc_error (subr, "bad keyword: ~S", scm_list_1 (obj));
- else if (scm_is_eq (obj, key))
- return SCM_CADR (l);
- else
- l = SCM_CDDR (l);
- }
-
- return default_value;
-}
-
-
-SCM_DEFINE (scm_get_keyword, "get-keyword", 3, 0, 0,
- (SCM key, SCM l, SCM default_value),
- "Determine an associated value for the keyword @var{key} from\n"
- "the list @var{l}. The list @var{l} has to consist of an even\n"
- "number of elements, where, starting with the first, every\n"
- "second element is a keyword, followed by its associated value.\n"
- "If @var{l} does not hold a value for @var{key}, the value\n"
- "@var{default_value} is returned.")
-#define FUNC_NAME s_scm_get_keyword
-{
- long len;
-
- SCM_ASSERT (scm_is_keyword (key), key, SCM_ARG1, FUNC_NAME);
- len = scm_ilength (l);
- if (len < 0 || len % 2 == 1)
- scm_misc_error (FUNC_NAME, "Bad keyword-value list: ~S", scm_list_1 (l));
-
- return scm_i_get_keyword (key, l, len, default_value, FUNC_NAME);
-}
-#undef FUNC_NAME
-
-
-SCM_KEYWORD (k_init_keyword, "init-keyword");
-
-static SCM get_slot_value (SCM class, SCM obj, SCM slotdef);
-static SCM set_slot_value (SCM class, SCM obj, SCM slotdef, SCM value);
-
-SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
- (SCM obj, SCM initargs),
- "Initialize the object @var{obj} with the given arguments\n"
- "@var{initargs}.")
-#define FUNC_NAME s_scm_sys_initialize_object
-{
- SCM tmp, get_n_set, slots;
- SCM class = SCM_CLASS_OF (obj);
- long n_initargs;
-
- SCM_VALIDATE_INSTANCE (1, obj);
- n_initargs = scm_ilength (initargs);
- SCM_ASSERT ((n_initargs & 1) == 0, initargs, SCM_ARG2, FUNC_NAME);
-
- get_n_set = SCM_SLOT (class, scm_si_getters_n_setters);
- slots = SCM_SLOT (class, scm_si_slots);
-
- /* See for each slot how it must be initialized */
- for (;
- !scm_is_null (slots);
- get_n_set = SCM_CDR (get_n_set), slots = SCM_CDR (slots))
- {
- SCM slot_name = SCM_CAR (slots);
- SCM slot_value = SCM_GOOPS_UNBOUND;
-
- if (!scm_is_null (SCM_CDR (slot_name)))
- {
- /* This slot admits (perhaps) to be initialized at creation time */
- long n = scm_ilength (SCM_CDR (slot_name));
- if (n & 1) /* odd or -1 */
- SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
- scm_list_1 (slot_name));
- tmp = scm_i_get_keyword (k_init_keyword,
- SCM_CDR (slot_name),
- n,
- SCM_PACK (0),
- FUNC_NAME);
- slot_name = SCM_CAR (slot_name);
- if (SCM_UNPACK (tmp))
- {
- /* an initarg was provided for this slot */
- if (!scm_is_keyword (tmp))
- SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
- scm_list_1 (tmp));
- slot_value = scm_i_get_keyword (tmp,
- initargs,
- n_initargs,
- SCM_GOOPS_UNBOUND,
- FUNC_NAME);
- }
- }
-
- if (!SCM_GOOPS_UNBOUNDP (slot_value))
- /* set slot to provided value */
- set_slot_value (class, obj, SCM_CAR (get_n_set), slot_value);
- else
- {
- /* set slot to its :init-form if it exists */
- tmp = SCM_CADAR (get_n_set);
- if (scm_is_true (tmp))
- set_slot_value (class,
- obj,
- SCM_CAR (get_n_set),
- scm_call_0 (tmp));
- }
- }
-
- return obj;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_sys_init_layout_x, "%init-layout!", 2, 0, 0,
- (SCM class, SCM layout),
- "")
-#define FUNC_NAME s_scm_sys_init_layout_x
-{
- SCM_VALIDATE_INSTANCE (1, class);
- SCM_ASSERT (!scm_is_symbol (SCM_VTABLE_LAYOUT (class)), class, 1, FUNC_NAME);
- SCM_VALIDATE_STRING (2, layout);
-
- SCM_SET_VTABLE_LAYOUT (class, scm_make_struct_layout (layout));
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0,
- (SCM class, SCM dsupers),
- "")
-#define FUNC_NAME s_scm_sys_inherit_magic_x
-{
- SCM_VALIDATE_INSTANCE (1, class);
- scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
- SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID);
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-/******************************************************************************/
-
-SCM
-scm_make_standard_class (SCM meta, SCM name, SCM dsupers, SCM dslots)
-{
- return scm_call_4 (scm_variable_ref (var_make_standard_class),
- meta, name, dsupers, dslots);
-}
-
-/******************************************************************************/
-
-SCM_DEFINE (scm_sys_make_root_class, "%make-root-class", 3, 0, 0,
- (SCM name, SCM dslots, SCM getters_n_setters),
- "")
-#define FUNC_NAME s_scm_sys_make_root_class
-{
- SCM cs, z;
-
- cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT);
- z = scm_i_make_vtable_vtable (cs);
- SCM_SET_CLASS_FLAGS (z, (SCM_CLASSF_GOOPS_OR_VALID
- | SCM_CLASSF_METACLASS));
-
- SCM_SET_SLOT (z, scm_vtable_index_name, name);
- SCM_SET_SLOT (z, scm_si_direct_supers, SCM_EOL); /* will be changed */
- SCM_SET_SLOT (z, scm_si_direct_slots, dslots); /* will be changed */
- SCM_SET_SLOT (z, scm_si_direct_subclasses, SCM_EOL);
- SCM_SET_SLOT (z, scm_si_direct_methods, SCM_EOL);
- SCM_SET_SLOT (z, scm_si_cpl, SCM_EOL); /* will be changed */
- SCM_SET_SLOT (z, scm_si_slots, dslots); /* will be changed */
- SCM_SET_SLOT (z, scm_si_nfields, scm_from_int (SCM_N_CLASS_SLOTS));
- SCM_SET_SLOT (z, scm_si_getters_n_setters, getters_n_setters); /* will be changed */
- SCM_SET_SLOT (z, scm_si_redefined, SCM_BOOL_F);
-
- return z;
-}
-#undef FUNC_NAME