-/* Copyright (C) 1998,1999,2000,2001, 2002, 2003 Free Software Foundation, Inc.
+/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004
+ * Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
#define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined])
*/
-#define TEST_CHANGE_CLASS(obj, class) \
- { \
- class = SCM_CLASS_OF (obj); \
- if (SCM_OBJ_CLASS_REDEF (obj) != SCM_BOOL_F) \
- scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj)); \
+#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 NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
while (!SCM_NULLP (ls))
{
SCM el = SCM_CAR (ls);
- if (SCM_FALSEP (scm_c_memq (el, res)))
+ if (scm_is_false (scm_c_memq (el, res)))
res = scm_cons (el, res);
ls = SCM_CDR (ls);
}
if (!SCM_SYMBOLP (tmp))
scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp));
- if (SCM_FALSEP (scm_c_memq (tmp, slots_already_seen))) {
+ if (scm_is_false (scm_c_memq (tmp, slots_already_seen))) {
res = scm_cons (SCM_CAR (l), res);
slots_already_seen = scm_cons (tmp, slots_already_seen);
}
{
init = scm_get_keyword (k_init_value, options, 0);
if (init)
- init = scm_closure (scm_list_2 (SCM_EOL,
- scm_list_2 (scm_sym_quote, init)),
- SCM_EOL);
+ {
+ init = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
+ SCM_EOL,
+ scm_list_2 (scm_sym_quote,
+ init)),
+ SCM_EOL);
+ }
else
init = scm_get_keyword (k_init_thunk, options, SCM_BOOL_F);
}
*cdrloc = scm_cons (scm_cons (SCM_CAAR (slots),
scm_cons (init,
- SCM_MAKINUM (i++))),
+ SCM_I_MAKINUM (i++))),
SCM_EOL);
cdrloc = SCM_CDRLOC (*cdrloc);
}
{
/* set slot to its :init-form if it exists */
tmp = SCM_CADAR (get_n_set);
- if (tmp != SCM_BOOL_F)
+ if (scm_is_true (tmp))
{
slot_value = get_slot_value (class, obj, SCM_CAR (get_n_set));
if (SCM_GOOPS_UNBOUNDP (slot_value))
type = scm_i_get_keyword (k_class, SCM_CDAR (slots),
len, SCM_BOOL_F, FUNC_NAME);
/* determine slot GC protection and access mode */
- if (SCM_FALSEP (type))
+ if (scm_is_false (type))
{
p = 'p';
a = 'w';
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));
+ nfields = SCM_I_MAKINUM (scm_ilength (slots));
g_n_s = compute_getters_n_setters (slots);
SCM_SET_SLOT (z, scm_si_name, name);
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_nfields, SCM_I_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);
"Return @code{#t} if @var{obj} is an instance.")
#define FUNC_NAME s_scm_instance_p
{
- return SCM_BOOL (SCM_INSTANCEP (obj));
+ return scm_from_bool (SCM_INSTANCEP (obj));
}
#undef FUNC_NAME
unsigned long int i;
SCM_VALIDATE_INSTANCE (1, obj);
- SCM_VALIDATE_INUM (2, index);
- SCM_ASSERT_RANGE (2, index, SCM_INUM (index) >= 0);
- i = SCM_INUM (index);
- SCM_ASSERT_RANGE (2, index, i < SCM_NUMBER_OF_SLOTS (obj));
-
+ i = scm_to_unsigned_integer (index, 0, SCM_NUMBER_OF_SLOTS(obj)-1);
return SCM_SLOT (obj, i);
}
#undef FUNC_NAME
unsigned long int i;
SCM_VALIDATE_INSTANCE (1, obj);
- SCM_VALIDATE_INUM (2, index);
- SCM_ASSERT_RANGE (2, index, SCM_INUM (index) >= 0);
- i = SCM_INUM (index);
- SCM_ASSERT_RANGE (2, index, i < SCM_NUMBER_OF_SLOTS (obj));
+ i = scm_to_unsigned_integer (index, 0, SCM_NUMBER_OF_SLOTS(obj)-1);
SCM_SET_SLOT (obj, i, value);
#undef FUNC_NAME
+SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_i_makbimacro, scm_m_atslot_ref);
+SCM_SYNTAX (s_atslot_set_x, "@slot-set!", scm_i_makbimacro, scm_m_atslot_set_x);
+
+
/** Utilities **/
/* In the future, this function will return the effective slot
get_slot_value_using_name (SCM class, SCM obj, SCM slot_name)
{
SCM slotdef = slot_definition_using_name (class, slot_name);
- if (!SCM_FALSEP (slotdef))
+ if (scm_is_true (slotdef))
return get_slot_value (class, obj, slotdef);
else
return CALL_GF3 ("slot-missing", class, obj, slot_name);
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_FALSEP (slotdef))
+ if (scm_is_true (slotdef))
return set_slot_value (class, obj, slotdef, value);
else
return CALL_GF4 ("slot-missing", class, obj, slot_name, value);
SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
+
SCM
scm_make_method_cache (SCM gf)
{
return scm_list_5 (SCM_IM_DISPATCH,
scm_sym_args,
- SCM_MAKINUM (1),
+ SCM_I_MAKINUM (1),
scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE,
list_of_no_method),
gf);
SCM used_by;
SCM_ASSERT (SCM_PUREGENERICP (gf), gf, SCM_ARG1, FUNC_NAME);
used_by = SCM_SLOT (gf, scm_si_used_by);
- if (!SCM_FALSEP (used_by))
+ if (scm_is_true (used_by))
{
SCM methods = SCM_SLOT (gf, scm_si_methods);
for (; SCM_CONSP (used_by); used_by = SCM_CDR (used_by))
"")
#define FUNC_NAME s_scm_generic_capability_p
{
- SCM_ASSERT (!SCM_FALSEP (scm_procedure_p (proc)),
+ SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
proc, SCM_ARG1, FUNC_NAME);
return (scm_subr_p (proc) && SCM_SUBR_GENERIC (proc)
? SCM_BOOL_T
applicablep (SCM actual, SCM formal)
{
/* We already know that the cpl is well formed. */
- return !SCM_FALSEP (scm_c_memq (formal, SCM_SLOT (actual, scm_si_cpl)));
+ return scm_is_true (scm_c_memq (formal, SCM_SLOT (actual, scm_si_cpl)));
}
static int
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_UNUSED)
-#define FUNC_NAME s_atslot_ref
-{
- SCM x = SCM_CDR (xorig);
- SCM_ASSYNT (scm_ilength (x) == 2, scm_s_expression, FUNC_NAME);
- SCM_VALIDATE_INUM (SCM_ARG2, SCM_CADR (x));
- return scm_cons (SCM_IM_SLOT_REF, x);
-}
-#undef FUNC_NAME
-
-
-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_UNUSED)
-#define FUNC_NAME s_atslot_set_x
-{
- SCM x = SCM_CDR (xorig);
- SCM_ASSYNT (scm_ilength (x) == 3, scm_s_expression, FUNC_NAME);
- SCM_VALIDATE_INUM (SCM_ARG2, SCM_CADR (x));
- return scm_cons (SCM_IM_SLOT_SET_X, x);
-}
-#undef FUNC_NAME
-
-
-SCM_SYNTAX (s_atdispatch, "@dispatch", scm_makmmacro, scm_m_atdispatch);
-
-SCM_SYMBOL (sym_atdispatch, s_atdispatch);
-
-SCM
-scm_m_atdispatch (SCM xorig, SCM env)
-#define FUNC_NAME s_atdispatch
-{
- SCM args, n, v, gf, x = SCM_CDR (xorig);
- SCM_ASSYNT (scm_ilength (x) == 4, scm_s_expression, FUNC_NAME);
- args = SCM_CAR (x);
- if (!SCM_CONSP (args) && !SCM_SYMBOLP (args))
- SCM_WRONG_TYPE_ARG (SCM_ARG1, args);
- x = SCM_CDR (x);
- n = SCM_XEVALCAR (x, env);
- SCM_VALIDATE_INUM (SCM_ARG2, n);
- SCM_ASSERT_RANGE (0, n, SCM_INUM (n) >= 1);
- x = SCM_CDR (x);
- v = SCM_XEVALCAR (x, env);
- SCM_VALIDATE_VECTOR (SCM_ARG3, v);
- x = SCM_CDR (x);
- gf = SCM_XEVALCAR (x, env);
- SCM_VALIDATE_PUREGENERIC (SCM_ARG4, gf);
- return scm_list_5 (SCM_IM_DISPATCH, args, n, v, gf);
-}
-#undef FUNC_NAME
-
-
static void
lock_cache_mutex (void *m)
{
* the cache miss and locking the mutex.
*/
SCM cmethod = scm_mcache_lookup_cmethod (x, SCM_CDDR (args));
- if (!SCM_FALSEP (cmethod))
+ if (scm_is_true (cmethod))
return cmethod;
/*fixme* Use scm_apply */
return CALL_GF3 ("memoize-method!", gf, SCM_CDDR (args), x);
if (class == scm_class_accessor)
{
SCM setter = scm_get_keyword (k_setter, args, SCM_BOOL_F);
- if (!SCM_FALSEP (setter))
+ if (scm_is_true (setter))
scm_sys_set_object_setter_x (z, setter);
}
}
SCM cpl = SCM_SLOT (c, scm_si_cpl);
SCM ls = scm_c_memq (after, cpl);
SCM tail = scm_delq1_x (before, SCM_CDR (ls));
- if (SCM_FALSEP (ls))
+ if (scm_is_false (ls))
/* if this condition occurs, fix_cpl should not be applied this way */
abort ();
SCM_SETCAR (ls, before);
k_init_keyword,
k_slot_definition));
SCM mutex_slot = scm_list_1 (scm_str2symbol ("make-mutex"));
+ SCM mutex_closure = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
+ SCM_EOL,
+ mutex_slot),
+ SCM_EOL);
SCM gf_slots = scm_list_5 (scm_str2symbol ("methods"),
scm_list_3 (scm_str2symbol ("n-specialized"),
k_init_value,
SCM_BOOL_F),
scm_list_3 (scm_str2symbol ("cache-mutex"),
k_init_thunk,
- scm_closure (scm_list_2 (SCM_EOL,
- mutex_slot),
- SCM_EOL)),
+ mutex_closure),
scm_list_3 (scm_str2symbol ("extended-by"),
k_init_value,
SCM_EOL));
scm_class_class, scm_class_complex, SCM_EOL);
make_stdcls (&scm_class_integer, "<integer>",
scm_class_class, scm_class_real, SCM_EOL);
+ make_stdcls (&scm_class_fraction, "<fraction>",
+ scm_class_class, scm_class_real, SCM_EOL);
make_stdcls (&scm_class_keyword, "<keyword>",
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_unknown, "<unknown>",
**********************************************************************/
static SCM
-make_class_from_template (char *template, char *type_name, SCM supers, int applicablep)
+make_class_from_template (char const *template, char const *type_name, SCM supers, int applicablep)
{
SCM class, name;
if (type_name)
/* Only define name if doesn't already exist. */
if (!SCM_GOOPS_UNBOUNDP (name)
- && SCM_FALSEP (scm_call_2 (scm_goops_lookup_closure, name, SCM_BOOL_F)))
+ && scm_is_false (scm_call_2 (scm_goops_lookup_closure, name, SCM_BOOL_F)))
DEFVAR (name, class);
return class;
}
SCM
-scm_make_extended_class (char *type_name, int applicablep)
+scm_make_extended_class (char const *type_name, int applicablep)
{
return make_class_from_template ("<%s>",
type_name,
SCM cpl = SCM_SLOT (c, scm_si_cpl);
/* patch scm_class_applicable into direct-supers */
SCM top = scm_c_memq (scm_class_top, dsupers);
- if (SCM_FALSEP (top))
+ if (scm_is_false (top))
dsupers = scm_append (scm_list_2 (dsupers,
scm_list_1 (scm_class_applicable)));
else
SCM_SET_SLOT (c, scm_si_direct_supers, dsupers);
/* patch scm_class_applicable into cpl */
top = scm_c_memq (scm_class_top, cpl);
- if (SCM_FALSEP (top))
+ if (scm_is_false (top))
abort ();
else
{
for (i = 0; i < 255; ++i)
scm_smob_class[i] = 0;
- scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_big)] = scm_class_integer;
- scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_real)] = scm_class_real;
- scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_complex)] = scm_class_complex;
scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_keyword)] = scm_class_keyword;
for (i = 0; i < scm_numsmob; ++i)
make_struct_class (void *closure SCM_UNUSED,
SCM vtable, SCM data, SCM prev SCM_UNUSED)
{
- if (!SCM_FALSEP (SCM_STRUCT_TABLE_NAME (data)))
+ if (scm_is_true (SCM_STRUCT_TABLE_NAME (data)))
SCM_SET_STRUCT_TABLE_CLASS (data,
scm_make_extended_class
(SCM_SYMBOL_CHARS (SCM_STRUCT_TABLE_NAME (data)),
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_list_2 (scm_list_1 (sym_o),
- scm_list_2 (get, sym_o)),
- SCM_EOL);
- SCM setm = scm_closure (scm_list_2 (scm_list_2 (sym_o, sym_x),
- scm_list_3 (set, sym_o, sym_x)),
- SCM_EOL);
+
+ /* Dirk:FIXME:: The following two expressions make use of the fact that
+ * the memoizer will accept a subr-object in the place of a function.
+ * This is not guaranteed to stay this way. */
+ SCM getm = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
+ scm_list_1 (sym_o),
+ scm_list_2 (get, sym_o)),
+ SCM_EOL);
+ SCM setm = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
+ scm_list_2 (sym_o, sym_x),
+ scm_list_3 (set, sym_o, sym_x)),
+ SCM_EOL);
+
{
SCM name = scm_str2symbol (slot_name);
SCM aname = scm_str2symbol (accessor_name);
scm_list_1 (slot))));
{
SCM n = SCM_SLOT (class, scm_si_nfields);
- SCM gns = scm_list_n (name, SCM_BOOL_F, get, set, n, SCM_MAKINUM (1));
+ SCM gns = scm_list_n (name, SCM_BOOL_F, get, set, n, SCM_I_MAKINUM (1));
SCM_SET_SLOT (class, scm_si_getters_n_setters,
scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters),
scm_list_1 (gns))));
- SCM_SET_SLOT (class, scm_si_nfields, SCM_MAKINUM (SCM_INUM (n) + 1));
+ SCM_SET_SLOT (class, scm_si_nfields, SCM_I_MAKINUM (SCM_INUM (n) + 1));
}
}
}
"Return @code{#t} if @var{obj} is a pure generic.")
#define FUNC_NAME s_scm_pure_generic_p
{
- return SCM_BOOL (SCM_PUREGENERICP (obj));
+ return scm_from_bool (SCM_PUREGENERICP (obj));
}
#undef FUNC_NAME
scm_permanent_object (scm_goops_lookup_closure);
scm_components = scm_permanent_object (scm_make_weak_key_hash_table
- (SCM_MAKINUM (37)));
+ (SCM_I_MAKINUM (37)));
goops_rstate = scm_c_make_rstate ("GOOPS", 5);
HCoop / bpt / guile.git / blobdiff