#include "libguile/validate.h"
#include "libguile/goops.h"
-#define CLASSP(x) (SCM_STRUCTP (x) \
- && SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_METACLASS)
-#define GENERICP(x) (SCM_INSTANCEP (x) \
- && SCM_SUBCLASSP (SCM_CLASS_OF (x), scm_class_generic))
-#define METHODP(x) (SCM_INSTANCEP (x) \
- && SCM_SUBCLASSP(SCM_CLASS_OF(x), scm_class_method))
#define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
-
#define DEFVAR(v,val) \
{ scm_i_eval (SCM_LIST3 (scm_sym_define_public, (v), (val)), \
scm_top_level_env (scm_goops_lookup_closure)); }
#define GETVAR(v) (SCM_CDDR (scm_apply (scm_goops_lookup_closure, \
SCM_LIST2 ((v), SCM_BOOL_F), \
SCM_EOL)))
-static SCM
-Intern (const char *s)
-{
- return SCM_CAR (scm_intern (s, strlen (s)));
-}
/* Fixme: Should use already interned symbols */
-#define CALL_GF1(name,a) (scm_apply (GETVAR (Intern(name)), \
+#define CALL_GF1(name,a) (scm_apply (GETVAR (scm_str2symbol (name)), \
SCM_LIST1 (a), SCM_EOL))
-#define CALL_GF2(name,a,b) (scm_apply (GETVAR (Intern(name)), \
+#define CALL_GF2(name,a,b) (scm_apply (GETVAR (scm_str2symbol (name)), \
SCM_LIST2 (a, b), SCM_EOL))
-#define CALL_GF3(name,a,b,c) (scm_apply (GETVAR (Intern(name)), \
+#define CALL_GF3(name,a,b,c) (scm_apply (GETVAR (scm_str2symbol (name)), \
SCM_LIST3 (a, b, c), SCM_EOL))
-#define CALL_GF4(name,a,b,c,d) (scm_apply (GETVAR (Intern(name)), \
+#define CALL_GF4(name,a,b,c,d) (scm_apply (GETVAR (scm_str2symbol (name)), \
SCM_LIST4 (a, b, c, d), SCM_EOL))
/* Class redefinition protocol:
static SCM scm_make_unbound (void);
static SCM scm_unbound_p (SCM obj);
+static SCM scm_assert_bound (SCM value, SCM obj);
+static SCM scm_at_assert_bound_ref (SCM obj, SCM index);
+static SCM scm_sys_goops_loaded (void);
/******************************************************************************
*
while (SCM_NIMP (ls))
{
SCM el = SCM_CAR (ls);
- if (SCM_IMP (scm_memq (el, res)))
+ if (SCM_FALSEP (scm_c_memq (el, res)))
res = scm_cons (el, res);
ls = SCM_CDR (ls);
}
return res;
tmp = SCM_CAAR (l);
- if (!(SCM_NIMP (tmp) && SCM_SYMBOLP (tmp)))
- scm_misc_error ("%compute-slots",
- "bad slot name ~S",
- SCM_LIST1 (tmp));
+ if (!SCM_SYMBOLP (tmp))
+ scm_misc_error ("%compute-slots", "bad slot name ~S", SCM_LIST1 (tmp));
- if (SCM_NULLP (scm_memq (tmp, slots_already_seen))) {
+ if (SCM_FALSEP (scm_c_memq (tmp, slots_already_seen))) {
res = scm_cons (SCM_CAR (l), res);
slots_already_seen = scm_cons (tmp, slots_already_seen);
}
SCM orig = ls;
while (SCM_NIMP (ls))
{
- if (!(SCM_NIMP (SCM_CAR (ls)) && SCM_CONSP (SCM_CAR (ls))))
+ if (!SCM_CONSP (SCM_CAR (ls)))
SCM_SETCAR (ls, scm_cons (SCM_CAR (ls), SCM_EOL));
ls = SCM_CDR (ls);
}
return orig;
}
-SCM_PROC (s_sys_compute_slots, "%compute-slots", 1, 0, 0, scm_sys_compute_slots);
-SCM
-scm_sys_compute_slots (SCM class)
+SCM_DEFINE (scm_sys_compute_slots, "%compute-slots", 1, 0, 0,
+ (SCM class),
+ "Return a list consisting of the names of all slots belonging\n"
+ "to class CLASS, i. e. the slots of CLASS and of all of its\n"
+ "superclasses.")
+#define FUNC_NAME s_scm_sys_compute_slots
{
- SCM_ASSERT (SCM_NIMP (class) && CLASSP (class),
- class, SCM_ARG1, s_sys_compute_slots);
+ SCM_VALIDATE_CLASS (1, class);
return build_slots_list (SCM_SLOT (class, scm_si_direct_slots),
SCM_SLOT (class, scm_si_cpl));
}
+#undef FUNC_NAME
+
/******************************************************************************
*
SCM
scm_i_get_keyword (SCM key, SCM l, int len, SCM default_value, const char *subr)
{
- int i;
- for (i = 0; i < len; i += 2)
+ unsigned int i;
+
+ for (i = 0; i != len; i += 2)
{
- if (!(SCM_NIMP (SCM_CAR (l)) && SCM_KEYWORDP (SCM_CAR (l))))
- scm_misc_error (subr,
- "bad keyword: ~S",
- SCM_LIST1 (SCM_CAR (l)));
- if (SCM_CAR (l) == key)
+ SCM obj = SCM_CAR (l);
+
+ if (!SCM_KEYWORDP (obj))
+ scm_misc_error (subr, "bad keyword: ~S", SCM_LIST1 (obj));
+ else if (SCM_EQ_P (obj, key))
return SCM_CADR (l);
- l = SCM_CDDR (l);
+ else
+ l = SCM_CDDR (l);
}
+
return default_value;
}
-SCM_PROC (s_get_keyword, "get-keyword", 3, 0, 0, scm_get_keyword);
-SCM
-scm_get_keyword (SCM key, SCM l, SCM 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 KEY from the\n"
+ "list L. The list L has to consist of an even number of\n"
+ "elements, where, starting with the first, every second element\n"
+ "is a keyword, followed by its associated value. If L does not\n"
+ "hold a value for KEY, the value DEFAULT_VALUE is returned.")
+#define FUNC_NAME s_scm_get_keyword
{
int len;
- SCM_ASSERT (SCM_NIMP (key) && SCM_KEYWORDP (key),
- key,
- "Bad keyword: ~S",
- s_get_keyword);
+
+ SCM_ASSERT (SCM_KEYWORDP (key), key, SCM_ARG1, FUNC_NAME);
len = scm_ilength (l);
- SCM_ASSERT (len >= 0 && (len & 1) == 0, l,
- "Bad keyword-value list: ~S",
- s_get_keyword);
- return scm_i_get_keyword (key, l, len, default_value, s_get_keyword);
+ if (len < 0 || len % 1 == 1)
+ scm_misc_error (FUNC_NAME, "Bad keyword-value list: ~S", SCM_LIST1 (l));
+
+ return scm_i_get_keyword (key, l, len, default_value, FUNC_NAME);
}
+#undef FUNC_NAME
-SCM_PROC (s_sys_initialize_object, "%initialize-object", 2, 0, 0, scm_sys_initialize_object);
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
-scm_sys_initialize_object (SCM obj, SCM initargs)
+SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
+ (SCM obj, SCM initargs),
+ "")
+#define FUNC_NAME s_scm_sys_initialize_object
{
SCM tmp, get_n_set, slots;
SCM class = SCM_CLASS_OF (obj);
int n_initargs;
- SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj),
- obj, SCM_ARG1, s_sys_initialize_object);
+ SCM_VALIDATE_INSTANCE (1, obj);
n_initargs = scm_ilength (initargs);
- SCM_ASSERT ((n_initargs & 1) == 0,
- initargs, SCM_ARG2, s_sys_initialize_object);
+ 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);
/* This slot admits (perhaps) to be initialized at creation time */
int n = scm_ilength (SCM_CDR (slot_name));
if (n & 1) /* odd or -1 */
- scm_misc_error (s_sys_initialize_object,
- "class contains bogus slot definition: ~S",
+ SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
SCM_LIST1 (slot_name));
tmp = scm_i_get_keyword (k_init_keyword,
SCM_CDR (slot_name),
n,
0,
- s_sys_initialize_object);
+ FUNC_NAME);
slot_name = SCM_CAR (slot_name);
if (tmp)
{
/* an initarg was provided for this slot */
- if (!(SCM_NIMP (tmp) && SCM_KEYWORDP (tmp)))
- scm_misc_error (s_sys_initialize_object,
- "initarg must be a keyword. It was ~S",
+ if (!SCM_KEYWORDP (tmp))
+ SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
SCM_LIST1 (tmp));
slot_value = scm_i_get_keyword (tmp,
initargs,
n_initargs,
0,
- s_sys_initialize_object);
+ FUNC_NAME);
}
}
return obj;
}
+#undef FUNC_NAME
SCM_KEYWORD (k_class, "class");
-SCM_PROC (s_sys_prep_layout_x, "%prep-layout!", 1, 0, 0, scm_sys_prep_layout_x);
-
-SCM
-scm_sys_prep_layout_x (SCM class)
+SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0,
+ (SCM class),
+ "")
+#define FUNC_NAME s_scm_sys_prep_layout_x
{
int i, n, len;
char *s, p, a;
SCM nfields, slots, type;
- SCM_ASSERT (SCM_NIMP (class) && SCM_INSTANCEP (class),
- class,
- SCM_ARG1,
- s_sys_prep_layout_x);
+ SCM_VALIDATE_INSTANCE (1, class);
slots = SCM_SLOT (class, scm_si_slots);
nfields = SCM_SLOT (class, scm_si_nfields);
if (!SCM_INUMP (nfields) || SCM_INUM (nfields) < 0)
- scm_misc_error (s_sys_prep_layout_x,
- "bad value in nfields slot: ~S",
+ SCM_MISC_ERROR ("bad value in nfields slot: ~S",
SCM_LIST1 (nfields));
n = 2 * SCM_INUM (nfields);
if (n < sizeof (SCM_CLASS_CLASS_LAYOUT) - 1
&& SCM_SUBCLASSP (class, scm_class_class))
- scm_misc_error (s_sys_prep_layout_x,
- "class object doesn't have enough fields: ~S",
+ SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
SCM_LIST1 (nfields));
- s = n > 0 ? scm_must_malloc (n, s_sys_prep_layout_x) : 0;
+ s = n > 0 ? scm_must_malloc (n, FUNC_NAME) : 0;
for (i = 0; i < n; i += 2)
{
- if (!(SCM_NIMP (slots) && SCM_CONSP (slots)))
- scm_misc_error (s_sys_prep_layout_x,
- "to few slot definitions",
- SCM_EOL);
+ if (!SCM_CONSP (slots))
+ SCM_MISC_ERROR ("to few slot definitions", SCM_EOL);
len = scm_ilength (SCM_CDAR (slots));
type = scm_i_get_keyword (k_class, SCM_CDAR (slots), len, SCM_BOOL_F,
- s_sys_prep_layout_x);
+ FUNC_NAME);
if (SCM_NIMP (type) && SCM_SUBCLASSP (type, scm_class_foreign_slot))
{
if (SCM_SUBCLASSP (type, scm_class_self))
s[i + 1] = a;
slots = SCM_CDR (slots);
}
- SCM_SLOT (class, scm_si_layout) = SCM_CAR (scm_intern (s, n));
+ SCM_SLOT (class, scm_si_layout) = scm_mem2symbol (s, n);
if (s)
scm_must_free (s);
return SCM_UNSPECIFIED;
}
+#undef FUNC_NAME
static void prep_hashsets (SCM);
-SCM_PROC (s_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0, scm_sys_inherit_magic_x);
-
-SCM
-scm_sys_inherit_magic_x (SCM class, SCM dsupers)
+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 ls = dsupers;
long flags = 0;
- SCM_ASSERT (SCM_NIMP (class) && SCM_INSTANCEP (class),
- class,
- SCM_ARG1,
- s_sys_inherit_magic_x);
+ SCM_VALIDATE_INSTANCE (1, class);
while (SCM_NNULLP (ls))
{
- SCM_ASSERT (SCM_NIMP (ls)
- && SCM_CONSP (ls)
- && SCM_NIMP (SCM_CAR (ls))
+ SCM_ASSERT (SCM_CONSP (ls)
&& SCM_INSTANCEP (SCM_CAR (ls)),
dsupers,
SCM_ARG2,
- s_sys_inherit_magic_x);
+ FUNC_NAME);
flags |= SCM_CLASS_FLAGS (SCM_CAR (ls));
ls = SCM_CDR (ls);
}
return SCM_UNSPECIFIED;
}
+#undef FUNC_NAME
void
prep_hashsets (SCM class)
build_class_class_slots ()
{
return maplist (
- scm_cons (SCM_LIST3 (Intern ("layout"),
+ scm_cons (SCM_LIST3 (scm_str2symbol ("layout"),
k_class,
scm_class_protected_read_only),
- scm_cons (SCM_LIST3 (Intern ("vcell"),
+ scm_cons (SCM_LIST3 (scm_str2symbol ("vcell"),
k_class,
scm_class_opaque),
- scm_cons (SCM_LIST3 (Intern ("vtable"),
+ scm_cons (SCM_LIST3 (scm_str2symbol ("vtable"),
k_class,
scm_class_self),
- scm_cons (Intern ("print"),
- scm_cons (SCM_LIST3 (Intern ("procedure"),
+ scm_cons (scm_str2symbol ("print"),
+ scm_cons (SCM_LIST3 (scm_str2symbol ("procedure"),
k_class,
scm_class_protected_opaque),
- scm_cons (SCM_LIST3 (Intern ("setter"),
+ scm_cons (SCM_LIST3 (scm_str2symbol ("setter"),
k_class,
scm_class_protected_opaque),
- scm_cons (Intern ("redefined"),
- scm_cons (SCM_LIST3 (Intern ("h0"),
+ scm_cons (scm_str2symbol ("redefined"),
+ scm_cons (SCM_LIST3 (scm_str2symbol ("h0"),
k_class,
scm_class_int),
- scm_cons (SCM_LIST3 (Intern ("h1"),
+ scm_cons (SCM_LIST3 (scm_str2symbol ("h1"),
k_class,
scm_class_int),
- scm_cons (SCM_LIST3 (Intern ("h2"),
+ scm_cons (SCM_LIST3 (scm_str2symbol ("h2"),
k_class,
scm_class_int),
- scm_cons (SCM_LIST3 (Intern ("h3"),
+ scm_cons (SCM_LIST3 (scm_str2symbol ("h3"),
k_class,
scm_class_int),
- scm_cons (SCM_LIST3 (Intern ("h4"),
+ scm_cons (SCM_LIST3 (scm_str2symbol ("h4"),
k_class,
scm_class_int),
- scm_cons (SCM_LIST3 (Intern ("h5"),
+ scm_cons (SCM_LIST3 (scm_str2symbol ("h5"),
k_class,
scm_class_int),
- scm_cons (SCM_LIST3 (Intern ("h6"),
+ scm_cons (SCM_LIST3 (scm_str2symbol ("h6"),
k_class,
scm_class_int),
- scm_cons (SCM_LIST3 (Intern ("h7"),
+ scm_cons (SCM_LIST3 (scm_str2symbol ("h7"),
k_class,
scm_class_int),
- scm_cons (Intern ("name"),
- scm_cons (Intern ("direct-supers"),
- scm_cons (Intern ("direct-slots"),
- scm_cons (Intern ("direct-subclasses"),
- scm_cons (Intern ("direct-methods"),
- scm_cons (Intern ("cpl"),
- scm_cons (Intern ("default-slot-definition-class"),
- scm_cons (Intern ("slots"),
- scm_cons (Intern ("getters-n-setters"), /* name-access */
- scm_cons (Intern ("keyword-access"),
- scm_cons (Intern ("nfields"),
- scm_cons (Intern ("environment"),
+ scm_cons (scm_str2symbol ("name"),
+ scm_cons (scm_str2symbol ("direct-supers"),
+ scm_cons (scm_str2symbol ("direct-slots"),
+ scm_cons (scm_str2symbol ("direct-subclasses"),
+ scm_cons (scm_str2symbol ("direct-methods"),
+ scm_cons (scm_str2symbol ("cpl"),
+ scm_cons (scm_str2symbol ("default-slot-definition-class"),
+ scm_cons (scm_str2symbol ("slots"),
+ scm_cons (scm_str2symbol ("getters-n-setters"), /* name-access */
+ scm_cons (scm_str2symbol ("keyword-access"),
+ scm_cons (scm_str2symbol ("nfields"),
+ scm_cons (scm_str2symbol ("environment"),
SCM_EOL))))))))))))))))))))))))))));
}
/**** <scm_class_class> ****/
SCM cs = scm_makfrom0str (SCM_CLASS_CLASS_LAYOUT
+ 2 * scm_vtable_offset_user);
- SCM name = Intern ("<class>");
+ SCM name = scm_str2symbol ("<class>");
scm_class_class = scm_permanent_object (scm_make_vtable_vtable (cs,
SCM_INUM0,
SCM_EOL));
DEFVAR(name, scm_class_class);
/**** <scm_class_top> ****/
- name = Intern ("<top>");
+ name = scm_str2symbol ("<top>");
scm_class_top = scm_permanent_object (scm_basic_make_class (scm_class_class,
name,
SCM_EOL,
DEFVAR(name, scm_class_top);
/**** <scm_class_object> ****/
- name = Intern("<object>");
+ name = scm_str2symbol ("<object>");
scm_class_object = scm_permanent_object (scm_basic_make_class (scm_class_class,
name,
SCM_LIST1 (scm_class_top),
/******************************************************************************/
-SCM_PROC (s_instance_p, "instance?", 1, 0, 0, scm_instance_p);
-
-SCM
-scm_instance_p (SCM obj)
+SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_instance_p
{
- return SCM_NIMP (obj) && SCM_INSTANCEP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
+ return SCM_BOOL (SCM_INSTANCEP (obj));
}
+#undef FUNC_NAME
-SCM_PROC (s_class_of, "class-of", 1, 0, 0, scm_class_of);
-/* scm_class_of is defined in libguile */
/******************************************************************************
*
* Meta object accessors
*
******************************************************************************/
-SCM_PROC (s_class_name, "class-name", 1, 0, 0, scm_class_name);
-
-SCM
-scm_class_name (SCM obj)
+SCM_DEFINE (scm_class_name, "class-name", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_class_name
{
- SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), obj, SCM_ARG1, s_class_name);
- return scm_slot_ref (obj, Intern ("name"));
+ SCM_VALIDATE_CLASS (1, obj);
+ return scm_slot_ref (obj, scm_str2symbol ("name"));
}
+#undef FUNC_NAME
-SCM_PROC (s_class_direct_supers, "class-direct-supers", 1, 0, 0, scm_class_direct_supers);
-
-SCM
-scm_class_direct_supers (SCM obj)
+SCM_DEFINE (scm_class_direct_supers, "class-direct-supers", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_class_direct_supers
{
- SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), obj, SCM_ARG1, s_class_direct_supers);
- return scm_slot_ref (obj, Intern("direct-supers"));
+ SCM_VALIDATE_CLASS (1, obj);
+ return scm_slot_ref (obj, scm_str2symbol ("direct-supers"));
}
+#undef FUNC_NAME
-SCM_PROC (s_class_direct_slots, "class-direct-slots", 1, 0, 0, scm_class_direct_slots);
-
-SCM
-scm_class_direct_slots (SCM obj)
+SCM_DEFINE (scm_class_direct_slots, "class-direct-slots", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_class_direct_slots
{
- SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj),
- obj, SCM_ARG1, s_class_direct_slots);
- return scm_slot_ref (obj, Intern ("direct-slots"));
+ SCM_VALIDATE_CLASS (1, obj);
+ return scm_slot_ref (obj, scm_str2symbol ("direct-slots"));
}
+#undef FUNC_NAME
-SCM_PROC (s_class_direct_subclasses, "class-direct-subclasses", 1, 0, 0, scm_class_direct_subclasses);
-
-SCM
-scm_class_direct_subclasses (SCM obj)
+SCM_DEFINE (scm_class_direct_subclasses, "class-direct-subclasses", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_class_direct_subclasses
{
- SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj),
- obj, SCM_ARG1, s_class_direct_subclasses);
- return scm_slot_ref(obj, Intern ("direct-subclasses"));
+ SCM_VALIDATE_CLASS (1, obj);
+ return scm_slot_ref(obj, scm_str2symbol ("direct-subclasses"));
}
+#undef FUNC_NAME
-SCM_PROC (s_class_direct_methods, "class-direct-methods", 1, 0, 0, scm_class_direct_methods);
-
-SCM
-scm_class_direct_methods (SCM obj)
+SCM_DEFINE (scm_class_direct_methods, "class-direct-methods", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_class_direct_methods
{
- SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj),
- obj, SCM_ARG1, s_class_direct_methods);
- return scm_slot_ref (obj, Intern("direct-methods"));
+ SCM_VALIDATE_CLASS (1, obj);
+ return scm_slot_ref (obj, scm_str2symbol ("direct-methods"));
}
+#undef FUNC_NAME
-SCM_PROC (s_class_direct_precedence_list, "class-precedence-list", 1, 0, 0, scm_class_precedence_list);
-
-SCM
-scm_class_precedence_list (SCM obj)
+SCM_DEFINE (scm_class_precedence_list, "class-precedence-list", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_class_precedence_list
{
- SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj),
- obj, SCM_ARG1, s_class_direct_precedence_list);
- return scm_slot_ref (obj, Intern ("cpl"));
+ SCM_VALIDATE_CLASS (1, obj);
+ return scm_slot_ref (obj, scm_str2symbol ("cpl"));
}
+#undef FUNC_NAME
-SCM_PROC (s_class_slots, "class-slots", 1, 0, 0, scm_class_slots);
-
-SCM
-scm_class_slots (SCM obj)
+SCM_DEFINE (scm_class_slots, "class-slots", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_class_slots
{
- SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj),
- obj, SCM_ARG1, s_class_slots);
- return scm_slot_ref (obj, Intern ("slots"));
+ SCM_VALIDATE_CLASS (1, obj);
+ return scm_slot_ref (obj, scm_str2symbol ("slots"));
}
+#undef FUNC_NAME
-SCM_PROC (s_class_environment, "class-environment", 1, 0, 0, scm_class_environment);
-
-SCM
-scm_class_environment (SCM obj)
+SCM_DEFINE (scm_class_environment, "class-environment", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_class_environment
{
- SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj),
- obj, SCM_ARG1, s_class_environment);
- return scm_slot_ref(obj, Intern ("environment"));
+ SCM_VALIDATE_CLASS (1, obj);
+ return scm_slot_ref(obj, scm_str2symbol ("environment"));
}
+#undef FUNC_NAME
-SCM_PROC (s_generic_function_name, "generic-function-name", 1, 0, 0, scm_generic_function_name);
-
-SCM
-scm_generic_function_name (SCM obj)
+SCM_DEFINE (scm_generic_function_name, "generic-function-name", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_generic_function_name
{
- SCM_ASSERT (SCM_NIMP (obj) && GENERICP (obj),
- obj, SCM_ARG1, s_generic_function_name);
+ SCM_VALIDATE_GENERIC (1, obj);
return scm_procedure_property (obj, scm_sym_name);
}
+#undef FUNC_NAME
-SCM_PROC (s_generic_function_methods, "generic-function-methods", 1, 0, 0, scm_generic_function_methods);
-
-SCM
-scm_generic_function_methods (SCM obj)
+SCM_DEFINE (scm_generic_function_methods, "generic-function-methods", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_generic_function_methods
{
- SCM_ASSERT (SCM_NIMP (obj) && GENERICP (obj),
- obj, SCM_ARG1, s_generic_function_methods);
- return scm_slot_ref (obj, Intern ("methods"));
+ SCM_VALIDATE_GENERIC (1, obj);
+ return scm_slot_ref (obj, scm_str2symbol ("methods"));
}
+#undef FUNC_NAME
-SCM_PROC (s_method_generic_function, "method-generic-function", 1, 0, 0, scm_method_generic_function);
-
-SCM
-scm_method_generic_function (SCM obj)
+SCM_DEFINE (scm_method_generic_function, "method-generic-function", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_method_generic_function
{
- SCM_ASSERT (SCM_NIMP (obj) && METHODP (obj),
- obj, SCM_ARG1, s_method_generic_function);
- return scm_slot_ref (obj, Intern ("generic-function"));
+ SCM_VALIDATE_METHOD (1, obj);
+ return scm_slot_ref (obj, scm_str2symbol ("generic-function"));
}
+#undef FUNC_NAME
-SCM_PROC (s_method_specializers, "method-specializers", 1, 0, 0, scm_method_specializers);
-
-SCM
-scm_method_specializers (SCM obj)
+SCM_DEFINE (scm_method_specializers, "method-specializers", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_method_specializers
{
- SCM_ASSERT (SCM_NIMP (obj) && METHODP (obj),
- obj, SCM_ARG1, s_method_specializers);
- return scm_slot_ref (obj, Intern ("specializers"));
+ SCM_VALIDATE_METHOD (1, obj);
+ return scm_slot_ref (obj, scm_str2symbol ("specializers"));
}
+#undef FUNC_NAME
-SCM_PROC (s_method_procedure, "method-procedure", 1, 0, 0, scm_method_procedure);
-
-SCM
-scm_method_procedure (SCM obj)
+SCM_DEFINE (scm_method_procedure, "method-procedure", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_method_procedure
{
- SCM_ASSERT (SCM_NIMP (obj) && METHODP (obj),
- obj, SCM_ARG1, s_method_procedure);
- return scm_slot_ref (obj, Intern ("procedure"));
+ SCM_VALIDATE_METHOD (1, obj);
+ return scm_slot_ref (obj, scm_str2symbol ("procedure"));
}
+#undef FUNC_NAME
-SCM_PROC (s_accessor_method_slot_definition, "accessor-method-slot-definition", 1, 0, 0, scm_accessor_method_slot_definition);
-
-SCM
-scm_accessor_method_slot_definition (SCM obj)
+SCM_DEFINE (scm_accessor_method_slot_definition, "accessor-method-slot-definition", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_accessor_method_slot_definition
{
- SCM_ASSERT (SCM_NIMP (obj) && SCM_ACCESSORP (obj),
- obj, SCM_ARG1, s_method_procedure);
- return scm_slot_ref (obj, Intern ("slot-definition"));
-}
+ SCM_VALIDATE_ACCESSOR (1, obj);
+ return scm_slot_ref (obj, scm_str2symbol ("slot-definition"));
+}
+#undef FUNC_NAME
/******************************************************************************
*
******************************************************************************/
-SCM_PROC (s_make_unbound, "make-unbound", 0, 0, 0, scm_make_unbound);
-
-static SCM
-scm_make_unbound ()
+SCM_DEFINE (scm_make_unbound, "make-unbound", 0, 0, 0,
+ (),
+ "")
+#define FUNC_NAME s_scm_make_unbound
{
return SCM_GOOPS_UNBOUND;
}
+#undef FUNC_NAME
-SCM_PROC (s_unbound_p, "unbound?", 1, 0, 0, scm_unbound_p);
-
-static SCM
-scm_unbound_p (SCM obj)
+SCM_DEFINE (scm_unbound_p, "unbound?", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_unbound_p
{
return SCM_GOOPS_UNBOUNDP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
}
+#undef FUNC_NAME
-SCM_PROC (s_assert_bound, "assert-bound", 2, 0, 0, scm_assert_bound);
-
-static SCM
-scm_assert_bound (SCM value, SCM obj)
+SCM_DEFINE (scm_assert_bound, "assert-bound", 2, 0, 0,
+ (SCM value, SCM obj),
+ "")
+#define FUNC_NAME s_scm_assert_bound
{
if (SCM_GOOPS_UNBOUNDP (value))
return CALL_GF1 ("slot-unbound", obj);
return value;
}
+#undef FUNC_NAME
-SCM_PROC (s_at_assert_bound_ref, "@assert-bound-ref", 2, 0, 0, scm_at_assert_bound_ref);
-
-static SCM
-scm_at_assert_bound_ref (SCM obj, SCM index)
+SCM_DEFINE (scm_at_assert_bound_ref, "@assert-bound-ref", 2, 0, 0,
+ (SCM obj, SCM index),
+ "")
+#define FUNC_NAME s_scm_at_assert_bound_ref
{
SCM value = SCM_SLOT (obj, SCM_INUM (index));
if (SCM_GOOPS_UNBOUNDP (value))
return CALL_GF1 ("slot-unbound", obj);
return value;
}
+#undef FUNC_NAME
-SCM_PROC (s_sys_fast_slot_ref, "%fast-slot-ref", 2, 0, 0, scm_sys_fast_slot_ref);
-
-SCM
-scm_sys_fast_slot_ref (SCM obj, SCM index)
-#define FUNC_NAME s_sys_fast_slot_ref
+SCM_DEFINE (scm_sys_fast_slot_ref, "%fast-slot-ref", 2, 0, 0,
+ (SCM obj, SCM index),
+ "")
+#define FUNC_NAME s_scm_sys_fast_slot_ref
{
register long i;
- SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj),
- obj, SCM_ARG1, s_sys_fast_slot_ref);
- SCM_ASSERT (SCM_INUMP (index), index, SCM_ARG2, s_sys_fast_slot_ref);
+ SCM_VALIDATE_INSTANCE (1, obj);
+ SCM_VALIDATE_INUM (2, index);
i = SCM_INUM (index);
SCM_ASSERT_RANGE (2, index, i >= 0 && i < SCM_NUMBER_OF_SLOTS (obj));
}
#undef FUNC_NAME
-
-SCM_PROC (s_sys_fast_slot_set_x, "%fast-slot-set!", 3, 0, 0, scm_sys_fast_slot_set_x);
-
-SCM
-scm_sys_fast_slot_set_x (SCM obj, SCM index, SCM value)
-#define FUNC_NAME s_sys_fast_slot_set_x
+SCM_DEFINE (scm_sys_fast_slot_set_x, "%fast-slot-set!", 3, 0, 0,
+ (SCM obj, SCM index, SCM value),
+ "")
+#define FUNC_NAME s_scm_sys_fast_slot_set_x
{
register long i;
- SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj),
- obj, SCM_ARG1, s_sys_fast_slot_set_x);
- SCM_ASSERT (SCM_INUMP (index), index, SCM_ARG2, s_sys_fast_slot_set_x);
+ SCM_VALIDATE_INSTANCE (1, obj);
+ 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;
/* 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
- */
+ */
if (SCM_INUMP (access))
return SCM_SLOT (obj, SCM_INUM (access));
else
/* ======================================== */
-SCM_PROC (s_slot_ref_using_class, "slot-ref-using-class", 3, 0, 0, scm_slot_ref_using_class);
-
-SCM
-scm_slot_ref_using_class (SCM class, SCM obj, SCM slot_name)
+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_ASSERT (SCM_NIMP (class) && CLASSP (class),
- class, SCM_ARG1, s_slot_ref_using_class);
- SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj),
- obj, SCM_ARG1, s_slot_ref_using_class);
- SCM_ASSERT (SCM_NIMP (slot_name) && SCM_SYMBOLP (slot_name),
- obj, SCM_ARG3, s_slot_ref_using_class);
+ 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 CALL_GF3 ("slot-unbound", class, obj, slot_name);
return res;
}
-
-SCM_PROC (s_slot_set_using_class_x, "slot-set-using-class!", 4, 0, 0, scm_slot_set_using_class_x);
+#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);
-SCM
-scm_slot_set_using_class_x (SCM class, SCM obj, SCM slot_name, SCM value)
-{
- SCM_ASSERT (SCM_NIMP (class) && CLASSP (class),
- class, SCM_ARG1, s_slot_set_using_class_x);
- SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj),
- obj, SCM_ARG2, s_slot_set_using_class_x);
- SCM_ASSERT (SCM_NIMP (slot_name) && SCM_SYMBOLP (slot_name),
- obj, SCM_ARG3, s_slot_set_using_class_x);
return set_slot_value_using_name (class, obj, slot_name, value);
}
+#undef FUNC_NAME
-SCM_PROC (s_slot_bound_using_class_p, "slot-bound-using-class?", 3, 0, 0, scm_slot_bound_using_class_p);
-SCM
-scm_slot_bound_using_class_p (SCM class, SCM obj, SCM slot_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_ASSERT (SCM_NIMP (class) && CLASSP (class),
- class, SCM_ARG1, s_slot_bound_using_class_p);
- SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj),
- obj, SCM_ARG2, s_slot_bound_using_class_p);
- SCM_ASSERT (SCM_NIMP (slot_name) && SCM_SYMBOLP (slot_name),
- obj, SCM_ARG3, s_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_PROC (s_slot_exists_using_class_p, "slot-exists-using-class?", 3, 0, 0, scm_slot_exists_using_class_p);
-
-SCM
-scm_slot_exists_using_class_p (SCM class, SCM obj, SCM slot_name)
-{
- SCM_ASSERT (SCM_NIMP (class) && CLASSP (class),
- class, SCM_ARG1, s_slot_exists_using_class_p);
- SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj),
- obj, SCM_ARG2, s_slot_exists_using_class_p);
- SCM_ASSERT (SCM_NIMP (slot_name) && SCM_SYMBOLP (slot_name),
- obj, SCM_ARG3, s_slot_exists_using_class_p);
+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_PROC (s_slot_ref, "slot-ref", 2, 0, 0, scm_slot_ref);
-
-SCM
-scm_slot_ref (SCM obj, SCM slot_name)
+SCM_DEFINE (scm_slot_ref, "slot-ref", 2, 0, 0,
+ (SCM obj, SCM slot_name),
+ "")
+#define FUNC_NAME s_scm_slot_ref
{
SCM res, class;
- SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj),
- obj, SCM_ARG1, s_slot_ref);
+ SCM_VALIDATE_INSTANCE (1, obj);
TEST_CHANGE_CLASS (obj, class);
res = get_slot_value_using_name (class, obj, slot_name);
return CALL_GF3 ("slot-unbound", class, obj, slot_name);
return res;
}
+#undef FUNC_NAME
-SCM_PROC (s_slot_set_x, "slot-set!", 3, 0, 0, scm_slot_set_x);
-
-const char *scm_s_slot_set_x = s_slot_set_x;
-
-SCM
-scm_slot_set_x (SCM obj, SCM slot_name, SCM value)
+SCM_DEFINE (scm_slot_set_x, "slot-set!", 3, 0, 0,
+ (SCM obj, SCM slot_name, SCM value),
+ "")
+#define FUNC_NAME s_scm_slot_set_x
{
SCM class;
- SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj),
- obj, SCM_ARG1, s_slot_set_x);
+ SCM_VALIDATE_INSTANCE (1, obj);
TEST_CHANGE_CLASS(obj, class);
return set_slot_value_using_name (class, obj, slot_name, value);
}
+#undef FUNC_NAME
-SCM_PROC (s_slot_bound_p, "slot-bound?", 2, 0, 0, scm_slot_bound_p);
+const char *scm_s_slot_set_x = s_scm_slot_set_x;
-SCM
-scm_slot_bound_p (SCM obj, SCM slot_name)
+SCM_DEFINE (scm_slot_bound_p, "slot-bound?", 2, 0, 0,
+ (SCM obj, SCM slot_name),
+ "")
+#define FUNC_NAME s_scm_slot_bound_p
{
SCM class;
- SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj),
- obj, SCM_ARG1, s_slot_bound_p);
+ SCM_VALIDATE_INSTANCE (1, obj);
TEST_CHANGE_CLASS(obj, class);
return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
? SCM_BOOL_F
: SCM_BOOL_T);
}
+#undef FUNC_NAME
-SCM_PROC (s_slot_exists_p, "slot-exists?", 2, 0, 0, scm_slots_exists_p);
-
-SCM
-scm_slots_exists_p (SCM obj, SCM slot_name)
+SCM_DEFINE (scm_slots_exists_p, "slot-exists?", 2, 0, 0,
+ (SCM obj, SCM slot_name),
+ "")
+#define FUNC_NAME s_scm_slots_exists_p
{
SCM class;
- SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj),
- obj, SCM_ARG1, s_slot_exists_p);
- SCM_ASSERT (SCM_NIMP (slot_name) && SCM_SYMBOLP (slot_name),
- slot_name, SCM_ARG2, s_slot_exists_p);
+ SCM_VALIDATE_INSTANCE (1, obj);
+ SCM_VALIDATE_SYMBOL (2, slot_name);
TEST_CHANGE_CLASS (obj, class);
return test_slot_existence (class, obj, slot_name);
}
+#undef FUNC_NAME
/******************************************************************************
return z;
}
-SCM_PROC (s_sys_allocate_instance, "%allocate-instance", 2, 0, 0, scm_sys_allocate_instance);
-
-SCM
-scm_sys_allocate_instance (SCM class, SCM initargs)
+SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
+ (SCM class, SCM initargs),
+ "")
+#define FUNC_NAME s_scm_sys_allocate_instance
{
SCM *m;
int n;
- SCM_ASSERT (SCM_NIMP (class) && CLASSP (class),
- class, SCM_ARG1, s_sys_allocate_instance);
+ SCM_VALIDATE_CLASS (1, class);
/* Most instances */
if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT)
return wrap_init (class, m, n);
}
}
+#undef FUNC_NAME
-SCM_PROC (s_sys_set_object_setter_x, "%set-object-setter!", 2, 0, 0, scm_sys_set_object_setter_x);
-
-SCM
-scm_sys_set_object_setter_x (SCM obj, SCM setter)
+SCM_DEFINE (scm_sys_set_object_setter_x, "%set-object-setter!", 2, 0, 0,
+ (SCM obj, SCM setter),
+ "")
+#define FUNC_NAME s_scm_sys_set_object_setter_x
{
- SCM_ASSERT (SCM_NIMP (obj) && SCM_STRUCTP (obj)
+ SCM_ASSERT (SCM_STRUCTP (obj)
&& ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)
|| SCM_I_ENTITYP (obj)),
obj,
SCM_ARG1,
- s_sys_set_object_setter_x);
+ FUNC_NAME);
if (SCM_I_ENTITYP (obj))
SCM_ENTITY_SETTER (obj) = setter;
else
SCM_OPERATOR_CLASS (obj)->setter = setter;
return SCM_UNSPECIFIED;
}
+#undef FUNC_NAME
/******************************************************************************
*
*
******************************************************************************/
-SCM_PROC (s_sys_modify_instance, "%modify-instance", 2, 0, 0, scm_sys_modify_instance);
-
-SCM
-scm_sys_modify_instance (SCM old, SCM new)
+SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0,
+ (SCM old, SCM new),
+ "")
+#define FUNC_NAME s_scm_sys_modify_instance
{
- SCM_ASSERT (SCM_NIMP (old) && SCM_INSTANCEP (old),
- old, SCM_ARG1, s_sys_modify_instance);
- SCM_ASSERT (SCM_NIMP (new) && SCM_INSTANCEP (new),
- new, SCM_ARG2, s_sys_modify_instance);
+ SCM_VALIDATE_INSTANCE (1, old);
+ SCM_VALIDATE_INSTANCE (2, new);
/* Exchange the data contained in old and new. We exchange rather than
* scratch the old value with new to be correct with GC.
SCM_REALLOW_INTS;
return SCM_UNSPECIFIED;
}
+#undef FUNC_NAME
-SCM_PROC (s_sys_modify_class, "%modify-class", 2, 0, 0, scm_sys_modify_class);
-
-SCM
-scm_sys_modify_class (SCM old, SCM new)
+SCM_DEFINE (scm_sys_modify_class, "%modify-class", 2, 0, 0,
+ (SCM old, SCM new),
+ "")
+#define FUNC_NAME s_scm_sys_modify_class
{
- SCM_ASSERT (SCM_NIMP (old) && CLASSP (old),
- old, SCM_ARG1, s_sys_modify_class);
- SCM_ASSERT (SCM_NIMP (new) && CLASSP (new),
- new, SCM_ARG2, s_sys_modify_class);
+ SCM_VALIDATE_CLASS (1, old);
+ SCM_VALIDATE_CLASS (2, new);
SCM_REDEFER_INTS;
{
SCM_REALLOW_INTS;
return SCM_UNSPECIFIED;
}
+#undef FUNC_NAME
-SCM_PROC (s_sys_invalidate_class, "%invalidate-class", 1, 0, 0, scm_sys_invalidate_class);
-
-SCM
-scm_sys_invalidate_class (SCM class)
+SCM_DEFINE (scm_sys_invalidate_class, "%invalidate-class", 1, 0, 0,
+ (SCM class),
+ "")
+#define FUNC_NAME s_scm_sys_invalidate_class
{
- SCM_ASSERT (SCM_NIMP (class) && CLASSP (class),
- class, SCM_ARG1, s_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
static SCM
purgatory (void *args)
{
- return scm_apply (GETVAR (Intern ("change-class")), (SCM) args, SCM_EOL);
+ return scm_apply (GETVAR (scm_str2symbol ("change-class")), (SCM) args, SCM_EOL);
}
void
SCM_SLOT (gf, scm_si_used_by) = SCM_BOOL_F;
}
-SCM_PROC (s_sys_invalidate_method_cache_x, "%invalidate-method-cache!", 1, 0, 0, scm_sys_invalidate_method_cache_x);
-
-SCM
-scm_sys_invalidate_method_cache_x (SCM gf)
+SCM_DEFINE (scm_sys_invalidate_method_cache_x, "%invalidate-method-cache!", 1, 0, 0,
+ (SCM gf),
+ "")
+#define FUNC_NAME s_scm_sys_invalidate_method_cache_x
{
SCM used_by;
- SCM_ASSERT (SCM_NIMP (gf) && SCM_STRUCTP (gf) && SCM_PUREGENERICP (gf),
- gf, SCM_ARG1, s_sys_invalidate_method_cache_x);
+ SCM_ASSERT (SCM_PUREGENERICP (gf), gf, SCM_ARG1, FUNC_NAME);
used_by = SCM_SLOT (gf, scm_si_used_by);
if (SCM_NFALSEP (used_by))
{
SCM methods = SCM_SLOT (gf, scm_si_methods);
- for (; SCM_NIMP (used_by) && SCM_CONSP (used_by);
- used_by = SCM_CDR (used_by))
+ for (; SCM_CONSP (used_by); used_by = SCM_CDR (used_by))
scm_sys_invalidate_method_cache_x (SCM_CAR (used_by));
clear_method_cache (gf);
- for (; SCM_NIMP (methods) && SCM_CONSP (methods);
- methods = SCM_CDR (methods))
+ for (; SCM_CONSP (methods); methods = SCM_CDR (methods))
SCM_SLOT (SCM_CAR (methods), scm_si_code_table) = SCM_EOL;
}
{
}
return SCM_UNSPECIFIED;
}
+#undef FUNC_NAME
-SCM_PROC (s_generic_capability_p, "generic-capability?", 1, 0, 0, scm_generic_capability_p);
-
-SCM
-scm_generic_capability_p (SCM proc)
+SCM_DEFINE (scm_generic_capability_p, "generic-capability?", 1, 0, 0,
+ (SCM proc),
+ "")
+#define FUNC_NAME s_scm_generic_capability_p
{
SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (proc)),
- proc, SCM_ARG1, s_generic_capability_p);
+ proc, SCM_ARG1, FUNC_NAME);
return (scm_subr_p (proc) && SCM_SUBR_GENERIC (proc)
? SCM_BOOL_T
: SCM_BOOL_F);
}
+#undef FUNC_NAME
-SCM_PROC (s_enable_primitive_generic_x, "enable-primitive-generic!", 0, 0, 1, scm_enable_primitive_generic_x);
-
-SCM
-scm_enable_primitive_generic_x (SCM subrs)
+SCM_DEFINE (scm_enable_primitive_generic_x, "enable-primitive-generic!", 0, 0, 1,
+ (SCM subrs),
+ "")
+#define FUNC_NAME s_scm_enable_primitive_generic_x
{
while (SCM_NIMP (subrs))
{
SCM subr = SCM_CAR (subrs);
SCM_ASSERT (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr),
- subr, SCM_ARGn, s_enable_primitive_generic_x);
+ subr, SCM_ARGn, FUNC_NAME);
*SCM_SUBR_GENERIC (subr)
= scm_make (SCM_LIST3 (scm_class_generic,
k_name,
}
return SCM_UNSPECIFIED;
}
+#undef FUNC_NAME
-SCM_PROC (s_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0, scm_primitive_generic_generic);
-
-SCM
-scm_primitive_generic_generic (SCM subr)
+SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0,
+ (SCM subr),
+ "")
+#define FUNC_NAME s_scm_primitive_generic_generic
{
if (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr))
{
if (gf)
return gf;
}
- return scm_wta (subr, (char *) SCM_ARG1, s_primitive_generic_generic);
+ return scm_wta (subr, (char *) SCM_ARG1, FUNC_NAME);
}
+#undef FUNC_NAME
/******************************************************************************
*
static int
applicablep (SCM actual, SCM formal)
{
- register SCM ptr;
-
- /* We test that (memq formal (slot-ref actual 'cpl))
- * However, we don't call memq here since we already know that
- * the list is well formed
- */
- for (ptr=SCM_SLOT(actual, scm_si_cpl); SCM_NNULLP(ptr); ptr = SCM_CDR(ptr)) {
- if (SCM_NIMP (ptr) && SCM_CONSP (ptr)) {
- if (SCM_CAR (ptr) == formal)
- return 1;
- }
- else
- scm_misc_error (0,
- "Internal error in applicable: bad list ~S",
- SCM_LIST1 (actual));
- }
- return 0;
+ /* We already know that the cpl is well formed. */
+ return !SCM_FALSEP (scm_c_memq (formal, SCM_SLOT (actual, scm_si_cpl)));
}
static int
continue;
for (i = 0; ; i++, fl = SCM_CDR (fl))
{
- if ((SCM_NIMP (fl) && SCM_INSTANCEP (fl))
+ if (SCM_INSTANCEP (fl)
/* We have a dotted argument list */
|| (i >= len && SCM_NULLP (fl)))
{ /* both list exhausted */
SCM
scm_sys_compute_applicable_methods (SCM gf, SCM args)
+#define FUNC_NAME s_sys_compute_applicable_methods
{
int n;
- SCM_ASSERT (SCM_NIMP (gf) && GENERICP (gf),
- gf, SCM_ARG1, s_sys_compute_applicable_methods);
+ SCM_VALIDATE_GENERIC (1, gf);
n = scm_ilength (args);
- SCM_ASSERT (n >= 0, args, SCM_ARG2, s_sys_compute_applicable_methods);
+ SCM_ASSERT (n >= 0, args, SCM_ARG2, FUNC_NAME);
return scm_compute_applicable_methods (gf, args, n, 1);
}
+#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 args, n, v, gf, x = SCM_CDR (xorig);
SCM_ASSYNT (scm_ilength (x) == 4, xorig, scm_s_expression, s_atdispatch);
args = SCM_CAR (x);
- SCM_ASSYNT (SCM_NIMP (args) && (SCM_CONSP (args) || SCM_SYMBOLP (args)),
+ SCM_ASSYNT (SCM_CONSP (args) || SCM_SYMBOLP (args),
args, SCM_ARG1, s_atdispatch);
x = SCM_CDR (x);
n = SCM_XEVALCAR (x, env);
SCM_ASSERT_RANGE (0, n, SCM_INUM (n) >= 1);
x = SCM_CDR (x);
v = SCM_XEVALCAR (x, env);
- SCM_ASSYNT (SCM_NIMP (v) && SCM_VECTORP (v), v, SCM_ARG3, s_atdispatch);
+ SCM_ASSYNT (SCM_VECTORP (v), v, SCM_ARG3, s_atdispatch);
x = SCM_CDR (x);
gf = SCM_XEVALCAR (x, env);
- SCM_ASSYNT (SCM_NIMP (gf) && SCM_STRUCTP (gf) && SCM_PUREGENERICP (gf),
- gf, SCM_ARG4, s_atdispatch);
+ SCM_ASSYNT (SCM_PUREGENERICP (gf), gf, SCM_ARG4, s_atdispatch);
return SCM_LIST5 (SCM_IM_DISPATCH, args, n, v, gf);
}
#undef FUNC_NAME
SCM_KEYWORD (k_slots, "slots");
SCM_KEYWORD (k_gf, "generic-function");
-SCM_PROC (s_make, "make", 0, 0, 1, scm_make);
-
-SCM
-scm_make (SCM args)
+SCM_DEFINE (scm_make, "make", 0, 0, 1,
+ (SCM args),
+ "")
+#define FUNC_NAME s_scm_make
{
SCM class, z;
int len = scm_ilength (args);
if (len <= 0 || (len & 1) == 0)
- scm_wrong_num_args (scm_makfrom0str (s_make));
+ SCM_WRONG_NUM_ARGS ();
class = SCM_CAR(args);
args = SCM_CDR(args);
args,
len - 1,
SCM_BOOL_F,
- s_make);
+ FUNC_NAME);
SCM_SLOT (z, scm_si_specializers) =
scm_i_get_keyword (k_specializers,
args,
len - 1,
SCM_EOL,
- s_make);
+ FUNC_NAME);
SCM_SLOT (z, scm_si_procedure) =
scm_i_get_keyword (k_procedure,
args,
len - 1,
SCM_EOL,
- s_make);
+ FUNC_NAME);
SCM_SLOT (z, scm_si_code_table) = SCM_EOL;
}
else
scm_i_get_keyword (k_name,
args,
len - 1,
- Intern ("???"),
- s_make);
+ scm_str2symbol ("???"),
+ FUNC_NAME);
SCM_SLOT (z, scm_si_direct_supers) =
scm_i_get_keyword (k_dsupers,
args,
len - 1,
SCM_EOL,
- s_make);
+ FUNC_NAME);
SCM_SLOT (z, scm_si_direct_slots) =
scm_i_get_keyword (k_slots,
args,
len - 1,
SCM_EOL,
- s_make);
+ FUNC_NAME);
}
}
return z;
}
+#undef FUNC_NAME
-SCM_PROC (s_find_method, "find-method", 0, 0, 1, scm_find_method);
-
-SCM
-scm_find_method (SCM l)
+SCM_DEFINE (scm_find_method, "find-method", 0, 0, 1,
+ (SCM l),
+ "")
+#define FUNC_NAME s_scm_find_method
{
SCM gf;
int len = scm_ilength (l);
if (len == 0)
- scm_wrong_num_args (scm_makfrom0str (s_find_method));
+ SCM_WRONG_NUM_ARGS ();
gf = SCM_CAR(l); l = SCM_CDR(l);
- SCM_ASSERT (SCM_NIMP (gf) && GENERICP (gf), gf, SCM_ARG1, s_find_method);
+ SCM_VALIDATE_GENERIC (1, gf);
if (SCM_NULLP (SCM_SLOT (gf, scm_si_methods)))
- scm_misc_error (s_find_method,
- "no methods for generic ~S",
- SCM_LIST1 (gf));
+ SCM_MISC_ERROR ("no methods for generic ~S", SCM_LIST1 (gf));
return scm_compute_applicable_methods (gf, l, len - 1, 1);
}
+#undef FUNC_NAME
-SCM_PROC (s_sys_method_more_specific_p, "%method-more-specific?", 3, 0, 0, scm_sys_method_more_specific_p);
-
-SCM
-scm_sys_method_more_specific_p (SCM m1, SCM m2, SCM targs)
+SCM_DEFINE (scm_sys_method_more_specific_p, "%method-more-specific?", 3, 0, 0,
+ (SCM m1, SCM m2, SCM targs),
+ "")
+#define FUNC_NAME s_scm_sys_method_more_specific_p
{
SCM l, v;
int i, len;
- SCM_ASSERT (SCM_NIMP (m1) && METHODP (m1),
- m1, SCM_ARG1, s_sys_method_more_specific_p);
- SCM_ASSERT (SCM_NIMP (m2) && METHODP (m2),
- m2, SCM_ARG2, s_sys_method_more_specific_p);
- SCM_ASSERT ((len = scm_ilength (targs)) != -1,
- targs, SCM_ARG3, s_sys_method_more_specific_p);
+ SCM_VALIDATE_METHOD (1, m1);
+ SCM_VALIDATE_METHOD (2, m2);
+ SCM_ASSERT ((len = scm_ilength (targs)) != -1, targs, SCM_ARG3, FUNC_NAME);
/* Verify that all the arguments of targs are classes and place them in a vector*/
v = scm_make_vector (SCM_MAKINUM (len), SCM_EOL);
for (i=0, l=targs; SCM_NNULLP(l); i++, l=SCM_CDR(l)) {
- SCM_ASSERT (SCM_NIMP (SCM_CAR (l)) && CLASSP (SCM_CAR (l)),
- targs, SCM_ARG3, s_sys_method_more_specific_p);
+ SCM_ASSERT (SCM_CLASSP (SCM_CAR (l)), targs, SCM_ARG3, FUNC_NAME);
SCM_VELTS(v)[i] = SCM_CAR(l);
}
return more_specificp (m1, m2, SCM_VELTS(v)) ? SCM_BOOL_T: SCM_BOOL_F;
}
+#undef FUNC_NAME
static void
make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots)
{
- SCM tmp = Intern(name);
+ SCM tmp = scm_str2symbol (name);
*var = scm_permanent_object (scm_basic_make_class (meta,
tmp,
create_standard_classes (void)
{
SCM slots;
- SCM method_slots = SCM_LIST4 (Intern ("generic-function"),
- Intern ("specializers"),
- Intern ("procedure"),
- Intern ("code-table"));
- SCM amethod_slots = SCM_LIST1 (SCM_LIST3 (Intern ("slot-definition"),
+ SCM method_slots = SCM_LIST4 (scm_str2symbol ("generic-function"),
+ scm_str2symbol ("specializers"),
+ scm_str2symbol ("procedure"),
+ scm_str2symbol ("code-table"));
+ SCM amethod_slots = SCM_LIST1 (SCM_LIST3 (scm_str2symbol ("slot-definition"),
k_init_keyword,
k_slot_definition));
#ifdef USE_THREADS
- SCM mutex_slot = SCM_LIST1 (Intern ("make-mutex"));
+ SCM mutex_slot = SCM_LIST1 (scm_str2symbol ("make-mutex"));
#else
SCM mutex_slot = SCM_BOOL_F;
#endif
- SCM gf_slots = SCM_LIST4 (Intern ("methods"),
- SCM_LIST3 (Intern ("n-specialized"),
+ SCM gf_slots = SCM_LIST4 (scm_str2symbol ("methods"),
+ SCM_LIST3 (scm_str2symbol ("n-specialized"),
k_init_value,
SCM_INUM0),
- SCM_LIST3 (Intern ("used-by"),
+ SCM_LIST3 (scm_str2symbol ("used-by"),
k_init_value,
SCM_BOOL_F),
- SCM_LIST3 (Intern ("cache-mutex"),
+ SCM_LIST3 (scm_str2symbol ("cache-mutex"),
k_init_thunk,
scm_closure (SCM_LIST2 (SCM_EOL,
mutex_slot),
make_stdcls (&scm_class_foreign_class, "<foreign-class>",
scm_class_class, scm_class_class,
- SCM_LIST2 (SCM_LIST3 (Intern ("constructor"),
+ SCM_LIST2 (SCM_LIST3 (scm_str2symbol ("constructor"),
k_class,
scm_class_opaque),
- SCM_LIST3 (Intern ("destructor"),
+ SCM_LIST3 (scm_str2symbol ("destructor"),
k_class,
scm_class_opaque)));
make_stdcls (&scm_class_foreign_object, "<foreign-object>",
{
char buffer[100];
sprintf (buffer, template, type_name);
- name = Intern (buffer);
+ name = scm_str2symbol (buffer);
}
else
name = SCM_GOOPS_UNBOUND;
void * (*constructor) (SCM)
= (void * (*) (SCM)) SCM_SLOT (class, scm_si_constructor);
SCM_ASSERT (constructor != 0, class, "Can't make instances of this class",
- s_make);
+ s_scm_make);
return scm_wrap_object (class, constructor (initargs));
}
size_t (*destructor) (void *))
{
SCM name, class;
- name = Intern (s_name);
+ name = scm_str2symbol (s_name);
if (SCM_IMP (supers))
supers = SCM_LIST1 (scm_class_foreign_object);
class = scm_basic_basic_make_class (meta, name, supers, SCM_EOL);
SCM_SET_CLASS_INSTANCE_SIZE (class, size);
}
- SCM_SLOT (class, scm_si_layout) = SCM_CAR (scm_intern ("", 0));
+ SCM_SLOT (class, scm_si_layout) = scm_str2symbol ("");
SCM_SLOT (class, scm_si_constructor) = (SCM) constructor;
return class;
SCM_LIST3 (set, sym_o, sym_x)),
SCM_EOL);
{
- SCM name = SCM_CAR (scm_intern0 (slot_name));
- SCM aname = SCM_CAR (scm_intern0 (accessor_name));
+ SCM name = scm_str2symbol (slot_name);
+ SCM aname = scm_str2symbol (accessor_name);
SCM gf = scm_ensure_accessor (aname);
SCM slot = SCM_LIST5 (name,
k_class, slot_class,
* Debugging utilities
*/
-SCM_PROC (s_pure_generic_p, "pure-generic?", 1, 0, 0, scm_pure_generic_p);
-
-SCM
-scm_pure_generic_p (SCM obj)
+SCM_DEFINE (scm_pure_generic_p, "pure-generic?", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_pure_generic_p
{
- return (SCM_NIMP (obj) && SCM_STRUCTP (obj) && SCM_PUREGENERICP (obj)
- ? SCM_BOOL_T
- : SCM_BOOL_F);
+ return SCM_BOOL (SCM_PUREGENERICP (obj));
}
+#undef FUNC_NAME
#endif /* GUILE_DEBUG */
* Initialization
*/
-SCM_PROC (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0, sys_goops_loaded);
-
-static SCM
-sys_goops_loaded ()
+SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0,
+ (),
+ "")
+#define FUNC_NAME s_scm_sys_goops_loaded
{
goops_loaded_p = 1;
var_compute_applicable_methods
SCM_EOL));
return SCM_UNSPECIFIED;
}
+#undef FUNC_NAME
SCM scm_module_goops;
create_port_classes ();
{
- SCM name = SCM_CAR (scm_intern0 ("no-applicable-method"));
+ SCM name = scm_str2symbol ("no-applicable-method");
scm_no_applicable_method
= scm_permanent_object (scm_make (SCM_LIST3 (scm_class_generic,
k_name,
{
scm_register_module_xxx ("oop goops goopscore", (void *) scm_init_goops);
}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
HCoop / bpt / guile.git / blobdiff