-/* 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
#include "libguile/_scm.h"
#include "libguile/alist.h"
+#include "libguile/async.h"
+#include "libguile/chars.h"
#include "libguile/debug.h"
#include "libguile/dynl.h"
#include "libguile/dynwind.h"
(v), SCM_BOOL_F)))
/* Fixme: Should use already interned symbols */
-#define CALL_GF1(name, a) (scm_call_1 (GETVAR (scm_str2symbol (name)), \
+
+#define CALL_GF1(name, a) (scm_call_1 (GETVAR (scm_from_locale_symbol (name)), \
a))
-#define CALL_GF2(name, a, b) (scm_call_2 (GETVAR (scm_str2symbol (name)), \
+#define CALL_GF2(name, a, b) (scm_call_2 (GETVAR (scm_from_locale_symbol (name)), \
a, b))
-#define CALL_GF3(name, a, b, c) (scm_call_3 (GETVAR (scm_str2symbol (name)), \
+#define CALL_GF3(name, a, b, c) (scm_call_3 (GETVAR (scm_from_locale_symbol (name)), \
a, b, c))
-#define CALL_GF4(name, a, b, c, d) (scm_call_4 (GETVAR (scm_str2symbol (name)), \
+#define CALL_GF4(name, a, b, c, d) (scm_call_4 (GETVAR (scm_from_locale_symbol (name)), \
a, b, c, d))
/* Class redefinition protocol:
#define TEST_CHANGE_CLASS(obj, class) \
{ \
class = SCM_CLASS_OF (obj); \
- if (!SCM_FALSEP (SCM_OBJ_CLASS_REDEF (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); \
static SCM scm_goops_lookup_closure;
-/* Some classes are defined in libguile/objects.c. */
+/* These variables are filled in by the object system when loaded. */
+SCM scm_class_boolean, scm_class_char, scm_class_pair;
+SCM scm_class_procedure, scm_class_string, scm_class_symbol;
+SCM scm_class_procedure_with_setter, scm_class_primitive_generic;
+SCM scm_class_vector, scm_class_null;
+SCM scm_class_integer, scm_class_real, scm_class_complex, scm_class_fraction;
+SCM scm_class_unknown;
SCM scm_class_top, scm_class_object, scm_class_class;
SCM scm_class_applicable;
SCM scm_class_entity, scm_class_entity_with_setter;
SCM scm_class_scm;
SCM scm_class_int, scm_class_float, scm_class_double;
+SCM *scm_port_class = 0;
+SCM *scm_smob_class = 0;
+
+SCM scm_no_applicable_method;
+
SCM_SYMBOL (scm_sym_define_public, "define-public");
static SCM scm_make_unbound (void);
static SCM scm_at_assert_bound_ref (SCM obj, SCM index);
static SCM scm_sys_goops_loaded (void);
+/* This function is used for efficient type dispatch. */
+SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
+ (SCM x),
+ "Return the class of @var{x}.")
+#define FUNC_NAME s_scm_class_of
+{
+ switch (SCM_ITAG3 (x))
+ {
+ case scm_tc3_int_1:
+ case scm_tc3_int_2:
+ return scm_class_integer;
+
+ case scm_tc3_imm24:
+ if (SCM_CHARP (x))
+ return scm_class_char;
+ else if (scm_is_bool (x))
+ return scm_class_boolean;
+ else if (scm_is_null (x))
+ return scm_class_null;
+ else
+ return scm_class_unknown;
+
+ case scm_tc3_cons:
+ switch (SCM_TYP7 (x))
+ {
+ case scm_tcs_cons_nimcar:
+ return scm_class_pair;
+ case scm_tcs_closures:
+ return scm_class_procedure;
+ case scm_tc7_symbol:
+ return scm_class_symbol;
+ case scm_tc7_vector:
+ case scm_tc7_wvect:
+ return scm_class_vector;
+ case scm_tc7_string:
+ return scm_class_string;
+ case scm_tc7_number:
+ switch SCM_TYP16 (x) {
+ case scm_tc16_big:
+ return scm_class_integer;
+ case scm_tc16_real:
+ return scm_class_real;
+ case scm_tc16_complex:
+ return scm_class_complex;
+ case scm_tc16_fraction:
+ return scm_class_fraction;
+ }
+ case scm_tc7_asubr:
+ case scm_tc7_subr_0:
+ case scm_tc7_subr_1:
+ case scm_tc7_dsubr:
+ case scm_tc7_cxr:
+ case scm_tc7_subr_3:
+ case scm_tc7_subr_2:
+ case scm_tc7_rpsubr:
+ case scm_tc7_subr_1o:
+ case scm_tc7_subr_2o:
+ case scm_tc7_lsubr_2:
+ case scm_tc7_lsubr:
+ if (SCM_SUBR_GENERIC (x) && *SCM_SUBR_GENERIC (x))
+ return scm_class_primitive_generic;
+ else
+ return scm_class_procedure;
+ case scm_tc7_cclo:
+ return scm_class_procedure;
+ case scm_tc7_pws:
+ return scm_class_procedure_with_setter;
+
+ case scm_tc7_smob:
+ {
+ scm_t_bits type = SCM_TYP16 (x);
+ if (type != scm_tc16_port_with_ps)
+ return scm_smob_class[SCM_TC2SMOBNUM (type)];
+ x = SCM_PORT_WITH_PS_PORT (x);
+ /* fall through to ports */
+ }
+ case scm_tc7_port:
+ return scm_port_class[(SCM_WRTNG & SCM_CELL_WORD_0 (x)
+ ? (SCM_RDNG & SCM_CELL_WORD_0 (x)
+ ? SCM_INOUT_PCLASS_INDEX | SCM_PTOBNUM (x)
+ : SCM_OUT_PCLASS_INDEX | SCM_PTOBNUM (x))
+ : SCM_IN_PCLASS_INDEX | SCM_PTOBNUM (x))];
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS_VALID)
+ return SCM_CLASS_OF (x);
+ else if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS)
+ {
+ /* 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 */
+ return SCM_CLASS_OF (x);
+ }
+ else
+ {
+ /* ordinary struct */
+ SCM handle = scm_struct_create_handle (SCM_STRUCT_VTABLE (x));
+ if (scm_is_true (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle))))
+ return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle));
+ else
+ {
+ SCM name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle));
+ SCM class = scm_make_extended_class (scm_is_true (name)
+ ? scm_i_symbol_chars (name)
+ : 0,
+ SCM_I_OPERATORP (x));
+ SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class);
+ return class;
+ }
+ }
+ default:
+ if (scm_is_pair (x))
+ return scm_class_pair;
+ else
+ return scm_class_unknown;
+ }
+
+ case scm_tc3_struct:
+ case scm_tc3_tc7_1:
+ case scm_tc3_tc7_2:
+ case scm_tc3_closure:
+ /* Never reached */
+ break;
+ }
+ return scm_class_unknown;
+}
+#undef FUNC_NAME
+
/******************************************************************************
*
* Compute-cpl
static SCM
map (SCM (*proc) (SCM), SCM ls)
{
- if (SCM_NULLP (ls))
+ if (scm_is_null (ls))
return ls;
else
{
SCM res = scm_cons (proc (SCM_CAR (ls)), SCM_EOL);
SCM h = res;
ls = SCM_CDR (ls);
- while (!SCM_NULLP (ls))
+ while (!scm_is_null (ls))
{
SCM_SETCDR (h, scm_cons (proc (SCM_CAR (ls)), SCM_EOL));
h = SCM_CDR (h);
filter_cpl (SCM ls)
{
SCM res = SCM_EOL;
- while (!SCM_NULLP (ls))
+ while (!scm_is_null (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);
}
{
SCM tmp;
- if (SCM_NULLP (l))
+ if (scm_is_null (l))
return res;
tmp = SCM_CAAR (l);
- if (!SCM_SYMBOLP (tmp))
+ if (!scm_is_symbol (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);
}
{
register SCM res = dslots;
- for (cpl = SCM_CDR (cpl); !SCM_NULLP (cpl); cpl = SCM_CDR (cpl))
+ for (cpl = SCM_CDR (cpl); !scm_is_null (cpl); cpl = SCM_CDR (cpl))
res = scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl),
scm_si_direct_slots),
res));
maplist (SCM ls)
{
SCM orig = ls;
- while (!SCM_NULLP (ls))
+ while (!scm_is_null (ls))
{
- if (!SCM_CONSP (SCM_CAR (ls)))
+ if (!scm_is_pair (SCM_CAR (ls)))
SCM_SETCAR (ls, scm_cons (SCM_CAR (ls), SCM_EOL));
ls = SCM_CDR (ls);
}
SCM *cdrloc = &res;
long i = 0;
- for ( ; !SCM_NULLP (slots); slots = SCM_CDR (slots))
+ for ( ; !scm_is_null (slots); slots = SCM_CDR (slots))
{
SCM init = SCM_BOOL_F;
SCM options = SCM_CDAR (slots);
- if (!SCM_NULLP (options))
+ if (!scm_is_null (options))
{
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_from_int (i++))),
SCM_EOL);
cdrloc = SCM_CDRLOC (*cdrloc);
}
{
SCM obj = SCM_CAR (l);
- if (!SCM_KEYWORDP (obj))
+ if (!scm_is_keyword (obj))
scm_misc_error (subr, "bad keyword: ~S", scm_list_1 (obj));
- else if (SCM_EQ_P (obj, key))
+ else if (scm_is_eq (obj, key))
return SCM_CADR (l);
else
l = SCM_CDDR (l);
{
long len;
- SCM_ASSERT (SCM_KEYWORDP (key), key, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_keyword (key), key, SCM_ARG1, FUNC_NAME);
len = scm_ilength (l);
if (len < 0 || len % 2 == 1)
scm_misc_error (FUNC_NAME, "Bad keyword-value list: ~S", scm_list_1 (l));
/* See for each slot how it must be initialized */
for (;
- !SCM_NULLP (slots);
+ !scm_is_null (slots);
get_n_set = SCM_CDR (get_n_set), slots = SCM_CDR (slots))
{
SCM slot_name = SCM_CAR (slots);
SCM slot_value = 0;
- if (!SCM_NULLP (SCM_CDR (slot_name)))
+ if (!scm_is_null (SCM_CDR (slot_name)))
{
/* This slot admits (perhaps) to be initialized at creation time */
long n = scm_ilength (SCM_CDR (slot_name));
if (tmp)
{
/* an initarg was provided for this slot */
- if (!SCM_KEYWORDP (tmp))
+ if (!scm_is_keyword (tmp))
SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
scm_list_1 (tmp));
slot_value = scm_i_get_keyword (tmp,
{
/* set slot to its :init-form if it exists */
tmp = SCM_CADAR (get_n_set);
- if (!SCM_FALSEP (tmp))
+ if (scm_is_true (tmp))
{
slot_value = get_slot_value (class, obj, SCM_CAR (get_n_set));
if (SCM_GOOPS_UNBOUNDP (slot_value))
* in goops.scm:compute-getters-n-setters
*/
#define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
- (SCM_INUMP (SCM_CDDR (gns)) \
- || (SCM_CONSP (SCM_CDDR (gns)) \
- && SCM_CONSP (SCM_CDDDR (gns)) \
- && SCM_CONSP (SCM_CDDDDR (gns))))
+ (SCM_I_INUMP (SCM_CDDR (gns)) \
+ || (scm_is_pair (SCM_CDDR (gns)) \
+ && scm_is_pair (SCM_CDDDR (gns)) \
+ && scm_is_pair (SCM_CDDDDR (gns))))
#define SCM_GNS_INDEX(gns) \
- (SCM_INUMP (SCM_CDDR (gns)) \
- ? SCM_INUM (SCM_CDDR (gns)) \
- : SCM_INUM (SCM_CAR (SCM_CDDDDR (gns))))
+ (SCM_I_INUMP (SCM_CDDR (gns)) \
+ ? SCM_I_INUM (SCM_CDDR (gns)) \
+ : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
#define SCM_GNS_SIZE(gns) \
- (SCM_INUMP (SCM_CDDR (gns)) \
+ (SCM_I_INUMP (SCM_CDDR (gns)) \
? 1 \
- : SCM_INUM (SCM_CADR (SCM_CDDDDR (gns))))
+ : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
SCM_KEYWORD (k_class, "class");
SCM_KEYWORD (k_allocation, "allocation");
SCM slots, getters_n_setters, nfields;
unsigned long int n, i;
char *s;
+ SCM layout;
SCM_VALIDATE_INSTANCE (1, class);
slots = SCM_SLOT (class, scm_si_slots);
getters_n_setters = SCM_SLOT (class, scm_si_getters_n_setters);
nfields = SCM_SLOT (class, scm_si_nfields);
- if (!SCM_INUMP (nfields) || SCM_INUM (nfields) < 0)
+ if (!SCM_I_INUMP (nfields) || SCM_I_INUM (nfields) < 0)
SCM_MISC_ERROR ("bad value in nfields slot: ~S",
scm_list_1 (nfields));
- n = 2 * SCM_INUM (nfields);
+ n = 2 * SCM_I_INUM (nfields);
if (n < sizeof (SCM_CLASS_CLASS_LAYOUT) - 1
&& SCM_SUBCLASSP (class, scm_class_class))
SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
scm_list_1 (nfields));
- s = n > 0 ? scm_malloc (n) : 0;
+ layout = scm_i_make_string (n, &s);
i = 0;
- while (SCM_CONSP (getters_n_setters))
+ while (scm_is_pair (getters_n_setters))
{
if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters)))
{
int len, index, size;
char p, a;
- if (i >= n || !SCM_CONSP (slots))
+ if (i >= n || !scm_is_pair (slots))
goto inconsistent;
/* extract slot type */
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';
else
{
if (!SCM_CLASSP (type))
- {
- if (s)
- free (s);
- SCM_MISC_ERROR ("bad slot class", SCM_EOL);
- }
+ SCM_MISC_ERROR ("bad slot class", SCM_EOL);
else if (SCM_SUBCLASSP (type, scm_class_foreign_slot))
{
if (SCM_SUBCLASSP (type, scm_class_self))
slots = SCM_CDR (slots);
getters_n_setters = SCM_CDR (getters_n_setters);
}
- if (!SCM_NULLP (slots))
+ if (!scm_is_null (slots))
{
inconsistent:
- if (s)
- free (s);
SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL);
}
- SCM_SET_SLOT (class, scm_si_layout, scm_mem2symbol (s, n));
- if (s)
- free (s);
+ SCM_SET_SLOT (class, scm_si_layout, scm_string_to_symbol (layout));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM ls = dsupers;
long flags = 0;
SCM_VALIDATE_INSTANCE (1, class);
- while (!SCM_NULLP (ls))
+ while (!scm_is_null (ls))
{
- SCM_ASSERT (SCM_CONSP (ls)
+ SCM_ASSERT (scm_is_pair (ls)
&& SCM_INSTANCEP (SCM_CAR (ls)),
dsupers,
SCM_ARG2,
SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity);
else
{
- long n = SCM_INUM (SCM_SLOT (class, scm_si_nfields));
+ long n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
#if 0
/*
* We could avoid calling scm_gc_malloc in the allocation code
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_from_int (scm_ilength (slots));
g_n_s = compute_getters_n_setters (slots);
SCM_SET_SLOT (z, scm_si_name, name);
/* Add this class in the direct-subclasses slot of dsupers */
{
SCM tmp;
- for (tmp = dsupers; !SCM_NULLP (tmp); tmp = SCM_CDR (tmp))
+ for (tmp = dsupers; !scm_is_null (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)));
/* SCM slots_of_class = build_class_class_slots (); */
/**** <scm_class_class> ****/
- SCM cs = scm_makfrom0str (SCM_CLASS_CLASS_LAYOUT
- + 2 * scm_vtable_offset_user);
- SCM name = scm_str2symbol ("<class>");
+ SCM cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
+ + 2 * scm_vtable_offset_user);
+ SCM name = scm_from_locale_symbol ("<class>");
scm_class_class = scm_permanent_object (scm_make_vtable_vtable (cs,
SCM_INUM0,
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_nfields, scm_from_int (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);
DEFVAR(name, scm_class_class);
/**** <scm_class_top> ****/
- name = scm_str2symbol ("<top>");
+ name = scm_from_locale_symbol ("<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 = scm_str2symbol ("<object>");
+ name = scm_from_locale_symbol ("<object>");
scm_class_object = scm_permanent_object (scm_basic_make_class (scm_class_class,
name,
scm_list_1 (scm_class_top),
"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
{
SCM gfs = scm_slot_ref (gf, sym_extended_by);
method_lists = scm_cons (scm_slot_ref (gf, sym_methods), method_lists);
- while (!SCM_NULLP (gfs))
+ while (!scm_is_null (gfs))
{
method_lists = fold_downward_gf_methods (method_lists, SCM_CAR (gfs));
gfs = SCM_CDR (gfs);
if (SCM_IS_A_P (gf, scm_class_extended_generic))
{
SCM gfs = scm_slot_ref (gf, sym_extends);
- while (!SCM_NULLP (gfs))
+ while (!scm_is_null (gfs))
{
SCM methods = scm_slot_ref (SCM_CAR (gfs), sym_methods);
method_lists = fold_upward_gf_methods (scm_cons (methods,
#define FUNC_NAME s_scm_method_generic_function
{
SCM_VALIDATE_METHOD (1, obj);
- return scm_slot_ref (obj, scm_str2symbol ("generic-function"));
+ return scm_slot_ref (obj, scm_from_locale_symbol ("generic-function"));
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_method_specializers
{
SCM_VALIDATE_METHOD (1, obj);
- return scm_slot_ref (obj, scm_str2symbol ("specializers"));
+ return scm_slot_ref (obj, scm_from_locale_symbol ("specializers"));
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_accessor_method_slot_definition
{
SCM_VALIDATE_ACCESSOR (1, obj);
- return scm_slot_ref (obj, scm_str2symbol ("slot-definition"));
+ return scm_slot_ref (obj, scm_from_locale_symbol ("slot-definition"));
}
#undef FUNC_NAME
"the value from @var{obj}.")
#define FUNC_NAME s_scm_at_assert_bound_ref
{
- SCM value = SCM_SLOT (obj, SCM_INUM (index));
+ SCM value = SCM_SLOT (obj, scm_to_int (index));
if (SCM_GOOPS_UNBOUNDP (value))
return CALL_GF1 ("slot-unbound", obj);
return value;
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_makmmacro, scm_m_atslot_ref);
-SCM_SYNTAX (s_atslot_set_x, "@slot-set!", scm_makmmacro, scm_m_atslot_set_x);
+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 **/
slot_definition_using_name (SCM class, SCM slot_name)
{
register SCM slots = SCM_SLOT (class, scm_si_getters_n_setters);
- for (; !SCM_NULLP (slots); slots = SCM_CDR (slots))
+ for (; !scm_is_null (slots); slots = SCM_CDR (slots))
if (SCM_CAAR (slots) == slot_name)
return SCM_CAR (slots);
return SCM_BOOL_F;
/* 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
+ *
+ * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
+ * we can just assume fixnums here.
*/
- if (SCM_INUMP (access))
- return SCM_SLOT (obj, SCM_INUM (access));
+ if (SCM_I_INUMP (access))
+ return SCM_SLOT (obj, SCM_I_INUM (access));
else
{
/* We must evaluate (apply (car access) (list obj))
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);
/* Two cases here:
* - access is an integer (the offset of this slot in the slots vector)
* - otherwise (cadr access) is the setter function to apply
+ *
+ * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
+ * we can just assume fixnums here.
*/
- if (SCM_INUMP (access))
- SCM_SET_SLOT (obj, SCM_INUM (access), value);
+ if (SCM_I_INUMP (access))
+ SCM_SET_SLOT (obj, SCM_I_INUM (access), value);
else
{
/* We must evaluate (apply (cadr l) (list obj value))
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);
{
register SCM l;
- for (l = SCM_ACCESSORS_OF (obj); !SCM_NULLP (l); l = SCM_CDR (l))
- if (SCM_EQ_P (SCM_CAAR (l), slot_name))
+ for (l = SCM_ACCESSORS_OF (obj); !scm_is_null (l); l = SCM_CDR (l))
+ if (scm_is_eq (SCM_CAAR (l), slot_name))
return SCM_BOOL_T;
return SCM_BOOL_F;
/* Most instances */
if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT)
{
- n = SCM_INUM (SCM_SLOT (class, scm_si_nfields));
+ n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
m = (SCM *) scm_gc_malloc (n * sizeof (SCM), "struct");
return wrap_init (class, m, n);
}
if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN)
return scm_make_foreign_object (class, initargs);
- n = SCM_INUM (SCM_SLOT (class, scm_si_nfields));
+ n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
/* Entities */
if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY)
* scratch the old value with new to be correct with GC.
* See "Class redefinition protocol above".
*/
- SCM_REDEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
{
SCM car = SCM_CAR (old);
SCM cdr = SCM_CDR (old);
SCM_SETCAR (new, car);
SCM_SETCDR (new, cdr);
}
- SCM_REALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_VALIDATE_CLASS (1, old);
SCM_VALIDATE_CLASS (2, new);
- SCM_REDEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
{
SCM car = SCM_CAR (old);
SCM cdr = SCM_CDR (old);
SCM_SETCDR (new, cdr);
SCM_STRUCT_DATA (new)[scm_vtable_index_vtable] = SCM_UNPACK (new);
}
- SCM_REALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
{
return scm_list_5 (SCM_IM_DISPATCH,
scm_sym_args,
- SCM_MAKINUM (1),
+ scm_from_int (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))
+ for (; scm_is_pair (used_by); used_by = SCM_CDR (used_by))
scm_sys_invalidate_method_cache_x (SCM_CAR (used_by));
clear_method_cache (gf);
- for (; SCM_CONSP (methods); methods = SCM_CDR (methods))
+ for (; scm_is_pair (methods); methods = SCM_CDR (methods))
SCM_SET_SLOT (SCM_CAR (methods), scm_si_code_table, SCM_EOL);
}
{
"")
#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
#define FUNC_NAME s_scm_enable_primitive_generic_x
{
SCM_VALIDATE_REST_ARGUMENT (subrs);
- while (!SCM_NULLP (subrs))
+ while (!scm_is_null (subrs))
{
SCM subr = SCM_CAR (subrs);
SCM_ASSERT (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr),
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
*
*/
for (i=0, s1=SPEC_OF(m1), s2=SPEC_OF(m2); ; i++, s1=SCM_CDR(s1), s2=SCM_CDR(s2)) {
- if (SCM_NULLP(s1)) return 1;
- if (SCM_NULLP(s2)) return 0;
+ if (scm_is_null(s1)) return 1;
+ if (scm_is_null(s2)) return 0;
if (SCM_CAR(s1) != SCM_CAR(s2)) {
register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2);
SCM z = scm_c_make_vector (len, SCM_UNDEFINED);
for (j = 0; j < len; j++, l = SCM_CDR (l)) {
- SCM_VECTOR_SET (z, j, SCM_CAR (l));
+ SCM_SIMPLE_VECTOR_SET (z, j, SCM_CAR (l));
}
return z;
}
SCM *v, vector = SCM_EOL;
SCM buffer[BUFFSIZE];
SCM save = method_list;
+ scm_t_array_handle handle;
/* For reasonably sized method_lists we can try to avoid all the
* consing and reorder the list in place...
{
/* Too many elements in method_list to keep everything locally */
vector = scm_i_vector2list (save, size);
-
- /*
- This is a new vector. Don't worry about the write barrier.
- We're not allocating elements in this routine, so this should
- pose no problem.
- */
- v = SCM_WRITABLE_VELTS (vector);
+ v = scm_vector_writable_elements (vector, &handle, NULL, NULL);
}
/* Use a simple shell sort since it is generally faster than qsort on
}
return save;
}
+
/* If we are here, that's that we did it the hard way... */
+ scm_array_handle_release (&handle);
return scm_vector_to_list (vector);
}
SCM const *types;
SCM *p;
SCM tmp = SCM_EOL;
+ scm_t_array_handle handle;
/* Build the list of arguments types */
- if (len >= BUFFSIZE) {
- tmp = scm_c_make_vector (len, SCM_UNDEFINED);
- /* NOTE: Using pointers to malloced memory won't work if we
- 1. have preemtive threading, and,
- 2. have a GC which moves objects. */
- types = p = SCM_WRITABLE_VELTS(tmp);
+ if (len >= BUFFSIZE)
+ {
+ tmp = scm_c_make_vector (len, SCM_UNDEFINED);
+ types = p = scm_vector_writable_elements (tmp, &handle, NULL, NULL);
/*
note that we don't have to work to reset the generation
count. TMP is a new vector anyway, and it is found
conservatively.
*/
- }
+ }
else
types = p = buffer;
- for ( ; !SCM_NULLP (args); args = SCM_CDR (args))
+ for ( ; !scm_is_null (args); args = SCM_CDR (args))
*p++ = scm_class_of (SCM_CAR (args));
/* Build a list of all applicable methods */
- for (l = scm_generic_function_methods (gf); !SCM_NULLP (l); l = SCM_CDR (l))
+ for (l = scm_generic_function_methods (gf); !scm_is_null (l); l = SCM_CDR (l))
{
fl = SPEC_OF (SCM_CAR (l));
/* Only accept accessors which match exactly in first arg. */
if (SCM_ACCESSORP (SCM_CAR (l))
- && (SCM_NULLP (fl) || types[0] != SCM_CAR (fl)))
+ && (scm_is_null (fl) || types[0] != SCM_CAR (fl)))
continue;
for (i = 0; ; i++, fl = SCM_CDR (fl))
{
if (SCM_INSTANCEP (fl)
/* We have a dotted argument list */
- || (i >= len && SCM_NULLP (fl)))
+ || (i >= len && scm_is_null (fl)))
{ /* both list exhausted */
applicable = scm_cons (SCM_CAR (l), applicable);
count += 1;
break;
}
if (i >= len
- || SCM_NULLP (fl)
+ || scm_is_null (fl)
|| !applicablep (types[i], SCM_CAR (fl)))
break;
}
}
+ if (len >= BUFFSIZE)
+ scm_array_handle_release (&handle);
+
if (count == 0)
{
if (find_method_p)
return SCM_BOOL_F;
}
- scm_remember_upto_here_1 (tmp);
return (count == 1
? applicable
: sort_applicable_methods (applicable, count, types));
* 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_i_get_keyword (k_name,
args,
len - 1,
- scm_str2symbol ("???"),
+ scm_from_locale_symbol ("???"),
FUNC_NAME));
SCM_SET_SLOT (z, scm_si_direct_supers,
scm_i_get_keyword (k_dsupers,
gf = SCM_CAR(l); l = SCM_CDR(l);
SCM_VALIDATE_GENERIC (1, gf);
- if (SCM_NULLP (SCM_SLOT (gf, scm_si_methods)))
+ if (scm_is_null (SCM_SLOT (gf, scm_si_methods)))
SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf));
return scm_compute_applicable_methods (gf, l, len - 1, 1);
"")
#define FUNC_NAME s_scm_sys_method_more_specific_p
{
- SCM l, v;
+ SCM l, v, result;
+ SCM *v_elts;
long i, len;
+ scm_t_array_handle handle;
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*/
+ /* Verify that all the arguments of targs are classes and place them
+ in a vector
+ */
+
v = scm_c_make_vector (len, SCM_EOL);
+ v_elts = scm_vector_writable_elements (v, &handle, NULL, NULL);
- for (i = 0, l = targs; !SCM_NULLP (l); i++, l = SCM_CDR (l)) {
- SCM_ASSERT (SCM_CLASSP (SCM_CAR (l)), targs, SCM_ARG3, FUNC_NAME);
- SCM_VECTOR_SET (v, i, SCM_CAR(l));
- }
- return more_specificp (m1, m2, SCM_VELTS(v)) ? SCM_BOOL_T: SCM_BOOL_F;
+ for (i = 0, l = targs; i < len && scm_is_pair (l); i++, l = SCM_CDR (l))
+ {
+ SCM_ASSERT (SCM_CLASSP (SCM_CAR (l)), targs, SCM_ARG3, FUNC_NAME);
+ v_elts[i] = SCM_CAR(l);
+ }
+ result = more_specificp (m1, m2, v_elts) ? SCM_BOOL_T: SCM_BOOL_F;
+
+ scm_array_handle_release (&handle);
+
+ return result;
}
#undef FUNC_NAME
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);
static void
make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots)
{
- SCM tmp = scm_str2symbol (name);
+ SCM tmp = scm_from_locale_symbol (name);
*var = scm_permanent_object (scm_basic_make_class (meta,
tmp,
- SCM_CONSP (super)
+ scm_is_pair (super)
? super
: scm_list_1 (super),
slots));
create_standard_classes (void)
{
SCM slots;
- SCM method_slots = scm_list_4 (scm_str2symbol ("generic-function"),
- scm_str2symbol ("specializers"),
+ SCM method_slots = scm_list_4 (scm_from_locale_symbol ("generic-function"),
+ scm_from_locale_symbol ("specializers"),
sym_procedure,
- scm_str2symbol ("code-table"));
- SCM amethod_slots = scm_list_1 (scm_list_3 (scm_str2symbol ("slot-definition"),
+ scm_from_locale_symbol ("code-table"));
+ SCM amethod_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"),
k_init_keyword,
k_slot_definition));
- SCM mutex_slot = scm_list_1 (scm_str2symbol ("make-mutex"));
- SCM gf_slots = scm_list_5 (scm_str2symbol ("methods"),
- scm_list_3 (scm_str2symbol ("n-specialized"),
+ SCM mutex_slot = scm_list_1 (scm_from_locale_symbol ("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_from_locale_symbol ("methods"),
+ scm_list_3 (scm_from_locale_symbol ("n-specialized"),
k_init_value,
SCM_INUM0),
- scm_list_3 (scm_str2symbol ("used-by"),
+ scm_list_3 (scm_from_locale_symbol ("used-by"),
k_init_value,
SCM_BOOL_F),
- scm_list_3 (scm_str2symbol ("cache-mutex"),
+ scm_list_3 (scm_from_locale_symbol ("cache-mutex"),
k_init_thunk,
- scm_closure (scm_list_2 (SCM_EOL,
- mutex_slot),
- SCM_EOL)),
- scm_list_3 (scm_str2symbol ("extended-by"),
+ mutex_closure),
+ scm_list_3 (scm_from_locale_symbol ("extended-by"),
k_init_value,
SCM_EOL));
- SCM egf_slots = scm_list_1 (scm_list_3 (scm_str2symbol ("extends"),
+ SCM egf_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("extends"),
k_init_value,
SCM_EOL));
/* Foreign class slot classes */
make_stdcls (&scm_class_foreign_class, "<foreign-class>",
scm_class_class, scm_class_class,
- scm_list_2 (scm_list_3 (scm_str2symbol ("constructor"),
+ scm_list_2 (scm_list_3 (scm_from_locale_symbol ("constructor"),
k_class,
scm_class_opaque),
- scm_list_3 (scm_str2symbol ("destructor"),
+ scm_list_3 (scm_from_locale_symbol ("destructor"),
k_class,
scm_class_opaque)));
make_stdcls (&scm_class_foreign_object, "<foreign-object>",
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)
{
char buffer[100];
sprintf (buffer, template, type_name);
- name = scm_str2symbol (buffer);
+ name = scm_from_locale_symbol (buffer);
}
else
name = SCM_GOOPS_UNBOUND;
/* 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_i_symbol_chars (SCM_STRUCT_TABLE_NAME (data)),
SCM_CLASS_FLAGS (vtable) & SCM_CLASSF_OPERATOR));
return SCM_UNSPECIFIED;
}
size_t (*destructor) (void *))
{
SCM name, class;
- name = scm_str2symbol (s_name);
- if (SCM_NULLP (supers))
+ name = scm_from_locale_symbol (s_name);
+ if (scm_is_null (supers))
supers = scm_list_1 (scm_class_foreign_object);
class = scm_basic_basic_make_class (meta, name, supers, SCM_EOL);
scm_sys_inherit_magic_x (class, supers);
SCM_SET_CLASS_INSTANCE_SIZE (class, size);
}
- SCM_SET_SLOT (class, scm_si_layout, scm_str2symbol (""));
+ SCM_SET_SLOT (class, scm_si_layout, scm_from_locale_symbol (""));
SCM_SET_SLOT (class, scm_si_constructor, (SCM) constructor);
return class;
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 name = scm_from_locale_symbol (slot_name);
+ SCM aname = scm_from_locale_symbol (accessor_name);
SCM gf = scm_ensure_accessor (aname);
SCM slot = scm_list_5 (name,
k_class,
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_from_int (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_sum (n, scm_from_int (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_from_int (37)));
goops_rstate = scm_c_make_rstate ("GOOPS", 5);
create_port_classes ();
{
- SCM name = scm_str2symbol ("no-applicable-method");
+ SCM name = scm_from_locale_symbol ("no-applicable-method");
scm_no_applicable_method
= scm_permanent_object (scm_make (scm_list_3 (scm_class_generic,
k_name,
HCoop / bpt / guile.git / blobdiff