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_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;
/* SMOB classes. */
SCM scm_i_smob_class[SCM_I_MAX_SMOB_TYPE_COUNT];
+SCM scm_module_goops;
+
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_make_root_class (SCM name, SCM dslots,
- SCM getters_n_setters);
+static SCM scm_sys_make_root_class (SCM layout);
static SCM scm_sys_init_layout_x (SCM class, SCM layout);
+static SCM scm_sys_clear_fields_x (SCM obj);
static SCM scm_sys_goops_early_init (void);
static SCM scm_sys_goops_loaded (void);
+\f
+
+SCM_DEFINE (scm_sys_make_root_class, "%make-root-class", 1, 0, 0,
+ (SCM layout),
+ "")
+#define FUNC_NAME s_scm_sys_make_root_class
+{
+ SCM z;
+
+ z = scm_i_make_vtable_vtable (layout);
+ SCM_SET_CLASS_FLAGS (z, (SCM_CLASSF_GOOPS_OR_VALID | SCM_CLASSF_METACLASS));
+
+ return z;
+}
+#undef FUNC_NAME
+
+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
+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
-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),
return SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), class_method);
}
-/******************************************************************************
- *
- * Meta object accessors
- *
- ******************************************************************************/
+
+\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
- *
- ******************************************************************************/
+
+\f
SCM_DEFINE (scm_make_unbound, "make-unbound", 0, 0, 0,
(),
}
-/******************************************************************************
- *
- * %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!", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_sys_clear_fields_x
{
- SCM obj;
scm_t_signed_bits n, i;
- SCM layout;
-
- SCM_VALIDATE_CLASS (1, class);
+ SCM vtable, layout;
- /* FIXME: duplicates some of scm_make_struct. */
+ SCM_VALIDATE_STRUCT (1, obj);
+ vtable = SCM_STRUCT_VTABLE (obj);
- n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
- obj = scm_i_alloc_struct (SCM_STRUCT_DATA (class), n);
+ n = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
+ layout = SCM_VTABLE_LAYOUT (vtable);
- 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, SCM_GOOPS_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);
}
}
-/******************************************************************************
- *
- * 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),
}
#undef FUNC_NAME
-/* 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.
- *
- ******************************************************************************/
+
+\f
SCM_DEFINE (scm_make, "make", 0, 0, 1,
(SCM 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;
}
-/*
- * 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
+\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_using_class = scm_c_lookup ("slot-ref-using-class");
var_slot_set_using_class_x = scm_c_lookup ("slot-set-using-class!");
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");
}
#undef FUNC_NAME
-SCM scm_module_goops;
-
static void
scm_init_goops_builtins (void *unused)
{
HCoop / bpt / guile.git / blobdiff