#define SCM_OUT_PCLASS_INDEX SCM_I_MAX_PORT_TYPE_COUNT
#define SCM_INOUT_PCLASS_INDEX (2 * SCM_I_MAX_PORT_TYPE_COUNT)
-#define SCM_GOOPS_UNBOUND SCM_UNBOUND
-#define SCM_GOOPS_UNBOUNDP(x) (scm_is_eq (x, SCM_GOOPS_UNBOUND))
-
/* Objects have identity, so references to classes and instances are by
value, not by reference. Redefinition of a class or modification of
an instance causes in-place update; you can think of GOOPS as
static SCM var_method_specializers = SCM_BOOL_F;
static SCM var_method_procedure = SCM_BOOL_F;
-static SCM var_slot_ref_using_class = SCM_BOOL_F;
-static SCM var_slot_set_using_class_x = SCM_BOOL_F;
-static SCM var_slot_bound_using_class_p = SCM_BOOL_F;
-static SCM var_slot_exists_using_class_p = SCM_BOOL_F;
-
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 class_fluid;
static SCM class_dynamic_state;
static SCM class_frame;
+static SCM class_keyword;
static SCM class_vm_cont;
static SCM class_bytevector;
static SCM class_uvec;
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 layout);
+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);
+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_root_class, "%make-root-class", 1, 0, 0,
+SCM_DEFINE (scm_sys_make_vtable_vtable, "%make-vtable-vtable", 1, 0, 0,
(SCM layout),
"")
-#define FUNC_NAME s_scm_sys_make_root_class
+#define FUNC_NAME s_scm_sys_make_vtable_vtable
{
- 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;
+ return scm_i_make_vtable_vtable (layout);
}
#undef FUNC_NAME
}
#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)
{
\f
-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
-
-SCM
-scm_slot_ref_using_class (SCM class, SCM obj, SCM slot_name)
-{
- return scm_call_3 (scm_variable_ref (var_slot_ref_using_class),
- class, obj, slot_name);
-}
-
-SCM
-scm_slot_set_using_class_x (SCM class, SCM obj, SCM slot_name, SCM value)
-{
- return scm_call_4 (scm_variable_ref (var_slot_set_using_class_x),
- class, obj, slot_name, value);
-}
-
-SCM
-scm_slot_bound_using_class_p (SCM class, SCM obj, SCM slot_name)
-{
- return scm_call_3 (scm_variable_ref (var_slot_bound_using_class_p),
- class, obj, slot_name);
-}
-
-SCM
-scm_slot_exists_using_class_p (SCM class, SCM obj, SCM slot_name)
-{
- return scm_call_3 (scm_variable_ref (var_slot_exists_using_class_p),
- class, obj, slot_name);
-}
-
SCM
scm_slot_ref (SCM obj, SCM slot_name)
{
\f
-SCM_DEFINE (scm_sys_clear_fields_x, "%clear-fields!", 1, 0, 0,
- (SCM obj),
+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
{
/* Set all SCM-holding slots to the GOOPS unbound value. */
for (i = 0; i < n; i++)
if (scm_i_symbol_ref (layout, i*2) == 'p')
- SCM_STRUCT_SLOT_SET (obj, i, SCM_GOOPS_UNBOUND);
+ SCM_STRUCT_SLOT_SET (obj, i, unbound);
return SCM_UNSPECIFIED;
}
}
#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
\f
-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
+SCM
+scm_make (SCM args)
{
return scm_apply_0 (scm_variable_ref (var_make), args);
}
-#undef FUNC_NAME
\f
/* 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_slot_bound_using_class_p = scm_c_lookup ("slot-bound-using-class?");
- var_slot_exists_using_class_p = scm_c_lookup ("slot-exists-using-class?");
-
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?");
class_fluid = scm_variable_ref (scm_c_lookup ("<fluid>"));
class_dynamic_state = scm_variable_ref (scm_c_lookup ("<dynamic-state>"));
class_frame = scm_variable_ref (scm_c_lookup ("<frame>"));
+ class_keyword = scm_variable_ref (scm_c_lookup ("<keyword>"));
class_vm_cont = scm_variable_ref (scm_c_lookup ("<vm-continuation>"));
class_bytevector = scm_variable_ref (scm_c_lookup ("<bytevector>"));
class_uvec = scm_variable_ref (scm_c_lookup ("<uvec>"));
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));
+ scm_c_define ("vtable-flag-goops-slot",
+ scm_from_int (SCM_VTABLE_FLAG_GOOPS_SLOT));
+ scm_c_define ("vtable-flag-goops-static",
+ scm_from_int (SCM_VTABLE_FLAG_GOOPS_STATIC));
}
void
HCoop / bpt / guile.git / blobdiff