#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"
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_is_false (scm_c_memq (el, res)))
{
SCM tmp;
- if (SCM_NULLP (l))
+ if (scm_is_null (l))
return res;
tmp = SCM_CAAR (l);
{
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)
{
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_is_eq (obj, key))
return SCM_CADR (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,
*/
#define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
(SCM_I_INUMP (SCM_CDDR (gns)) \
- || (SCM_CONSP (SCM_CDDR (gns)) \
- && SCM_CONSP (SCM_CDDDR (gns)) \
- && SCM_CONSP (SCM_CDDDDR (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_I_INUMP (SCM_CDDR (gns)) \
? SCM_I_INUM (SCM_CDDR (gns)) \
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 */
slots = SCM_CDR (slots);
getters_n_setters = SCM_CDR (getters_n_setters);
}
- if (!SCM_NULLP (slots))
+ if (!scm_is_null (slots))
{
inconsistent:
SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL);
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,
/* 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 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,
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;
{
register SCM l;
- for (l = SCM_ACCESSORS_OF (obj); !SCM_NULLP (l); l = SCM_CDR (l))
+ 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;
* 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
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_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),
*
*/
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));
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
*var = scm_permanent_object (scm_basic_make_class (meta,
tmp,
- SCM_CONSP (super)
+ scm_is_pair (super)
? super
: scm_list_1 (super),
slots));
{
SCM name, class;
name = scm_from_locale_symbol (s_name);
- if (SCM_NULLP (supers))
+ 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);
HCoop / bpt / guile.git / blobdiff