References to ordinary procedures is by reference (by variable),
though, as in the rest of Guile. */
+SCM_KEYWORD (k_name, "name");
+SCM_KEYWORD (k_setter, "setter");
+SCM_SYMBOL (sym_redefined, "redefined");
+SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
+
+static int goops_loaded_p = 0;
+
static SCM var_make_standard_class = SCM_BOOL_F;
-static SCM var_slot_unbound = SCM_BOOL_F;
-static SCM var_slot_missing = SCM_BOOL_F;
static SCM var_change_class = SCM_BOOL_F;
static SCM var_make = SCM_BOOL_F;
+static SCM var_inherit_applicable = SCM_BOOL_F;
static SCM var_class_name = SCM_BOOL_F;
static SCM var_class_direct_supers = SCM_BOOL_F;
static SCM var_class_direct_slots = SCM_BOOL_F;
static SCM var_method_specializers = SCM_BOOL_F;
static SCM var_method_procedure = SCM_BOOL_F;
-
-SCM_SYMBOL (sym_slot_unbound, "slot-unbound");
-SCM_SYMBOL (sym_slot_missing, "slot-missing");
-SCM_SYMBOL (sym_change_class, "change-class");
-
-SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic");
-
-
-/* Class redefinition protocol:
-
- A class is represented by a heap header h1 which points to a
- malloc:ed memory block m1.
-
- When a new version of a class is created, a new header h2 and
- memory block m2 are allocated. The headers h1 and h2 then switch
- pointers so that h1 refers to m2 and h2 to m1. In this way, names
- bound to h1 will point to the new class at the same time as h2 will
- be a handle which the GC will use to free m1.
-
- The `redefined' slot of m1 will be set to point to h1. An old
- instance will have its class pointer (the CAR of the heap header)
- pointing to m1. The non-immediate `redefined'-slot in m1 indicates
- the class modification and the new class pointer can be found via
- h1.
-*/
-
-#define TEST_CHANGE_CLASS(obj, class) \
- { \
- class = SCM_CLASS_OF (obj); \
- if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj))) \
- { \
- scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
- class = SCM_CLASS_OF (obj); \
- } \
- }
-
-#define SCM_GOOPS_UNBOUND SCM_UNBOUND
-#define SCM_GOOPS_UNBOUNDP(x) (scm_is_eq (x, SCM_GOOPS_UNBOUND))
-
-static int goops_loaded_p = 0;
+static SCM var_slot_ref = SCM_BOOL_F;
+static SCM var_slot_set_x = SCM_BOOL_F;
+static SCM var_slot_bound_p = SCM_BOOL_F;
+static SCM var_slot_exists_p = SCM_BOOL_F;
/* These variables are filled in by the object system when loaded. */
static SCM class_boolean, class_char, class_pair;
/* SMOB classes. */
SCM scm_i_smob_class[SCM_I_MAX_SMOB_TYPE_COUNT];
-static SCM scm_make_unbound (void);
-static SCM scm_unbound_p (SCM obj);
-static SCM scm_class_p (SCM obj);
-static SCM scm_sys_bless_applicable_struct_vtables_x (SCM applicable,
- SCM setter);
-static SCM scm_sys_bless_pure_generic_vtable_x (SCM vtable);
-static SCM scm_sys_make_root_class (SCM name, SCM dslots,
- SCM getters_n_setters);
+SCM scm_module_goops;
+
+static SCM scm_sys_make_vtable_vtable (SCM layout);
static SCM scm_sys_init_layout_x (SCM class, SCM layout);
+static SCM scm_sys_clear_fields_x (SCM obj, SCM unbound);
static SCM scm_sys_goops_early_init (void);
static SCM scm_sys_goops_loaded (void);
+\f
+
+SCM_DEFINE (scm_sys_make_vtable_vtable, "%make-vtable-vtable", 1, 0, 0,
+ (SCM layout),
+ "")
+#define FUNC_NAME s_scm_sys_make_vtable_vtable
+{
+ return scm_i_make_vtable_vtable (layout);
+}
+#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_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));
+ 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
+
+
+\f
+
/* This function is used for efficient type dispatch. */
SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
(SCM x),
: SCM_IN_PCLASS_INDEX | SCM_PTOBNUM (x))];
case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS_VALID)
+ /* A GOOPS object with a valid class. */
return SCM_CLASS_OF (x);
else if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS)
+ /* A GOOPS object whose class might have been redefined. */
{
- /* Goops object */
- if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x)))
- scm_change_object_class (x,
- SCM_CLASS_OF (x), /* old */
- SCM_OBJ_CLASS_REDEF (x)); /* new */
+ SCM class = SCM_CLASS_OF (x);
+ SCM new_class = scm_slot_ref (class, sym_redefined);
+ if (!scm_is_false (new_class))
+ scm_change_object_class (x, class, new_class);
+ /* Re-load class from instance. */
return SCM_CLASS_OF (x);
}
else
}
#undef FUNC_NAME
-/******************************************************************************
- *
- * 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
-/******************************************************************************/
+\f
SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0,
(SCM obj),
}
#undef FUNC_NAME
-SCM_DEFINE (scm_class_p, "class?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a class.")
-#define FUNC_NAME s_scm_class_p
-{
- return scm_from_bool (SCM_CLASSP (obj));
-}
-#undef FUNC_NAME
-
int
scm_is_generic (SCM x)
{
return SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), class_method);
}
-/******************************************************************************
- *
- * Meta object accessors
- *
- ******************************************************************************/
-SCM_SYMBOL (sym_procedure, "procedure");
+\f
SCM
scm_class_name (SCM obj)
return scm_call_1 (scm_variable_ref (var_class_slots), obj);
}
+
+\f
+
SCM_DEFINE (scm_generic_function_name, "generic-function-name", 1, 0, 0,
(SCM obj),
"Return the name of the generic function @var{obj}.")
return scm_call_1 (scm_variable_ref (var_method_procedure), obj);
}
-/******************************************************************************
- *
- * S l o t a c c e s s
- *
- ******************************************************************************/
-
-SCM_DEFINE (scm_make_unbound, "make-unbound", 0, 0, 0,
- (),
- "Return the unbound value.")
-#define FUNC_NAME s_scm_make_unbound
-{
- return SCM_GOOPS_UNBOUND;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_unbound_p, "unbound?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is unbound.")
-#define FUNC_NAME s_scm_unbound_p
-{
- return SCM_GOOPS_UNBOUNDP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
\f
-/** Utilities **/
-
-/* In the future, this function will return the effective slot
- * definition associated with SLOT_NAME. Now it just returns some of
- * the information which will be stored in the effective slot
- * definition.
- */
-
-static SCM
-slot_definition_using_name (SCM class, SCM slot_name)
-{
- register SCM slots = SCM_SLOT (class, scm_si_getters_n_setters);
- for (; !scm_is_null (slots); slots = SCM_CDR (slots))
- if (scm_is_eq (SCM_CAAR (slots), slot_name))
- return SCM_CAR (slots);
- return SCM_BOOL_F;
-}
-static SCM
-get_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef)
-#define FUNC_NAME "%get-slot-value"
-{
- SCM access = SCM_CDDR (slotdef);
- /* Two cases here:
- * - access is an integer (the offset of this slot in the slots vector)
- * - otherwise (car access) is the getter function to apply
- *
- * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
- * we can just assume fixnums here.
- */
- if (SCM_I_INUMP (access))
- /* Don't poke at the slots directly, because scm_struct_ref handles the
- access bits for us. */
- return scm_struct_ref (obj, access);
- else
- return scm_call_1 (SCM_CAR (access), obj);
-}
-#undef FUNC_NAME
-
-static SCM
-get_slot_value_using_name (SCM class, SCM obj, SCM slot_name)
-{
- SCM slotdef = slot_definition_using_name (class, slot_name);
- if (scm_is_true (slotdef))
- return get_slot_value (class, obj, slotdef);
- else
- return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing), class, obj, slot_name);
-}
-
-static SCM
-set_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef, SCM value)
-#define FUNC_NAME "%set-slot-value"
-{
- SCM access = SCM_CDDR (slotdef);
- /* Two cases here:
- * - access is an integer (the offset of this slot in the slots vector)
- * - otherwise (cadr access) is the setter function to apply
- *
- * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
- * we can just assume fixnums here.
- */
- if (SCM_I_INUMP (access))
- /* obey permissions bits via going through struct-set! */
- scm_struct_set_x (obj, access, value);
- else
- /* ((cadr l) obj value) */
- scm_call_2 (SCM_CADR (access), obj, value);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-static SCM
-set_slot_value_using_name (SCM class, SCM obj, SCM slot_name, SCM value)
-{
- SCM slotdef = slot_definition_using_name (class, slot_name);
- if (scm_is_true (slotdef))
- return set_slot_value (class, obj, slotdef, value);
- else
- return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing), class, obj, slot_name, value);
-}
-
-static SCM
-test_slot_existence (SCM class SCM_UNUSED, SCM obj, SCM slot_name)
-{
- register SCM l;
-
- for (l = SCM_ACCESSORS_OF (obj); !scm_is_null (l); l = SCM_CDR (l))
- if (scm_is_eq (SCM_CAAR (l), slot_name))
- return SCM_BOOL_T;
-
- return SCM_BOOL_F;
-}
-
- /* ======================================== */
-
-SCM_DEFINE (scm_slot_ref_using_class, "slot-ref-using-class", 3, 0, 0,
- (SCM class, SCM obj, SCM slot_name),
- "")
-#define FUNC_NAME s_scm_slot_ref_using_class
-{
- SCM res;
-
- SCM_VALIDATE_CLASS (1, class);
- SCM_VALIDATE_INSTANCE (2, obj);
- SCM_VALIDATE_SYMBOL (3, slot_name);
-
- res = get_slot_value_using_name (class, obj, slot_name);
- if (SCM_GOOPS_UNBOUNDP (res))
- return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound), class, obj, slot_name);
- return res;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_slot_set_using_class_x, "slot-set-using-class!", 4, 0, 0,
- (SCM class, SCM obj, SCM slot_name, SCM value),
- "")
-#define FUNC_NAME s_scm_slot_set_using_class_x
-{
- SCM_VALIDATE_CLASS (1, class);
- SCM_VALIDATE_INSTANCE (2, obj);
- SCM_VALIDATE_SYMBOL (3, slot_name);
-
- return set_slot_value_using_name (class, obj, slot_name, value);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_slot_bound_using_class_p, "slot-bound-using-class?", 3, 0, 0,
- (SCM class, SCM obj, SCM slot_name),
- "")
-#define FUNC_NAME s_scm_slot_bound_using_class_p
-{
- SCM_VALIDATE_CLASS (1, class);
- SCM_VALIDATE_INSTANCE (2, obj);
- SCM_VALIDATE_SYMBOL (3, slot_name);
-
- return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj, slot_name))
- ? SCM_BOOL_F
- : SCM_BOOL_T);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_slot_exists_using_class_p, "slot-exists-using-class?", 3, 0, 0,
- (SCM class, SCM obj, SCM slot_name),
- "")
-#define FUNC_NAME s_scm_slot_exists_using_class_p
-{
- SCM_VALIDATE_CLASS (1, class);
- SCM_VALIDATE_INSTANCE (2, obj);
- SCM_VALIDATE_SYMBOL (3, slot_name);
- return test_slot_existence (class, obj, slot_name);
-}
-#undef FUNC_NAME
-
-
- /* ======================================== */
-
-SCM_DEFINE (scm_slot_ref, "slot-ref", 2, 0, 0,
- (SCM obj, SCM slot_name),
- "Return the value from @var{obj}'s slot with the name\n"
- "@var{slot_name}.")
-#define FUNC_NAME s_scm_slot_ref
+SCM
+scm_slot_ref (SCM obj, SCM slot_name)
{
- SCM res, class;
-
- SCM_VALIDATE_INSTANCE (1, obj);
- TEST_CHANGE_CLASS (obj, class);
-
- res = get_slot_value_using_name (class, obj, slot_name);
- if (SCM_GOOPS_UNBOUNDP (res))
- return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound), class, obj, slot_name);
- return res;
+ return scm_call_2 (scm_variable_ref (var_slot_ref), obj, slot_name);
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_slot_set_x, "slot-set!", 3, 0, 0,
- (SCM obj, SCM slot_name, SCM value),
- "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
-#define FUNC_NAME s_scm_slot_set_x
+SCM
+scm_slot_set_x (SCM obj, SCM slot_name, SCM value)
{
- SCM class;
-
- SCM_VALIDATE_INSTANCE (1, obj);
- TEST_CHANGE_CLASS(obj, class);
-
- return set_slot_value_using_name (class, obj, slot_name, value);
+ return scm_call_3 (scm_variable_ref (var_slot_set_x), obj, slot_name, value);
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_slot_bound_p, "slot-bound?", 2, 0, 0,
- (SCM obj, SCM slot_name),
- "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
- "is bound.")
-#define FUNC_NAME s_scm_slot_bound_p
+SCM
+scm_slot_bound_p (SCM obj, SCM slot_name)
{
- SCM class;
-
- SCM_VALIDATE_INSTANCE (1, obj);
- TEST_CHANGE_CLASS(obj, class);
-
- return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
- obj,
- slot_name))
- ? SCM_BOOL_F
- : SCM_BOOL_T);
+ return scm_call_2 (scm_variable_ref (var_slot_bound_p), obj, slot_name);
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_slot_exists_p, "slot-exists?", 2, 0, 0,
- (SCM obj, SCM slot_name),
- "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
-#define FUNC_NAME s_scm_slot_exists_p
+SCM
+scm_slot_exists_p (SCM obj, SCM slot_name)
{
- SCM class;
-
- SCM_VALIDATE_INSTANCE (1, obj);
- SCM_VALIDATE_SYMBOL (2, slot_name);
- TEST_CHANGE_CLASS (obj, class);
-
- return test_slot_existence (class, obj, slot_name);
+ return scm_call_2 (scm_variable_ref (var_slot_exists_p), obj, slot_name);
}
-#undef FUNC_NAME
-/******************************************************************************
- *
- * %allocate-instance (the low level instance allocation primitive)
- *
- ******************************************************************************/
+\f
-SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
- (SCM class, SCM initargs),
- "Create a new instance of class @var{class} and initialize it\n"
- "from the arguments @var{initargs}.")
-#define FUNC_NAME s_scm_sys_allocate_instance
+SCM_DEFINE (scm_sys_clear_fields_x, "%clear-fields!", 2, 0, 0,
+ (SCM obj, SCM unbound),
+ "")
+#define FUNC_NAME s_scm_sys_clear_fields_x
{
- SCM obj;
scm_t_signed_bits n, i;
- SCM layout;
+ SCM vtable, layout;
- SCM_VALIDATE_CLASS (1, class);
+ SCM_VALIDATE_STRUCT (1, obj);
+ vtable = SCM_STRUCT_VTABLE (obj);
- /* FIXME: duplicates some of scm_make_struct. */
+ n = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
+ layout = SCM_VTABLE_LAYOUT (vtable);
- n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
- obj = scm_i_alloc_struct (SCM_STRUCT_DATA (class), n);
-
- layout = SCM_VTABLE_LAYOUT (class);
-
- /* Set all SCM-holding slots to unbound */
+ /* Set all SCM-holding slots to the GOOPS unbound value. */
for (i = 0; i < n; i++)
- {
- scm_t_wchar c = scm_i_symbol_ref (layout, i*2);
- if (c == 'p')
- SCM_STRUCT_DATA (obj)[i] = SCM_UNPACK (SCM_GOOPS_UNBOUND);
- else if (c == 's')
- SCM_STRUCT_DATA (obj)[i] = SCM_UNPACK (obj);
- else
- SCM_STRUCT_DATA (obj)[i] = 0;
- }
+ if (scm_i_symbol_ref (layout, i*2) == 'p')
+ SCM_STRUCT_SLOT_SET (obj, i, unbound);
- return obj;
+ return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-/******************************************************************************
- *
- * %modify-instance (used by change-class to modify in place)
- *
- ******************************************************************************/
+
+\f
SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0,
(SCM old, SCM new),
- "")
+ "Used by change-class to modify objects in place.")
#define FUNC_NAME s_scm_sys_modify_instance
{
SCM_VALIDATE_INSTANCE (1, old);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_sys_invalidate_class, "%invalidate-class", 1, 0, 0,
- (SCM class),
- "")
-#define FUNC_NAME s_scm_sys_invalidate_class
-{
- SCM_VALIDATE_CLASS (1, class);
- SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
/* When instances change class, they finally get a new body, but
* before that, they go through purgatory in hell. Odd as it may
* seem, this data structure saves us from eternal suffering in
}
-SCM_SYMBOL (scm_sym_change_class, "change-class");
-
static SCM
purgatory (SCM obj, SCM new_class)
{
}
}
-/******************************************************************************
- *
- * GGGG FFFFF
- * G F
- * G GG FFF
- * G G F
- * GGG E N E R I C F U N C T I O N S
- *
- * This implementation provides
- * - generic functions (with class specializers)
- * - multi-methods
- * - next-method
- * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
- *
- ******************************************************************************/
-SCM_KEYWORD (k_name, "name");
-SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
+\f
+
+/* Primitive generics: primitives that can dispatch to generics if their
+ arguments fail to apply. */
SCM_DEFINE (scm_generic_capability_p, "generic-capability?", 1, 0, 0,
(SCM proc),
#define FUNC_NAME s_scm_set_primitive_generic_x
{
SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARG1, FUNC_NAME);
- SCM_ASSERT (SCM_PUREGENERICP (generic), generic, SCM_ARG2, FUNC_NAME);
+ SCM_ASSERT (SCM_GENERICP (generic), generic, SCM_ARG2, FUNC_NAME);
SCM_SET_SUBR_GENERIC (subr, generic);
return SCM_UNSPECIFIED;
}
}
#undef FUNC_NAME
-typedef struct t_extension {
- struct t_extension *next;
- SCM extended;
- SCM extension;
-} t_extension;
-
-
-/* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
- objects. */
-static const char extension_gc_hint[] = "GOOPS extension";
-
-static t_extension *extensions = 0;
-
-void
-scm_c_extend_primitive_generic (SCM extended, SCM extension)
-{
- if (goops_loaded_p)
- {
- SCM gf, gext;
- if (!SCM_UNPACK (*SCM_SUBR_GENERIC (extended)))
- scm_enable_primitive_generic_x (scm_list_1 (extended));
- gf = *SCM_SUBR_GENERIC (extended);
- gext = scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic),
- gf,
- SCM_SUBR_NAME (extension));
- SCM_SET_SUBR_GENERIC (extension, gext);
- }
- else
- {
- t_extension *e = scm_gc_malloc (sizeof (t_extension),
- extension_gc_hint);
- t_extension **loc = &extensions;
- /* Make sure that extensions are placed before their own
- * extensions in the extensions list. O(N^2) algorithm, but
- * extensions of primitive generics are rare.
- */
- while (*loc && !scm_is_eq (extension, (*loc)->extended))
- loc = &(*loc)->next;
- e->next = *loc;
- e->extended = extended;
- e->extension = extension;
- *loc = e;
- }
-}
-
-static void
-setup_extended_primitive_generics ()
-{
- while (extensions)
- {
- t_extension *e = extensions;
- scm_c_extend_primitive_generic (e->extended, e->extension);
- extensions = e->next;
- }
-}
-
-/* Dirk:FIXME:: In all of these scm_wta_dispatch_* routines it is
- * assumed that 'gf' is zero if uninitialized. It would be cleaner if
- * some valid SCM value like SCM_BOOL_F or SCM_UNDEFINED were chosen.
- */
-
SCM
scm_wta_dispatch_0 (SCM gf, const char *subr)
{
return scm_apply_0 (gf, args);
}
-/******************************************************************************
- *
- * Protocol for calling a generic fumction
- * This protocol is roughly equivalent to (parameter are a little bit different
- * for efficiency reasons):
- *
- * + apply-generic (gf args)
- * + compute-applicable-methods (gf args ...)
- * + sort-applicable-methods (methods args)
- * + apply-methods (gf methods args)
- *
- * apply-methods calls make-next-method to build the "continuation" of a a
- * method. Applying a next-method will call apply-next-method which in
- * turn will call apply again to call effectively the following method.
- *
- ******************************************************************************/
-SCM_DEFINE (scm_make, "make", 0, 0, 1,
- (SCM args),
- "Make a new object. @var{args} must contain the class and\n"
- "all necessary initialization information.")
-#define FUNC_NAME s_scm_make
+\f
+
+SCM
+scm_make (SCM args)
{
return scm_apply_0 (scm_variable_ref (var_make), args);
}
-#undef FUNC_NAME
-/**********************************************************************
- *
- * Smob classes
- *
- **********************************************************************/
+\f
+
+/* SMOB, struct, and port classes. */
static SCM
make_class_name (const char *prefix, const char *type_name, const char *suffix)
void
scm_i_inherit_applicable (SCM c)
{
- if (!SCM_SUBCLASSP (c, class_applicable))
- {
- SCM dsupers = SCM_SLOT (c, scm_si_direct_supers);
- SCM cpl = SCM_SLOT (c, scm_si_cpl);
- /* patch class_applicable into direct-supers */
- SCM top = scm_c_memq (class_top, dsupers);
- if (scm_is_false (top))
- dsupers = scm_append (scm_list_2 (dsupers,
- scm_list_1 (class_applicable)));
- else
- {
- SCM_SETCAR (top, class_applicable);
- SCM_SETCDR (top, scm_cons (class_top, SCM_CDR (top)));
- }
- SCM_SET_SLOT (c, scm_si_direct_supers, dsupers);
- /* patch class_applicable into cpl */
- top = scm_c_memq (class_top, cpl);
- if (scm_is_false (top))
- abort ();
- else
- {
- SCM_SETCAR (top, class_applicable);
- SCM_SETCDR (top, scm_cons (class_top, SCM_CDR (top)));
- }
- /* add class to direct-subclasses of class_applicable */
- SCM_SET_SLOT (class_applicable,
- scm_si_direct_subclasses,
- scm_cons (c, SCM_SLOT (class_applicable,
- scm_si_direct_subclasses)));
- }
+ scm_call_1 (scm_variable_ref (var_inherit_applicable), c);
}
static void
vtable_class_map);
}
-/**********************************************************************
- *
- * C interface
- *
- **********************************************************************/
+
+\f
void
scm_load_goops ()
scm_c_resolve_module ("oop goops");
}
-
-SCM_KEYWORD (k_setter, "setter");
-
SCM
scm_ensure_accessor (SCM name)
{
return gf;
}
-#ifdef GUILE_DEBUG
-/*
- * Debugging utilities
- */
-SCM_DEFINE (scm_pure_generic_p, "pure-generic?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a pure generic.")
-#define FUNC_NAME s_scm_pure_generic_p
-{
- return scm_from_bool (SCM_PUREGENERICP (obj));
-}
-#undef FUNC_NAME
-
-#endif /* GUILE_DEBUG */
-
-/*
- * Initialization
- */
-
-SCM_DEFINE (scm_sys_bless_applicable_struct_vtables_x, "%bless-applicable-struct-vtables!", 2, 0, 0,
- (SCM applicable, SCM setter),
- "")
-#define FUNC_NAME s_scm_sys_bless_applicable_struct_vtables_x
-{
- SCM_VALIDATE_CLASS (1, applicable);
- SCM_VALIDATE_CLASS (2, setter);
- SCM_SET_VTABLE_FLAGS (applicable, SCM_VTABLE_FLAG_APPLICABLE_VTABLE);
- SCM_SET_VTABLE_FLAGS (setter, SCM_VTABLE_FLAG_SETTER_VTABLE);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_sys_bless_pure_generic_vtable_x, "%bless-pure-generic-vtable!", 1, 0, 0,
- (SCM vtable),
- "")
-#define FUNC_NAME s_scm_sys_bless_pure_generic_vtable_x
-{
- SCM_VALIDATE_CLASS (1, vtable);
- SCM_SET_CLASS_FLAGS (vtable, SCM_CLASSF_PURE_GENERIC);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
+\f
SCM_DEFINE (scm_sys_goops_early_init, "%goops-early-init", 0, 0, 0,
(),
{
var_make_standard_class = scm_c_lookup ("make-standard-class");
var_make = scm_c_lookup ("make");
+ var_inherit_applicable = scm_c_lookup ("inherit-applicable!");
+
+ /* For SCM_SUBCLASSP. */
+ var_class_precedence_list = scm_c_lookup ("class-precedence-list");
+
+ var_slot_ref = scm_c_lookup ("slot-ref");
+ var_slot_set_x = scm_c_lookup ("slot-set!");
+ var_slot_bound_p = scm_c_lookup ("slot-bound?");
+ var_slot_exists_p = scm_c_lookup ("slot-exists?");
class_class = scm_variable_ref (scm_c_lookup ("<class>"));
class_top = scm_variable_ref (scm_c_lookup ("<top>"));
var_class_direct_slots = scm_c_lookup ("class-direct-slots");
var_class_direct_subclasses = scm_c_lookup ("class-direct-subclasses");
var_class_direct_methods = scm_c_lookup ("class-direct-methods");
- var_class_precedence_list = scm_c_lookup ("class-precedence-list");
var_class_slots = scm_c_lookup ("class-slots");
var_generic_function_methods = scm_c_lookup ("generic-function-methods");
var_method_specializers = scm_c_lookup ("method-specializers");
var_method_procedure = scm_c_lookup ("method-procedure");
- var_slot_unbound =
- scm_module_variable (scm_module_goops, sym_slot_unbound);
- var_slot_missing =
- scm_module_variable (scm_module_goops, sym_slot_missing);
- var_change_class =
- scm_module_variable (scm_module_goops, sym_change_class);
- setup_extended_primitive_generics ();
+ var_change_class = scm_c_lookup ("change-class");
#if (SCM_ENABLE_DEPRECATED == 1)
scm_init_deprecated_goops ();
}
#undef FUNC_NAME
-SCM scm_module_goops;
-
static void
scm_init_goops_builtins (void *unused)
{
hell_mutex = scm_make_mutex ();
#include "libguile/goops.x"
+
+ scm_c_define ("vtable-flag-vtable",
+ scm_from_int (SCM_VTABLE_FLAG_VTABLE));
+ scm_c_define ("vtable-flag-applicable-vtable",
+ scm_from_int (SCM_VTABLE_FLAG_APPLICABLE_VTABLE));
+ scm_c_define ("vtable-flag-setter-vtable",
+ scm_from_int (SCM_VTABLE_FLAG_SETTER_VTABLE));
+ scm_c_define ("vtable-flag-validated",
+ scm_from_int (SCM_VTABLE_FLAG_VALIDATED));
+ scm_c_define ("vtable-flag-goops-class",
+ scm_from_int (SCM_VTABLE_FLAG_GOOPS_CLASS));
+ scm_c_define ("vtable-flag-goops-valid",
+ scm_from_int (SCM_VTABLE_FLAG_GOOPS_VALID));
}
void