-/* Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc.
+/* Copyright (C) 1998,1999,2000,2001 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
scm_module_goops); }
/* Temporary hack until we get the new module system */
/*fixme* Should optimize by keeping track of the variable object itself */
-#define GETVAR(v) (SCM_CDDR (scm_apply (scm_goops_lookup_closure, \
+#define GETVAR(v) (SCM_VARIABLE_REF (scm_apply (scm_goops_lookup_closure, \
SCM_LIST2 ((v), SCM_BOOL_F), \
SCM_EOL)))
h1.
*/
-#define SCM_CLASS_REDEF(c) SCM_SLOT (c, scm_si_redefined)
/* The following definition is located in libguile/objects.h:
#define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined])
*/
#define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND)
static int goops_loaded_p = 0;
-static scm_rstate *goops_rstate;
+static scm_rstate_t *goops_rstate;
static SCM scm_goops_lookup_closure;
* Compute-cpl
*
* This version doesn't handle multiple-inheritance. It serves only for
- * booting classes and will be overaloaded in Scheme
+ * booting classes and will be overloaded in Scheme
*
******************************************************************************/
* compute-getters-n-setters
*
* This version doesn't handle slot options. It serves only for booting
- * classes and will be overaloaded in Scheme.
+ * classes and will be overloaded in Scheme.
*
******************************************************************************/
/*fixme* Manufacture keywords in advance */
SCM
-scm_i_get_keyword (SCM key, SCM l, int len, SCM default_value, const char *subr)
+scm_i_get_keyword (SCM key, SCM l, long len, SCM default_value, const char *subr)
{
- unsigned int i;
+ long i;
for (i = 0; i != len; i += 2)
{
"@var{default_value} is returned.")
#define FUNC_NAME s_scm_get_keyword
{
- int len;
+ long len;
SCM_ASSERT (SCM_KEYWORDP (key), key, SCM_ARG1, FUNC_NAME);
len = scm_ilength (l);
{
SCM tmp, get_n_set, slots;
SCM class = SCM_CLASS_OF (obj);
- int n_initargs;
+ long n_initargs;
SCM_VALIDATE_INSTANCE (1, obj);
n_initargs = scm_ilength (initargs);
if (SCM_NIMP (SCM_CDR (slot_name)))
{
/* This slot admits (perhaps) to be initialized at creation time */
- int n = scm_ilength (SCM_CDR (slot_name));
+ long n = scm_ilength (SCM_CDR (slot_name));
if (n & 1) /* odd or -1 */
SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
SCM_LIST1 (slot_name));
"")
#define FUNC_NAME s_scm_sys_prep_layout_x
{
- int i, n, len;
+ long i, n, len;
char *s, p, a;
SCM nfields, slots, type;
s[i + 1] = a;
slots = SCM_CDR (slots);
}
- SCM_SLOT (class, scm_si_layout) = scm_mem2symbol (s, n);
+ SCM_SET_SLOT (class, scm_si_layout, scm_mem2symbol (s, n));
if (s)
scm_must_free (s);
return SCM_UNSPECIFIED;
SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity);
else
{
- int n = SCM_INUM (SCM_SLOT (class, scm_si_nfields));
+ long n = SCM_INUM (SCM_SLOT (class, scm_si_nfields));
#if 0
/*
* We could avoid calling scm_must_malloc in the allocation code
void
prep_hashsets (SCM class)
{
- int i;
+ unsigned int i;
for (i = 0; i < 7; ++i)
- SCM_SLOT (class, scm_si_hashsets + i)
- = SCM_PACK (scm_c_uniform32 (goops_rstate));
+ SCM_SET_HASHSET (class, i, scm_c_uniform32 (goops_rstate));
}
/******************************************************************************/
#if 0
cpl = compute_cpl (dsupers, SCM_LIST1(z));
#endif
- SCM_SLOT (z, scm_si_direct_supers) = dsupers;
+ SCM_SET_SLOT (z, scm_si_direct_supers, dsupers);
cpl = compute_cpl (z);
slots = build_slots_list (maplist (dslots), cpl);
nfields = SCM_MAKINUM (scm_ilength (slots));
g_n_s = compute_getters_n_setters (slots);
- SCM_SLOT(z, scm_si_name) = name;
- SCM_SLOT(z, scm_si_direct_slots) = dslots;
- SCM_SLOT(z, scm_si_direct_subclasses) = SCM_EOL;
- SCM_SLOT(z, scm_si_direct_methods) = SCM_EOL;
- SCM_SLOT(z, scm_si_cpl) = cpl;
- SCM_SLOT(z, scm_si_slots) = slots;
- SCM_SLOT(z, scm_si_nfields) = nfields;
- SCM_SLOT(z, scm_si_getters_n_setters) = g_n_s;
- SCM_SLOT(z, scm_si_redefined) = SCM_BOOL_F;
- SCM_SLOT(z, scm_si_environment)
- = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE);
+ SCM_SET_SLOT (z, scm_si_name, name);
+ SCM_SET_SLOT (z, scm_si_direct_slots, dslots);
+ 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, cpl);
+ SCM_SET_SLOT (z, scm_si_slots, slots);
+ SCM_SET_SLOT (z, scm_si_nfields, nfields);
+ SCM_SET_SLOT (z, scm_si_getters_n_setters, g_n_s);
+ SCM_SET_SLOT (z, scm_si_redefined, SCM_BOOL_F);
+ SCM_SET_SLOT (z, scm_si_environment,
+ scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE));
/* Add this class in the direct-subclasses slot of dsupers */
{
SCM tmp;
- for (tmp = dsupers; SCM_NNULLP(tmp); tmp = SCM_CDR(tmp))
- SCM_SLOT(SCM_CAR(tmp), scm_si_direct_subclasses)
- = scm_cons(z, SCM_SLOT(SCM_CAR(tmp), scm_si_direct_subclasses));
+ for (tmp = dsupers; !SCM_NULLP (tmp); tmp = SCM_CDR (tmp))
+ SCM_SET_SLOT (SCM_CAR (tmp), scm_si_direct_subclasses,
+ scm_cons (z, SCM_SLOT (SCM_CAR (tmp),
+ scm_si_direct_subclasses)));
}
/* Support for the underlying structs: */
SCM_SET_CLASS_FLAGS (scm_class_class, (SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_METACLASS));
- SCM_SLOT(scm_class_class, scm_si_name) = name;
- SCM_SLOT(scm_class_class, scm_si_direct_supers) = SCM_EOL; /* will be changed */
- /* SCM_SLOT(scm_class_class, scm_si_direct_slots) = slots_of_class; */
- SCM_SLOT(scm_class_class, scm_si_direct_subclasses)= SCM_EOL;
- SCM_SLOT(scm_class_class, scm_si_direct_methods) = SCM_EOL;
- SCM_SLOT(scm_class_class, scm_si_cpl) = SCM_EOL; /* will be changed */
- /* SCM_SLOT(scm_class_class, scm_si_slots) = slots_of_class; */
- SCM_SLOT(scm_class_class, scm_si_nfields) = SCM_MAKINUM (SCM_N_CLASS_SLOTS);
- /* SCM_SLOT(scm_class_class, scm_si_getters_n_setters)
- = compute_getters_n_setters (slots_of_class); */
- SCM_SLOT(scm_class_class, scm_si_redefined) = SCM_BOOL_F;
- SCM_SLOT(scm_class_class, scm_si_environment)
- = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE);
+ SCM_SET_SLOT (scm_class_class, scm_si_name, name);
+ SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, SCM_EOL); /* will be changed */
+ /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
+ SCM_SET_SLOT (scm_class_class, scm_si_direct_subclasses, SCM_EOL);
+ SCM_SET_SLOT (scm_class_class, scm_si_direct_methods, SCM_EOL);
+ SCM_SET_SLOT (scm_class_class, scm_si_cpl, SCM_EOL); /* will be changed */
+ /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
+ SCM_SET_SLOT (scm_class_class, scm_si_nfields, SCM_MAKINUM (SCM_N_CLASS_SLOTS));
+ /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
+ compute_getters_n_setters (slots_of_class)); */
+ SCM_SET_SLOT (scm_class_class, scm_si_redefined, SCM_BOOL_F);
+ SCM_SET_SLOT (scm_class_class, scm_si_environment,
+ scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE));
prep_hashsets (scm_class_class);
DEFVAR (name, scm_class_object);
/* <top> <object> and <class> were partially initialized. Correct them here */
- SCM_SLOT (scm_class_object, scm_si_direct_subclasses) = SCM_LIST1 (scm_class_class);
+ SCM_SET_SLOT (scm_class_object, scm_si_direct_subclasses, SCM_LIST1 (scm_class_class));
- SCM_SLOT (scm_class_class, scm_si_direct_supers) = SCM_LIST1 (scm_class_object);
- SCM_SLOT (scm_class_class, scm_si_cpl) = SCM_LIST3 (scm_class_class, scm_class_object, scm_class_top);
+ SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, SCM_LIST1 (scm_class_object));
+ SCM_SET_SLOT (scm_class_class, scm_si_cpl, SCM_LIST3 (scm_class_class, scm_class_object, scm_class_top));
}
/******************************************************************************/
SCM_VALIDATE_INUM (2, index);
i = SCM_INUM (index);
SCM_ASSERT_RANGE (2, index, i >= 0 && i < SCM_NUMBER_OF_SLOTS (obj));
- SCM_SLOT (obj, i) = value;
+ SCM_SET_SLOT (obj, i, value);
return SCM_UNSPECIFIED;
}
}
static SCM
-get_slot_value (SCM class, SCM obj, SCM slotdef)
+get_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef)
{
SCM access = SCM_CDDR (slotdef);
/* Two cases here:
code = SCM_CAR (access);
if (!SCM_CLOSUREP (code))
return SCM_SUBRF (code) (obj);
- env = SCM_EXTEND_ENV (SCM_CAR (SCM_CODE (code)),
+ env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
SCM_LIST1 (obj),
SCM_ENV (code));
/* Evaluate the closure body */
}
static SCM
-set_slot_value (SCM class, SCM obj, SCM slotdef, SCM value)
+set_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef, SCM value)
{
SCM access = SCM_CDDR (slotdef);
/* Two cases here:
* - otherwise (cadr access) is the setter function to apply
*/
if (SCM_INUMP (access))
- SCM_SLOT (obj, SCM_INUM (access)) = value;
+ SCM_SET_SLOT (obj, SCM_INUM (access), value);
else
{
/* We must evaluate (apply (cadr l) (list obj value))
SCM_SUBRF (code) (obj, value);
else
{
- env = SCM_EXTEND_ENV (SCM_CAR (SCM_CODE (code)),
+ env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
SCM_LIST2 (obj, value),
SCM_ENV (code));
/* Evaluate the closure body */
}
static SCM
-test_slot_existence (SCM class, SCM obj, SCM slot_name)
+test_slot_existence (SCM class SCM_UNUSED, SCM obj, SCM slot_name)
{
register SCM l;
- for (l = SCM_ACCESSORS_OF (obj); SCM_NNULLP (l); l = SCM_CDR (l))
- if (SCM_CAAR (l) == slot_name)
+ for (l = SCM_ACCESSORS_OF (obj); !SCM_NULLP (l); l = SCM_CDR (l))
+ if (SCM_EQ_P (SCM_CAAR (l), slot_name))
return SCM_BOOL_T;
return SCM_BOOL_F;
static void clear_method_cache (SCM);
static SCM
-wrap_init (SCM class, SCM *m, int n)
+wrap_init (SCM class, SCM *m, long n)
{
SCM z;
- int i;
+ long i;
/* Set all slots to unbound */
for (i = 0; i < n; i++)
m[i] = SCM_GOOPS_UNBOUND;
SCM_NEWCELL2 (z);
- SCM_SETCDR (z, (SCM) m);
SCM_SET_STRUCT_GC_CHAIN (z, 0);
- SCM_SETCAR (z, (scm_bits_t) SCM_STRUCT_DATA (class) | scm_tc3_cons_gloc);
+ SCM_SET_CELL_WORD_1 (z, m);
+ SCM_SET_CELL_WORD_0 (z, (scm_bits_t) SCM_STRUCT_DATA (class)
+ | scm_tc3_cons_gloc);
return z;
}
#define FUNC_NAME s_scm_sys_allocate_instance
{
SCM *m;
- int n;
+ long n;
SCM_VALIDATE_CLASS (1, class);
/* Class objects */
if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS)
{
- int i;
+ long i;
/* allocate class object */
SCM z = scm_make_struct (class, SCM_INUM0, SCM_EOL);
- SCM_SLOT (z, scm_si_print) = SCM_GOOPS_UNBOUND;
+ SCM_SET_SLOT (z, scm_si_print, SCM_GOOPS_UNBOUND);
for (i = scm_si_goops_fields; i < n; i++)
- SCM_SLOT (z, i) = SCM_GOOPS_UNBOUND;
+ SCM_SET_SLOT (z, i, SCM_GOOPS_UNBOUND);
if (SCM_SUBCLASSP (class, scm_class_entity_class))
SCM_SET_CLASS_FLAGS (z, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY);
SCM cdr = SCM_CDR (old);
SCM_SETCAR (old, SCM_CAR (new));
SCM_SETCDR (old, SCM_CDR (new));
- SCM_STRUCT_DATA (old)[scm_vtable_index_vtable] = old;
+ SCM_STRUCT_DATA (old)[scm_vtable_index_vtable] = SCM_UNPACK (old);
SCM_SETCAR (new, car);
SCM_SETCDR (new, cdr);
- SCM_STRUCT_DATA (new)[scm_vtable_index_vtable] = new;
+ SCM_STRUCT_DATA (new)[scm_vtable_index_vtable] = SCM_UNPACK (new);
}
SCM_REALLOW_INTS;
return SCM_UNSPECIFIED;
* infinite recursions.
*/
-static SCM **hell;
-static int n_hell = 1; /* one place for the evil one himself */
-static int hell_size = 4;
+static scm_bits_t **hell;
+static long n_hell = 1; /* one place for the evil one himself */
+static long hell_size = 4;
#ifdef USE_THREADS
static scm_mutex_t hell_mutex;
#endif
-static int
+static long
burnin (SCM o)
{
- int i;
+ long i;
for (i = 1; i < n_hell; ++i)
if (SCM_INST (o) == hell[i])
return i;
#endif
if (n_hell == hell_size)
{
- int new_size = 2 * hell_size;
+ long new_size = 2 * hell_size;
hell = scm_must_realloc (hell, hell_size, new_size, "hell");
hell_size = new_size;
}
}
void
-scm_change_object_class (SCM obj, SCM old_class, SCM new_class)
+scm_change_object_class (SCM obj, SCM old_class SCM_UNUSED, SCM new_class)
{
if (!burnin (obj))
scm_internal_dynamic_wind (go_to_hell, purgatory, go_to_heaven,
{
SCM cache = scm_make_method_cache (gf);
SCM_SET_ENTITY_PROCEDURE (gf, cache);
- SCM_SLOT (gf, scm_si_used_by) = SCM_BOOL_F;
+ SCM_SET_SLOT (gf, scm_si_used_by, SCM_BOOL_F);
}
SCM_DEFINE (scm_sys_invalidate_method_cache_x, "%invalidate-method-cache!", 1, 0, 0,
scm_sys_invalidate_method_cache_x (SCM_CAR (used_by));
clear_method_cache (gf);
for (; SCM_CONSP (methods); methods = SCM_CDR (methods))
- SCM_SLOT (SCM_CAR (methods), scm_si_code_table) = SCM_EOL;
+ SCM_SET_SLOT (SCM_CAR (methods), scm_si_code_table, SCM_EOL);
}
{
SCM n = SCM_SLOT (gf, scm_si_n_specialized);
more_specificp (SCM m1, SCM m2, SCM *targs)
{
register SCM s1, s2;
- register int i;
+ register long i;
/*
* Note:
* m1 and m2 can have != length (i.e. one can be one element longer than the
if (SCM_CAR(s1) != SCM_CAR(s2)) {
register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2);
- for (l = SCM_SLOT(targs[i], scm_si_cpl); ; l = SCM_CDR(l)) {
+ for (l = SCM_SLOT (targs[i], scm_si_cpl); ; l = SCM_CDR(l)) {
if (cs1 == SCM_CAR(l))
return 1;
if (cs2 == SCM_CAR(l))
#define BUFFSIZE 32 /* big enough for most uses */
static SCM
-scm_i_vector2list (SCM l, int len)
+scm_i_vector2list (SCM l, long len)
{
- int j;
+ long j;
SCM z = scm_c_make_vector (len, SCM_UNDEFINED);
for (j = 0; j < len; j++, l = SCM_CDR (l)) {
}
static SCM
-sort_applicable_methods (SCM method_list, int size, SCM *targs)
+sort_applicable_methods (SCM method_list, long size, SCM *targs)
{
- int i, j, incr;
+ long i, j, incr;
SCM *v, vector = SCM_EOL;
SCM buffer[BUFFSIZE];
SCM save = method_list;
}
SCM
-scm_compute_applicable_methods (SCM gf, SCM args, int len, int find_method_p)
+scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
{
- register int i;
- int count = 0;
+ register long i;
+ long count = 0;
SCM l, fl, applicable = SCM_EOL;
SCM save = args;
SCM buffer[BUFFSIZE], *types, *p;
scm_sys_compute_applicable_methods (SCM gf, SCM args)
#define FUNC_NAME s_sys_compute_applicable_methods
{
- int n;
+ long n;
SCM_VALIDATE_GENERIC (1, gf);
n = scm_ilength (args);
SCM_ASSERT (n >= 0, args, SCM_ARG2, FUNC_NAME);
}
#undef FUNC_NAME
-SCM_VCELL_INIT (var_compute_applicable_methods, "compute-applicable-methods", scm_make_gsubr (s_sys_compute_applicable_methods, 2, 0, 0, scm_sys_compute_applicable_methods));
+SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods");
+SCM_VARIABLE_INIT (var_compute_applicable_methods, "compute-applicable-methods", scm_c_define_gsubr (s_sys_compute_applicable_methods, 2, 0, 0, scm_sys_compute_applicable_methods));
SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_makmmacro, scm_m_atslot_ref);
SCM
-scm_m_atslot_ref (SCM xorig, SCM env)
+scm_m_atslot_ref (SCM xorig, SCM env SCM_UNUSED)
#define FUNC_NAME s_atslot_ref
{
SCM x = SCM_CDR (xorig);
SCM_SYNTAX (s_atslot_set_x, "@slot-set!", scm_makmmacro, scm_m_atslot_set_x);
SCM
-scm_m_atslot_set_x (SCM xorig, SCM env)
+scm_m_atslot_set_x (SCM xorig, SCM env SCM_UNUSED)
#define FUNC_NAME s_atslot_set_x
{
SCM x = SCM_CDR (xorig);
#define FUNC_NAME s_scm_make
{
SCM class, z;
- int len = scm_ilength (args);
+ long len = scm_ilength (args);
if (len <= 0 || (len & 1) == 0)
SCM_WRONG_NUM_ARGS ();
|| class == scm_class_simple_method
|| class == scm_class_accessor)
{
- SCM_SLOT (z, scm_si_generic_function) =
+ SCM_SET_SLOT (z, scm_si_generic_function,
scm_i_get_keyword (k_gf,
args,
len - 1,
SCM_BOOL_F,
- FUNC_NAME);
- SCM_SLOT (z, scm_si_specializers) =
+ FUNC_NAME));
+ SCM_SET_SLOT (z, scm_si_specializers,
scm_i_get_keyword (k_specializers,
args,
len - 1,
SCM_EOL,
- FUNC_NAME);
- SCM_SLOT (z, scm_si_procedure) =
+ FUNC_NAME));
+ SCM_SET_SLOT (z, scm_si_procedure,
scm_i_get_keyword (k_procedure,
args,
len - 1,
SCM_EOL,
- FUNC_NAME);
- SCM_SLOT (z, scm_si_code_table) = SCM_EOL;
+ FUNC_NAME));
+ SCM_SET_SLOT (z, scm_si_code_table, SCM_EOL);
}
else
{
/* In all the others case, make a new class .... No instance here */
- SCM_SLOT (z, scm_si_name) =
+ SCM_SET_SLOT (z, scm_si_name,
scm_i_get_keyword (k_name,
args,
len - 1,
scm_str2symbol ("???"),
- FUNC_NAME);
- SCM_SLOT (z, scm_si_direct_supers) =
+ FUNC_NAME));
+ SCM_SET_SLOT (z, scm_si_direct_supers,
scm_i_get_keyword (k_dsupers,
args,
len - 1,
SCM_EOL,
- FUNC_NAME);
- SCM_SLOT (z, scm_si_direct_slots) =
+ FUNC_NAME));
+ SCM_SET_SLOT (z, scm_si_direct_slots,
scm_i_get_keyword (k_slots,
args,
len - 1,
SCM_EOL,
- FUNC_NAME);
+ FUNC_NAME));
}
}
return z;
#define FUNC_NAME s_scm_find_method
{
SCM gf;
- int len = scm_ilength (l);
+ long len = scm_ilength (l);
if (len == 0)
SCM_WRONG_NUM_ARGS ();
#define FUNC_NAME s_scm_sys_method_more_specific_p
{
SCM l, v;
- int i, len;
+ long i, len;
SCM_VALIDATE_METHOD (1, m1);
SCM_VALIDATE_METHOD (2, m2);
/* Continue initialization of class <class> */
slots = build_class_class_slots ();
- SCM_SLOT (scm_class_class, scm_si_direct_slots) = slots;
- SCM_SLOT (scm_class_class, scm_si_slots) = slots;
- SCM_SLOT (scm_class_class, scm_si_getters_n_setters)
- = compute_getters_n_setters (slots);
+ SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots);
+ SCM_SET_SLOT (scm_class_class, scm_si_slots, slots);
+ SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
+ compute_getters_n_setters (slots));
make_stdcls (&scm_class_foreign_class, "<foreign-class>",
scm_class_class, scm_class_class,
SCM_EOL);
#if 0
/* Patch cpl since compute_cpl doesn't support multiple inheritance. */
- SCM_SLOT (scm_class_generic_with_setter, scm_si_cpl) =
+ SCM_SET_SLOT (scm_class_generic_with_setter, scm_si_cpl,
scm_append (SCM_LIST3 (SCM_LIST2 (scm_class_generic_with_setter,
scm_class_generic),
SCM_SLOT (scm_class_entity_with_setter,
scm_si_cpl),
- SCM_EOL));
+ SCM_EOL)));
#endif
SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter, SCM_CLASSF_PURE_GENERIC);
static void
create_smob_classes (void)
{
- int i;
+ long i;
scm_smob_class = (SCM *) malloc (255 * sizeof (SCM));
for (i = 0; i < 255; ++i)
}
void
-scm_make_port_classes (int ptobnum, char *type_name)
+scm_make_port_classes (long ptobnum, char *type_name)
{
SCM c, class = make_class_from_template ("<%s-port>",
type_name,
SCM_LIST2 (class,
scm_class_input_output_port));
/* Patch cpl (since this tree is too complex for the C level compute-cpl) */
- SCM_SLOT (c, scm_si_cpl)
- = scm_cons2 (c, class, SCM_SLOT (scm_class_input_output_port, scm_si_cpl));
+ SCM_SET_SLOT (c, scm_si_cpl,
+ scm_cons2 (c, class, SCM_SLOT (scm_class_input_output_port, scm_si_cpl)));
}
static void
create_port_classes (void)
{
- int i;
+ long i;
scm_port_class = (SCM *) malloc (3 * 256 * sizeof (SCM));
for (i = 0; i < 3 * 256; ++i)
}
static SCM
-make_struct_class (void *closure, SCM key, SCM data, SCM prev)
+make_struct_class (void *closure SCM_UNUSED, SCM key SCM_UNUSED,
+ SCM data, SCM prev SCM_UNUSED)
{
if (SCM_NFALSEP (SCM_STRUCT_TABLE_NAME (data)))
SCM_SET_STRUCT_TABLE_CLASS (data,
scm_load_goops ()
{
if (!goops_loaded_p)
- scm_resolve_module (scm_read_0str ("(oop goops)"));
+ scm_c_resolve_module ("oop goops");
}
if (destructor != 0)
{
- SCM_SLOT (class, scm_si_destructor) = (SCM) destructor;
+ SCM_SET_SLOT (class, scm_si_destructor, (SCM) destructor);
SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object);
}
else if (size > 0)
SCM_SET_CLASS_INSTANCE_SIZE (class, size);
}
- SCM_SLOT (class, scm_si_layout) = scm_str2symbol ("");
- SCM_SLOT (class, scm_si_constructor) = (SCM) constructor;
+ SCM_SET_SLOT (class, scm_si_layout, scm_str2symbol (""));
+ SCM_SET_SLOT (class, scm_si_constructor, (SCM) constructor);
return class;
}
SCM_KEYWORD (k_getter, "getter");
static SCM
-default_setter (SCM obj, SCM c)
+default_setter (SCM obj SCM_UNUSED, SCM c SCM_UNUSED)
{
scm_misc_error ("slot-set!", "read-only slot", SCM_EOL);
return 0;
char *accessor_name)
{
{
- SCM get = scm_make_subr_opt ("goops:get", scm_tc7_subr_1, getter, 0);
- SCM set = scm_make_subr_opt ("goops:set", scm_tc7_subr_2,
- setter ? setter : default_setter, 0);
+ 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);
SCM getm = scm_closure (SCM_LIST2 (SCM_LIST1 (sym_o),
SCM_LIST2 (get, sym_o)),
SCM_EOL);
k_procedure, setm)));
DEFVAR (aname, gf);
- SCM_SLOT (class, scm_si_slots)
- = scm_append_x (SCM_LIST2 (SCM_SLOT (class, scm_si_slots),
- SCM_LIST1 (slot)));
- SCM_SLOT (class, scm_si_getters_n_setters)
- = scm_append_x (SCM_LIST2 (SCM_SLOT (class, scm_si_getters_n_setters),
- SCM_LIST1 (gns)));
+ SCM_SET_SLOT (class, scm_si_slots,
+ scm_append_x (SCM_LIST2 (SCM_SLOT (class, scm_si_slots),
+ SCM_LIST1 (slot))));
+ SCM_SET_SLOT (class, scm_si_getters_n_setters,
+ scm_append_x (SCM_LIST2 (SCM_SLOT (class, scm_si_getters_n_setters),
+ SCM_LIST1 (gns))));
}
}
{
- int n = SCM_INUM (SCM_SLOT (class, scm_si_nfields));
+ long n = SCM_INUM (SCM_SLOT (class, scm_si_nfields));
- SCM_SLOT (class, scm_si_nfields)
- = SCM_MAKINUM (n + 1);
+ SCM_SET_SLOT (class, scm_si_nfields, SCM_MAKINUM (n + 1));
}
}
#define FUNC_NAME s_scm_sys_goops_loaded
{
goops_loaded_p = 1;
- var_compute_applicable_methods
- = SCM_CDR (scm_apply (scm_goops_lookup_closure,
- SCM_LIST2 (SCM_CAR (var_compute_applicable_methods),
- SCM_BOOL_F),
- SCM_EOL));
+ var_compute_applicable_methods =
+ scm_sym2var (sym_compute_applicable_methods, scm_goops_lookup_closure,
+ SCM_BOOL_F);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM scm_module_goops;
-void
-scm_init_goops (void)
+SCM
+scm_init_goops_builtins (void)
{
- SCM old_module;
- scm_module_goops = scm_make_module (scm_read_0str ("(oop goops)"));
- old_module = scm_set_current_module (scm_module_goops);
-
+ scm_module_goops = scm_current_module ();
scm_goops_lookup_closure = scm_module_lookup_closure (scm_module_goops);
/* Not really necessary right now, but who knows...
name)));
DEFVAR (name, scm_no_applicable_method);
}
-
- scm_set_current_module (old_module);
+
+ return SCM_UNSPECIFIED;
}
void
-scm_init_oop_goops_goopscore_module ()
+scm_init_goops ()
{
- scm_register_module_xxx ("oop goops goopscore", (void *) scm_init_goops);
+ scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
+ scm_init_goops_builtins);
}
/*
HCoop / bpt / guile.git / blobdiff