-/* 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 program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * This program is distributed in the hope that it will be useful,
+ * This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ */
\f
/* This software is a derivative work of other copyrighted softwares; the
#define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined])
*/
-#define TEST_CHANGE_CLASS(obj, class) \
- { \
- class = SCM_CLASS_OF (obj); \
- if (SCM_OBJ_CLASS_REDEF (obj) != SCM_BOOL_F) \
- CALL_GF3 ("change-object-class", \
- obj, class, SCM_OBJ_CLASS_REDEF (obj)); \
+#define TEST_CHANGE_CLASS(obj, class) \
+ { \
+ class = SCM_CLASS_OF (obj); \
+ if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj))) \
+ { \
+ scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
+ class = SCM_CLASS_OF (obj); \
+ } \
}
#define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
/* Some classes are defined in libguile/objects.c. */
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_generic, scm_class_generic_with_setter;
+SCM scm_class_accessor;
SCM scm_class_extended_generic, scm_class_extended_generic_with_setter;
+SCM scm_class_extended_accessor;
SCM scm_class_method;
-SCM scm_class_simple_method, scm_class_accessor;
+SCM scm_class_simple_method, scm_class_accessor_method;
SCM scm_class_procedure_class;
SCM scm_class_operator_class, scm_class_operator_with_setter_class;
SCM scm_class_entity_class;
while (!SCM_NULLP (ls))
{
SCM el = SCM_CAR (ls);
- if (SCM_FALSEP (scm_c_memq (el, res)))
+ if (scm_is_false (scm_c_memq (el, res)))
res = scm_cons (el, res);
ls = SCM_CDR (ls);
}
if (!SCM_SYMBOLP (tmp))
scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp));
- if (SCM_FALSEP (scm_c_memq (tmp, slots_already_seen))) {
+ if (scm_is_false (scm_c_memq (tmp, slots_already_seen))) {
res = scm_cons (SCM_CAR (l), res);
slots_already_seen = scm_cons (tmp, slots_already_seen);
}
{
init = scm_get_keyword (k_init_value, options, 0);
if (init)
- init = scm_closure (scm_list_2 (SCM_EOL,
- scm_list_2 (scm_sym_quote, init)),
- SCM_EOL);
+ {
+ init = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
+ SCM_EOL,
+ scm_list_2 (scm_sym_quote,
+ init)),
+ SCM_EOL);
+ }
else
init = scm_get_keyword (k_init_thunk, options, SCM_BOOL_F);
}
*cdrloc = scm_cons (scm_cons (SCM_CAAR (slots),
scm_cons (init,
- SCM_MAKINUM (i++))),
+ SCM_I_MAKINUM (i++))),
SCM_EOL);
cdrloc = SCM_CDRLOC (*cdrloc);
}
{
/* set slot to its :init-form if it exists */
tmp = SCM_CADAR (get_n_set);
- if (tmp != SCM_BOOL_F)
+ if (scm_is_true (tmp))
{
slot_value = get_slot_value (class, obj, SCM_CAR (get_n_set));
if (SCM_GOOPS_UNBOUNDP (slot_value))
}
#undef FUNC_NAME
+/* NOTE: The following macros are interdependent with code
+ * 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))))
+#define SCM_GNS_INDEX(gns) \
+ (SCM_INUMP (SCM_CDDR (gns)) \
+ ? SCM_INUM (SCM_CDDR (gns)) \
+ : SCM_INUM (SCM_CAR (SCM_CDDDDR (gns))))
+#define SCM_GNS_SIZE(gns) \
+ (SCM_INUMP (SCM_CDDR (gns)) \
+ ? 1 \
+ : SCM_INUM (SCM_CADR (SCM_CDDDDR (gns))))
SCM_KEYWORD (k_class, "class");
+SCM_KEYWORD (k_allocation, "allocation");
+SCM_KEYWORD (k_instance, "instance");
SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0,
(SCM class),
"")
#define FUNC_NAME s_scm_sys_prep_layout_x
{
- SCM slots, nfields;
+ SCM slots, getters_n_setters, nfields;
unsigned long int n, i;
char *s;
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)
SCM_MISC_ERROR ("bad value in nfields slot: ~S",
scm_list_1 (nfields));
s = n > 0 ? scm_malloc (n) : 0;
- for (i = 0; i < n; i += 2)
+ i = 0;
+ while (SCM_CONSP (getters_n_setters))
{
- long len;
- SCM type;
- char p, a;
-
- if (!SCM_CONSP (slots))
- SCM_MISC_ERROR ("too 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,
- FUNC_NAME);
- if (SCM_FALSEP (type))
+ if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters)))
{
- p = 'p';
- a = 'w';
- }
- else
- {
- if (!SCM_CLASSP (type))
- SCM_MISC_ERROR ("bad slot class", SCM_EOL);
- else if (SCM_SUBCLASSP (type, scm_class_foreign_slot))
+ SCM type;
+ int len, index, size;
+ char p, a;
+
+ if (i >= n || !SCM_CONSP (slots))
+ goto inconsistent;
+
+ /* extract slot type */
+ len = scm_ilength (SCM_CDAR (slots));
+ 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_is_false (type))
{
- if (SCM_SUBCLASSP (type, scm_class_self))
- p = 's';
- else if (SCM_SUBCLASSP (type, scm_class_protected))
- p = 'p';
- else
- p = 'u';
-
- if (SCM_SUBCLASSP (type, scm_class_opaque))
- a = 'o';
- else if (SCM_SUBCLASSP (type, scm_class_read_only))
- a = 'r';
- else
- a = 'w';
+ p = 'p';
+ a = 'w';
}
else
{
- p = 'p';
- a = 'w';
+ if (!SCM_CLASSP (type))
+ {
+ if (s)
+ free (s);
+ SCM_MISC_ERROR ("bad slot class", SCM_EOL);
+ }
+ else if (SCM_SUBCLASSP (type, scm_class_foreign_slot))
+ {
+ if (SCM_SUBCLASSP (type, scm_class_self))
+ p = 's';
+ else if (SCM_SUBCLASSP (type, scm_class_protected))
+ p = 'p';
+ else
+ p = 'u';
+
+ if (SCM_SUBCLASSP (type, scm_class_opaque))
+ a = 'o';
+ else if (SCM_SUBCLASSP (type, scm_class_read_only))
+ a = 'r';
+ else
+ a = 'w';
+ }
+ else
+ {
+ p = 'p';
+ a = 'w';
+ }
+ }
+
+ index = SCM_GNS_INDEX (SCM_CAR (getters_n_setters));
+ if (index != (i >> 1))
+ goto inconsistent;
+ size = SCM_GNS_SIZE (SCM_CAR (getters_n_setters));
+ while (size)
+ {
+ s[i++] = p;
+ s[i++] = a;
+ --size;
}
}
- s[i] = p;
- s[i + 1] = a;
slots = SCM_CDR (slots);
+ getters_n_setters = SCM_CDR (getters_n_setters);
+ }
+ if (!SCM_NULLP (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)
}
#undef FUNC_NAME
-void
+static void
prep_hashsets (SCM class)
{
unsigned int i;
SCM_SET_SLOT (z, scm_si_direct_supers, dsupers);
cpl = compute_cpl (z);
slots = build_slots_list (maplist (dslots), cpl);
- nfields = SCM_MAKINUM (scm_ilength (slots));
+ nfields = SCM_I_MAKINUM (scm_ilength (slots));
g_n_s = compute_getters_n_setters (slots);
SCM_SET_SLOT (z, scm_si_name, name);
SCM_SET_SLOT (scm_class_class, scm_si_direct_methods, SCM_EOL);
SCM_SET_SLOT (scm_class_class, scm_si_cpl, SCM_EOL); /* will be changed */
/* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
- SCM_SET_SLOT (scm_class_class, scm_si_nfields, SCM_MAKINUM (SCM_N_CLASS_SLOTS));
+ SCM_SET_SLOT (scm_class_class, scm_si_nfields, SCM_I_MAKINUM (SCM_N_CLASS_SLOTS));
/* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
compute_getters_n_setters (slots_of_class)); */
SCM_SET_SLOT (scm_class_class, scm_si_redefined, SCM_BOOL_F);
"Return @code{#t} if @var{obj} is an instance.")
#define FUNC_NAME s_scm_instance_p
{
- return SCM_BOOL (SCM_INSTANCEP (obj));
+ return scm_from_bool (SCM_INSTANCEP (obj));
}
#undef FUNC_NAME
unsigned long int i;
SCM_VALIDATE_INSTANCE (1, obj);
- SCM_VALIDATE_INUM (2, index);
- SCM_ASSERT_RANGE (2, index, SCM_INUM (index) >= 0);
- i = SCM_INUM (index);
- SCM_ASSERT_RANGE (2, index, i < SCM_NUMBER_OF_SLOTS (obj));
-
- return scm_at_assert_bound_ref (obj, index);
+ i = scm_to_unsigned_integer (index, 0, SCM_NUMBER_OF_SLOTS(obj)-1);
+ return SCM_SLOT (obj, i);
}
#undef FUNC_NAME
unsigned long int i;
SCM_VALIDATE_INSTANCE (1, obj);
- SCM_VALIDATE_INUM (2, index);
- SCM_ASSERT_RANGE (2, index, SCM_INUM (index) >= 0);
- i = SCM_INUM (index);
- SCM_ASSERT_RANGE (2, index, i < SCM_NUMBER_OF_SLOTS (obj));
+ i = scm_to_unsigned_integer (index, 0, SCM_NUMBER_OF_SLOTS(obj)-1);
SCM_SET_SLOT (obj, i, value);
#undef FUNC_NAME
+SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_i_makbimacro, scm_m_atslot_ref);
+SCM_SYNTAX (s_atslot_set_x, "@slot-set!", scm_i_makbimacro, scm_m_atslot_set_x);
+
+
/** Utilities **/
/* In the future, this function will return the effective slot
get_slot_value_using_name (SCM class, SCM obj, SCM slot_name)
{
SCM slotdef = slot_definition_using_name (class, slot_name);
- if (!SCM_FALSEP (slotdef))
+ if (scm_is_true (slotdef))
return get_slot_value (class, obj, slotdef);
else
return CALL_GF3 ("slot-missing", class, obj, slot_name);
set_slot_value_using_name (SCM class, SCM obj, SCM slot_name, SCM value)
{
SCM slotdef = slot_definition_using_name (class, slot_name);
- if (!SCM_FALSEP (slotdef))
+ if (scm_is_true (slotdef))
return set_slot_value (class, obj, slotdef, value);
else
return CALL_GF4 ("slot-missing", class, obj, slot_name, value);
SCM_PACK ((scm_t_bits) args));
}
+/* This function calls the generic function change-class for all
+ * instances which aren't currently undergoing class change.
+ */
+
void
scm_change_object_class (SCM obj, SCM old_class SCM_UNUSED, SCM new_class)
{
static SCM list_of_no_method;
-SCM_SYMBOL (scm_sym_args, "args");
+SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
+
SCM
scm_make_method_cache (SCM gf)
{
return scm_list_5 (SCM_IM_DISPATCH,
scm_sym_args,
- SCM_MAKINUM (1),
+ SCM_I_MAKINUM (1),
scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE,
list_of_no_method),
gf);
SCM used_by;
SCM_ASSERT (SCM_PUREGENERICP (gf), gf, SCM_ARG1, FUNC_NAME);
used_by = SCM_SLOT (gf, scm_si_used_by);
- if (!SCM_FALSEP (used_by))
+ if (scm_is_true (used_by))
{
SCM methods = SCM_SLOT (gf, scm_si_methods);
for (; SCM_CONSP (used_by); used_by = SCM_CDR (used_by))
"")
#define FUNC_NAME s_scm_generic_capability_p
{
- SCM_ASSERT (!SCM_FALSEP (scm_procedure_p (proc)),
+ SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
proc, SCM_ARG1, FUNC_NAME);
return (scm_subr_p (proc) && SCM_SUBR_GENERIC (proc)
? SCM_BOOL_T
{
if (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr))
{
- SCM gf = *SCM_SUBR_GENERIC (subr);
- if (gf)
- return gf;
+ if (!*SCM_SUBR_GENERIC (subr))
+ scm_enable_primitive_generic_x (scm_list_1 (subr));
+ return *SCM_SUBR_GENERIC (subr);
}
SCM_WRONG_TYPE_ARG (SCM_ARG1, subr);
}
#undef FUNC_NAME
+typedef struct t_extension {
+ struct t_extension *next;
+ SCM extended;
+ SCM extension;
+} t_extension;
+
+static t_extension *extensions = 0;
+
+SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic");
+
+void
+scm_c_extend_primitive_generic (SCM extended, SCM extension)
+{
+ if (goops_loaded_p)
+ {
+ SCM gf, gext;
+ if (!*SCM_SUBR_GENERIC (extended))
+ scm_enable_primitive_generic_x (scm_list_1 (extended));
+ gf = *SCM_SUBR_GENERIC (extended);
+ gext = scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic),
+ gf,
+ SCM_SNAME (extension));
+ *SCM_SUBR_GENERIC (extension) = gext;
+ }
+ else
+ {
+ t_extension *e = scm_malloc (sizeof (t_extension));
+ t_extension **loc = &extensions;
+ /* Make sure that extensions are placed before their own
+ * extensions in the extensions list. O(N^2) algorithm, but
+ * extensions of primitive generics are rare.
+ */
+ while (*loc && extension != (*loc)->extended)
+ loc = &(*loc)->next;
+ e->next = *loc;
+ e->extended = extended;
+ e->extension = extension;
+ *loc = e;
+ }
+}
+
+static void
+setup_extended_primitive_generics ()
+{
+ while (extensions)
+ {
+ t_extension *e = extensions;
+ scm_c_extend_primitive_generic (e->extended, e->extension);
+ extensions = e->next;
+ free (e);
+ }
+}
+
/******************************************************************************
*
* Protocol for calling a generic fumction
applicablep (SCM actual, SCM formal)
{
/* We already know that the cpl is well formed. */
- return !SCM_FALSEP (scm_c_memq (formal, SCM_SLOT (actual, scm_si_cpl)));
+ return scm_is_true (scm_c_memq (formal, SCM_SLOT (actual, scm_si_cpl)));
}
static int
SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods");
SCM_VARIABLE_INIT (var_compute_applicable_methods, "compute-applicable-methods", scm_c_define_gsubr (s_sys_compute_applicable_methods, 2, 0, 0, scm_sys_compute_applicable_methods));
-SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_makmmacro, scm_m_atslot_ref);
-
-SCM
-scm_m_atslot_ref (SCM xorig, SCM env SCM_UNUSED)
-#define FUNC_NAME s_atslot_ref
-{
- SCM x = SCM_CDR (xorig);
- SCM_ASSYNT (scm_ilength (x) == 2, scm_s_expression, FUNC_NAME);
- SCM_VALIDATE_INUM (SCM_ARG2, SCM_CADR (x));
- return scm_cons (SCM_IM_SLOT_REF, x);
-}
-#undef FUNC_NAME
-
-
-SCM_SYNTAX (s_atslot_set_x, "@slot-set!", scm_makmmacro, scm_m_atslot_set_x);
-
-SCM
-scm_m_atslot_set_x (SCM xorig, SCM env SCM_UNUSED)
-#define FUNC_NAME s_atslot_set_x
-{
- SCM x = SCM_CDR (xorig);
- SCM_ASSYNT (scm_ilength (x) == 3, scm_s_expression, FUNC_NAME);
- SCM_VALIDATE_INUM (SCM_ARG2, SCM_CADR (x));
- return scm_cons (SCM_IM_SLOT_SET_X, x);
-}
-#undef FUNC_NAME
-
-
-SCM_SYNTAX (s_atdispatch, "@dispatch", scm_makmmacro, scm_m_atdispatch);
-
-SCM_SYMBOL (sym_atdispatch, s_atdispatch);
-
-SCM
-scm_m_atdispatch (SCM xorig, SCM env)
-#define FUNC_NAME s_atdispatch
-{
- SCM args, n, v, gf, x = SCM_CDR (xorig);
- SCM_ASSYNT (scm_ilength (x) == 4, scm_s_expression, FUNC_NAME);
- args = SCM_CAR (x);
- if (!SCM_CONSP (args) && !SCM_SYMBOLP (args))
- SCM_WRONG_TYPE_ARG (SCM_ARG1, args);
- x = SCM_CDR (x);
- n = SCM_XEVALCAR (x, env);
- SCM_VALIDATE_INUM (SCM_ARG2, n);
- SCM_ASSERT_RANGE (0, n, SCM_INUM (n) >= 1);
- x = SCM_CDR (x);
- v = SCM_XEVALCAR (x, env);
- SCM_VALIDATE_VECTOR (SCM_ARG3, v);
- x = SCM_CDR (x);
- gf = SCM_XEVALCAR (x, env);
- SCM_VALIDATE_PUREGENERIC (SCM_ARG4, gf);
- return scm_list_5 (SCM_IM_DISPATCH, args, n, v, gf);
-}
-#undef FUNC_NAME
-
-
static void
lock_cache_mutex (void *m)
{
* the cache miss and locking the mutex.
*/
SCM cmethod = scm_mcache_lookup_cmethod (x, SCM_CDDR (args));
- if (!SCM_FALSEP (cmethod))
+ if (scm_is_true (cmethod))
return cmethod;
/*fixme* Use scm_apply */
return CALL_GF3 ("memoize-method!", gf, SCM_CDDR (args), x);
class = SCM_CAR(args);
args = SCM_CDR(args);
- if (class == scm_class_generic || class == scm_class_generic_with_setter)
+ if (class == scm_class_generic || class == scm_class_accessor)
{
z = scm_make_struct (class, SCM_INUM0,
scm_list_5 (SCM_EOL,
args,
SCM_BOOL_F));
clear_method_cache (z);
- if (class == scm_class_generic_with_setter)
+ 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);
}
}
if (class == scm_class_method
|| class == scm_class_simple_method
- || class == scm_class_accessor)
+ || class == scm_class_accessor_method)
{
SCM_SET_SLOT (z, scm_si_generic_function,
scm_i_get_keyword (k_gf,
*
******************************************************************************/
+static void
+fix_cpl (SCM c, SCM before, SCM after)
+{
+ 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_is_false (ls))
+ /* if this condition occurs, fix_cpl should not be applied this way */
+ abort ();
+ SCM_SETCAR (ls, before);
+ SCM_SETCDR (ls, scm_cons (after, tail));
+ {
+ SCM dslots = SCM_SLOT (c, scm_si_direct_slots);
+ SCM slots = build_slots_list (maplist (dslots), cpl);
+ SCM g_n_s = compute_getters_n_setters (slots);
+ SCM_SET_SLOT (c, scm_si_slots, slots);
+ SCM_SET_SLOT (c, scm_si_getters_n_setters, g_n_s);
+ }
+}
+
static void
make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots)
k_init_keyword,
k_slot_definition));
SCM mutex_slot = scm_list_1 (scm_str2symbol ("make-mutex"));
+ SCM mutex_closure = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
+ SCM_EOL,
+ mutex_slot),
+ SCM_EOL);
SCM gf_slots = scm_list_5 (scm_str2symbol ("methods"),
scm_list_3 (scm_str2symbol ("n-specialized"),
k_init_value,
SCM_BOOL_F),
scm_list_3 (scm_str2symbol ("cache-mutex"),
k_init_thunk,
- scm_closure (scm_list_2 (SCM_EOL,
- mutex_slot),
- SCM_EOL)),
+ mutex_closure),
scm_list_3 (scm_str2symbol ("extended-by"),
k_init_value,
SCM_EOL));
scm_class_class, scm_class_foreign_slot, SCM_EOL);
make_stdcls (&scm_class_self, "<self-slot>",
scm_class_class,
- scm_list_2 (scm_class_foreign_slot, scm_class_read_only),
+ scm_class_read_only,
SCM_EOL);
make_stdcls (&scm_class_protected_opaque, "<protected-opaque-slot>",
scm_class_class,
make_stdcls (&scm_class_simple_method, "<simple-method>",
scm_class_class, scm_class_method, SCM_EOL);
SCM_SET_CLASS_FLAGS (scm_class_simple_method, SCM_CLASSF_SIMPLE_METHOD);
- make_stdcls (&scm_class_accessor, "<accessor-method>",
+ make_stdcls (&scm_class_accessor_method, "<accessor-method>",
scm_class_class, scm_class_simple_method, amethod_slots);
- SCM_SET_CLASS_FLAGS (scm_class_accessor, SCM_CLASSF_ACCESSOR_METHOD);
+ SCM_SET_CLASS_FLAGS (scm_class_accessor_method, SCM_CLASSF_ACCESSOR_METHOD);
+ make_stdcls (&scm_class_applicable, "<applicable>",
+ scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_entity, "<entity>",
- scm_class_entity_class, scm_class_object, SCM_EOL);
+ scm_class_entity_class,
+ scm_list_2 (scm_class_object, scm_class_applicable),
+ SCM_EOL);
make_stdcls (&scm_class_entity_with_setter, "<entity-with-setter>",
scm_class_entity_class, scm_class_entity, SCM_EOL);
make_stdcls (&scm_class_generic, "<generic>",
scm_class_entity_class, scm_class_entity, gf_slots);
SCM_SET_CLASS_FLAGS (scm_class_generic, SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_extended_generic, "<extended-generic>",
- scm_class_entity_class,
- scm_list_1 (scm_class_generic),
- egf_slots);
+ scm_class_entity_class, scm_class_generic, egf_slots);
SCM_SET_CLASS_FLAGS (scm_class_extended_generic, SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_generic_with_setter, "<generic-with-setter>",
scm_class_entity_class,
scm_list_2 (scm_class_generic, scm_class_entity_with_setter),
SCM_EOL);
SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter, SCM_CLASSF_PURE_GENERIC);
+ make_stdcls (&scm_class_accessor, "<accessor>",
+ scm_class_entity_class, scm_class_generic_with_setter, SCM_EOL);
+ SCM_SET_CLASS_FLAGS (scm_class_accessor, SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_extended_generic_with_setter,
"<extended-generic-with-setter>",
scm_class_entity_class,
- scm_list_2 (scm_class_extended_generic,
- scm_class_entity_with_setter),
+ scm_list_2 (scm_class_generic_with_setter,
+ scm_class_extended_generic),
SCM_EOL);
SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter,
SCM_CLASSF_PURE_GENERIC);
+ make_stdcls (&scm_class_extended_accessor, "<extended-accessor>",
+ scm_class_entity_class,
+ scm_list_2 (scm_class_accessor,
+ scm_class_extended_generic_with_setter),
+ SCM_EOL);
+ fix_cpl (scm_class_extended_accessor,
+ scm_class_extended_generic, scm_class_generic);
+ SCM_SET_CLASS_FLAGS (scm_class_extended_accessor, SCM_CLASSF_PURE_GENERIC);
/* Primitive types classes */
make_stdcls (&scm_class_boolean, "<boolean>",
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>",
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_procedure, "<procedure>",
- scm_class_procedure_class, scm_class_top, SCM_EOL);
+ scm_class_procedure_class, scm_class_applicable, SCM_EOL);
make_stdcls (&scm_class_procedure_with_setter, "<procedure-with-setter>",
scm_class_procedure_class, scm_class_procedure, SCM_EOL);
make_stdcls (&scm_class_primitive_generic, "<primitive-generic>",
**********************************************************************/
static SCM
-make_class_from_template (char *template, char *type_name, SCM supers)
+make_class_from_template (char const *template, char const *type_name, SCM supers, int applicablep)
{
SCM class, name;
if (type_name)
else
name = SCM_GOOPS_UNBOUND;
- class = scm_permanent_object (scm_basic_make_class (scm_class_class,
+ class = scm_permanent_object (scm_basic_make_class (applicablep
+ ? scm_class_procedure_class
+ : scm_class_class,
name,
supers,
SCM_EOL));
/* 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)
+scm_make_extended_class (char const *type_name, int applicablep)
{
return make_class_from_template ("<%s>",
type_name,
- scm_list_1 (scm_class_top));
+ scm_list_1 (applicablep
+ ? scm_class_applicable
+ : scm_class_top),
+ applicablep);
+}
+
+void
+scm_i_inherit_applicable (SCM c)
+{
+ if (!SCM_SUBCLASSP (c, scm_class_applicable))
+ {
+ SCM dsupers = SCM_SLOT (c, scm_si_direct_supers);
+ 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_is_false (top))
+ dsupers = scm_append (scm_list_2 (dsupers,
+ scm_list_1 (scm_class_applicable)));
+ else
+ {
+ SCM_SETCAR (top, scm_class_applicable);
+ SCM_SETCDR (top, scm_cons (scm_class_top, SCM_CDR (top)));
+ }
+ 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_is_false (top))
+ abort ();
+ else
+ {
+ SCM_SETCAR (top, scm_class_applicable);
+ SCM_SETCDR (top, scm_cons (scm_class_top, SCM_CDR (top)));
+ }
+ /* add class to direct-subclasses of scm_class_applicable */
+ SCM_SET_SLOT (scm_class_applicable,
+ scm_si_direct_subclasses,
+ scm_cons (c, SCM_SLOT (scm_class_applicable,
+ scm_si_direct_subclasses)));
+ }
}
static void
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)
if (!scm_smob_class[i])
- scm_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i));
+ scm_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i),
+ scm_smobs[i].apply != 0);
}
void
{
SCM c, class = make_class_from_template ("<%s-port>",
type_name,
- scm_list_1 (scm_class_port));
+ scm_list_1 (scm_class_port),
+ 0);
scm_port_class[SCM_IN_PCLASS_INDEX + ptobnum]
= make_class_from_template ("<%s-input-port>",
type_name,
- scm_list_2 (class, scm_class_input_port));
+ scm_list_2 (class, scm_class_input_port),
+ 0);
scm_port_class[SCM_OUT_PCLASS_INDEX + ptobnum]
= make_class_from_template ("<%s-output-port>",
type_name,
- scm_list_2 (class, scm_class_output_port));
+ scm_list_2 (class, scm_class_output_port),
+ 0);
scm_port_class[SCM_INOUT_PCLASS_INDEX + ptobnum]
= c
= make_class_from_template ("<%s-input-output-port>",
type_name,
- scm_list_2 (class, scm_class_input_output_port));
+ scm_list_2 (class, scm_class_input_output_port),
+ 0);
/* Patch cpl (since this tree is too complex for the C level compute-cpl) */
SCM_SET_SLOT (c, scm_si_cpl,
scm_cons2 (c, class, SCM_SLOT (scm_class_input_output_port, scm_si_cpl)));
}
static SCM
-make_struct_class (void *closure SCM_UNUSED, SCM key SCM_UNUSED,
- SCM data, SCM prev SCM_UNUSED)
+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_SYMBOL_CHARS (SCM_STRUCT_TABLE_NAME (data)),
+ SCM_CLASS_FLAGS (vtable) & SCM_CLASSF_OPERATOR));
return SCM_UNSPECIFIED;
}
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);
slot_class,
setter ? k_accessor : k_getter,
gf);
- SCM gns = scm_list_4 (name, SCM_BOOL_F, get, set);
-
- scm_add_method (gf, scm_make (scm_list_5 (scm_class_accessor,
+ scm_add_method (gf, scm_make (scm_list_5 (scm_class_accessor_method,
k_specializers,
scm_list_1 (class),
k_procedure,
getm)));
scm_add_method (scm_setter (gf),
- scm_make (scm_list_5 (scm_class_accessor,
+ scm_make (scm_list_5 (scm_class_accessor_method,
k_specializers,
scm_list_2 (class, scm_class_top),
k_procedure,
SCM_SET_SLOT (class, scm_si_slots,
scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots),
scm_list_1 (slot))));
- 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 n = SCM_SLOT (class, scm_si_nfields);
+ SCM gns = scm_list_n (name, SCM_BOOL_F, get, set, n, SCM_I_MAKINUM (1));
+ SCM_SET_SLOT (class, scm_si_getters_n_setters,
+ scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters),
+ scm_list_1 (gns))));
+ SCM_SET_SLOT (class, scm_si_nfields, SCM_I_MAKINUM (SCM_INUM (n) + 1));
+ }
}
}
- {
- long n = SCM_INUM (SCM_SLOT (class, scm_si_nfields));
-
- SCM_SET_SLOT (class, scm_si_nfields, SCM_MAKINUM (n + 1));
- }
}
SCM
scm_ensure_accessor (SCM name)
{
SCM gf = scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE, name, SCM_BOOL_F);
- if (!SCM_IS_A_P (gf, scm_class_generic_with_setter))
+ if (!SCM_IS_A_P (gf, scm_class_accessor))
{
gf = scm_make (scm_list_3 (scm_class_generic, k_name, name));
- gf = scm_make (scm_list_5 (scm_class_generic_with_setter,
+ gf = scm_make (scm_list_5 (scm_class_accessor,
k_name, name, k_setter, gf));
}
return gf;
"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
var_compute_applicable_methods =
scm_sym2var (sym_compute_applicable_methods, scm_goops_lookup_closure,
SCM_BOOL_F);
+ setup_extended_primitive_generics ();
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
scm_permanent_object (scm_goops_lookup_closure);
scm_components = scm_permanent_object (scm_make_weak_key_hash_table
- (SCM_MAKINUM (37)));
+ (SCM_I_MAKINUM (37)));
goops_rstate = scm_c_make_rstate ("GOOPS", 5);