-/* Copyright (C) 1998,1999,2000,2001 Free Software Foundation, Inc.
+/* Copyright (C) 1998,1999,2000,2001, 2002, 2003 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
{ \
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)); \
+ scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (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_class_method;
-SCM scm_class_simple_method, scm_class_accessor;
+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_method;
SCM scm_class_procedure_class;
SCM scm_class_operator_class, scm_class_operator_with_setter_class;
SCM scm_class_entity_class;
*
* Compute-cpl
*
- * This version doesn't handle multiple-inheritance. It serves only for
- * booting classes and will be overloaded in Scheme
+ * This version doesn't fully handle multiple-inheritance. It serves
+ * only for booting classes and will be overloaded in Scheme
*
******************************************************************************/
-#if 0
-static SCM
-compute_cpl (SCM supers, SCM res)
-{
- return (SCM_NULLP (supers)
- ? scm_reverse (res)
- : compute_cpl (SCM_SLOT (SCM_CAR (supers), scm_si_direct_supers),
- scm_cons (SCM_CAR (supers), res)));
-}
-#endif
-
static SCM
map (SCM (*proc) (SCM), SCM ls)
{
{
init = scm_get_keyword (k_init_value, options, 0);
if (init)
- init = scm_closure (scm_list_2 (SCM_EOL, init), SCM_EOL);
+ init = scm_closure (scm_list_2 (SCM_EOL,
+ scm_list_2 (scm_sym_quote, init)),
+ SCM_EOL);
else
init = scm_get_keyword (k_init_thunk, options, SCM_BOOL_F);
}
}
#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))
- {
- p = 'p';
- a = 'w';
- }
- else
+ if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters)))
{
- 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_FALSEP (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;
z = scm_make_struct (class, SCM_INUM0, SCM_EOL);
/* Initialize its slots */
-#if 0
- cpl = compute_cpl (dsupers, scm_list_1 (z));
-#endif
SCM_SET_SLOT (z, scm_si_direct_supers, dsupers);
cpl = compute_cpl (z);
slots = build_slots_list (maplist (dslots), cpl);
}
#undef FUNC_NAME
+SCM_SYMBOL (sym_methods, "methods");
+SCM_SYMBOL (sym_extended_by, "extended-by");
+SCM_SYMBOL (sym_extends, "extends");
+
+static
+SCM fold_downward_gf_methods (SCM method_lists, SCM gf)
+{
+ 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))
+ {
+ method_lists = fold_downward_gf_methods (method_lists, SCM_CAR (gfs));
+ gfs = SCM_CDR (gfs);
+ }
+ return method_lists;
+}
+
+static
+SCM fold_upward_gf_methods (SCM method_lists, SCM gf)
+{
+ if (SCM_IS_A_P (gf, scm_class_extended_generic))
+ {
+ SCM gfs = scm_slot_ref (gf, sym_extends);
+ while (!SCM_NULLP (gfs))
+ {
+ SCM methods = scm_slot_ref (SCM_CAR (gfs), sym_methods);
+ method_lists = fold_upward_gf_methods (scm_cons (methods,
+ method_lists),
+ SCM_CAR (gfs));
+ gfs = SCM_CDR (gfs);
+ }
+ }
+ return method_lists;
+}
+
SCM_DEFINE (scm_generic_function_methods, "generic-function-methods", 1, 0, 0,
(SCM obj),
"Return the methods of the generic function @var{obj}.")
#define FUNC_NAME s_scm_generic_function_methods
{
+ SCM methods;
SCM_VALIDATE_GENERIC (1, obj);
- return scm_slot_ref (obj, scm_str2symbol ("methods"));
+ methods = fold_upward_gf_methods (SCM_EOL, obj);
+ methods = fold_downward_gf_methods (methods, obj);
+ return scm_append (methods);
}
#undef FUNC_NAME
-
SCM_DEFINE (scm_method_generic_function, "method-generic-function", 1, 0, 0,
(SCM obj),
"Return the generic function for the method @var{obj}.")
i = SCM_INUM (index);
SCM_ASSERT_RANGE (2, index, i < SCM_NUMBER_OF_SLOTS (obj));
- return scm_at_assert_bound_ref (obj, index);
+ return SCM_SLOT (obj, i);
}
#undef FUNC_NAME
static scm_t_bits **hell;
static long n_hell = 1; /* one place for the evil one himself */
static long hell_size = 4;
-#ifdef USE_THREADS
-static scm_t_mutex hell_mutex;
-#endif
+static SCM hell_mutex;
static long
burnin (SCM o)
go_to_hell (void *o)
{
SCM obj = SCM_PACK ((scm_t_bits) o);
-#ifdef USE_THREADS
- scm_mutex_lock (&hell_mutex);
-#endif
+ scm_lock_mutex (hell_mutex);
if (n_hell == hell_size)
{
long new_size = 2 * hell_size;
hell_size = new_size;
}
hell[n_hell++] = SCM_STRUCT_DATA (obj);
-#ifdef USE_THREADS
- scm_mutex_unlock (&hell_mutex);
-#endif
+ scm_unlock_mutex (hell_mutex);
}
static void
go_to_heaven (void *o)
{
-#ifdef USE_THREADS
- scm_mutex_lock (&hell_mutex);
-#endif
+ scm_lock_mutex (hell_mutex);
hell[burnin (SCM_PACK ((scm_t_bits) o))] = hell[--n_hell];
-#ifdef USE_THREADS
- scm_mutex_unlock (&hell_mutex);
-#endif
+ scm_unlock_mutex (hell_mutex);
}
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)
{
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
We're not allocating elements in this routine, so this should
pose no problem.
*/
- v = SCM_WRITABLE_VELTS (vector);
+ v = SCM_WRITABLE_VELTS (vector);
}
/* Use a simple shell sort since it is generally faster than qsort on
*p++ = scm_class_of (SCM_CAR (args));
/* Build a list of all applicable methods */
- for (l = SCM_SLOT (gf, scm_si_methods); !SCM_NULLP (l); l = SCM_CDR (l))
+ for (l = scm_generic_function_methods (gf); !SCM_NULLP (l); l = SCM_CDR (l))
{
fl = SPEC_OF (SCM_CAR (l));
/* Only accept accessors which match exactly in first arg. */
return SCM_BOOL_F;
}
- scm_remember_upto_here (tmp);
+ scm_remember_upto_here_1 (tmp);
return (count == 1
? applicable
: sort_applicable_methods (applicable, count, types));
#undef FUNC_NAME
-#ifdef USE_THREADS
static void
lock_cache_mutex (void *m)
{
SCM mutex = SCM_PACK ((scm_t_bits) m);
scm_unlock_mutex (mutex);
}
-#endif
static SCM
call_memoize_method (void *a)
scm_memoize_method (SCM x, SCM args)
{
SCM gf = SCM_CAR (scm_last_pair (x));
-#ifdef USE_THREADS
return scm_internal_dynamic_wind (
lock_cache_mutex,
call_memoize_method,
unlock_cache_mutex,
(void *) SCM_UNPACK (scm_cons2 (gf, x, args)),
(void *) SCM_UNPACK (SCM_SLOT (gf, scm_si_cache_mutex)));
-#else
- return call_memoize_method ((void *) SCM_UNPACK (scm_cons2 (gf, x, args)));
-#endif
}
/******************************************************************************
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)
{
-#ifdef USE_THREADS
z = scm_make_struct (class, SCM_INUM0,
- scm_list_4 (SCM_EOL,
+ scm_list_5 (SCM_EOL,
SCM_INUM0,
SCM_BOOL_F,
- scm_make_mutex ()));
-#else
- z = scm_make_struct (class, SCM_INUM0,
- scm_list_3 (SCM_EOL, SCM_INUM0, SCM_BOOL_F));
-#endif
+ scm_make_mutex (),
+ SCM_EOL));
scm_set_procedure_property_x (z, scm_sym_name,
scm_get_keyword (k_name,
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 (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_FALSEP (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)
SCM amethod_slots = scm_list_1 (scm_list_3 (scm_str2symbol ("slot-definition"),
k_init_keyword,
k_slot_definition));
-#ifdef USE_THREADS
SCM mutex_slot = scm_list_1 (scm_str2symbol ("make-mutex"));
-#else
- SCM mutex_slot = SCM_BOOL_F;
-#endif
- SCM gf_slots = scm_list_4 (scm_str2symbol ("methods"),
+ SCM gf_slots = scm_list_5 (scm_str2symbol ("methods"),
scm_list_3 (scm_str2symbol ("n-specialized"),
k_init_value,
SCM_INUM0),
k_init_thunk,
scm_closure (scm_list_2 (SCM_EOL,
mutex_slot),
- SCM_EOL)));
-
+ SCM_EOL)),
+ scm_list_3 (scm_str2symbol ("extended-by"),
+ k_init_value,
+ SCM_EOL));
+ SCM egf_slots = scm_list_1 (scm_list_3 (scm_str2symbol ("extends"),
+ k_init_value,
+ SCM_EOL));
/* Foreign class slot classes */
make_stdcls (&scm_class_foreign_slot, "<foreign-slot>",
scm_class_class, scm_class_top, 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_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);
-#if 0
- /* Patch cpl since compute_cpl doesn't support multiple inheritance. */
- SCM_SET_SLOT (scm_class_generic_with_setter, scm_si_cpl,
- scm_append (scm_list_3 (scm_list_2 (scm_class_generic_with_setter,
- scm_class_generic),
- SCM_SLOT (scm_class_entity_with_setter,
- scm_si_cpl),
- SCM_EOL)));
-#endif
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_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>",
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 *template, char *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));
}
SCM
-scm_make_extended_class (char *type_name)
+scm_make_extended_class (char *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_FALSEP (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_FALSEP (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
{
long i;
- scm_smob_class = (SCM *) malloc (255 * sizeof (SCM));
+ scm_smob_class = (SCM *) scm_malloc (255 * sizeof (SCM));
for (i = 0; i < 255; ++i)
scm_smob_class[i] = 0;
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)));
{
long i;
- scm_port_class = (SCM *) malloc (3 * 256 * sizeof (SCM));
+ scm_port_class = (SCM *) scm_malloc (3 * 256 * sizeof (SCM));
for (i = 0; i < 3 * 256; ++i)
scm_port_class[i] = 0;
}
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)))
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;
}
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_MAKINUM (1));
+ SCM_SET_SLOT (class, scm_si_getters_n_setters,
+ scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters),
+ scm_list_1 (gns))));
+ SCM_SET_SLOT (class, scm_si_nfields, SCM_MAKINUM (SCM_INUM (n) + 1));
+ }
}
}
- {
- 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;
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
list_of_no_method = scm_permanent_object (scm_list_1 (sym_no_method));
hell = scm_malloc (hell_size);
-#ifdef USE_THREADS
- scm_mutex_init (&hell_mutex);
-#endif
+ hell_mutex = scm_permanent_object (scm_make_mutex ());
create_basic_classes ();
create_standard_classes ();
HCoop / bpt / guile.git / blobdiff