-/* 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 program 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.
- *
+ *
* 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,
#define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
-#define DEFVAR(v,val) \
+#define DEFVAR(v, val) \
{ scm_eval (scm_list_3 (scm_sym_define_public, (v), (val)), \
scm_module_goops); }
/* Temporary hack until we get the new module system */
(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_str2symbol (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_str2symbol (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_str2symbol (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_str2symbol (name)), \
a, b, c, d))
/* Class redefinition protocol:
{ \
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_entity, scm_class_entity_with_setter;
-SCM scm_class_generic, scm_class_generic_with_setter, scm_class_method;
+SCM scm_class_generic, scm_class_generic_with_setter;
+SCM scm_class_extended_generic, scm_class_extended_generic_with_setter;
+SCM scm_class_method;
SCM scm_class_simple_method, scm_class_accessor;
SCM scm_class_procedure_class;
SCM scm_class_operator_class, scm_class_operator_with_setter_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)
{
tmp = SCM_CAAR (l);
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))) {
res = scm_cons (SCM_CAR (l), res);
slots_already_seen = scm_cons (tmp, slots_already_seen);
}
-
+
return remove_duplicate_slots (SCM_CDR (l), res, slots_already_seen);
}
(SCM class),
"Return a list consisting of the names of all slots belonging to\n"
"class @var{class}, i. e. the slots of @var{class} and of all of\n"
- "its superclasses.")
+ "its superclasses.")
#define FUNC_NAME s_scm_sys_compute_slots
{
SCM_VALIDATE_CLASS (1, class);
/******************************************************************************
*
* compute-getters-n-setters
- *
- * This version doesn't handle slot options. It serves only for booting
+ *
+ * This version doesn't handle slot options. It serves only for booting
* classes and will be overloaded in Scheme.
*
******************************************************************************/
{
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);
}
SCM_VALIDATE_INSTANCE (1, obj);
n_initargs = scm_ilength (initargs);
SCM_ASSERT ((n_initargs & 1) == 0, initargs, SCM_ARG2, FUNC_NAME);
-
+
get_n_set = SCM_SLOT (class, scm_si_getters_n_setters);
slots = SCM_SLOT (class, scm_si_slots);
-
+
/* See for each slot how it must be initialized */
for (;
!SCM_NULLP (slots);
{
SCM slot_name = SCM_CAR (slots);
SCM slot_value = 0;
-
+
if (!SCM_NULLP (SCM_CDR (slot_name)))
{
/* This slot admits (perhaps) to be initialized at creation time */
set_slot_value (class,
obj,
SCM_CAR (get_n_set),
- scm_eval_body (SCM_CDR (SCM_CODE (tmp)),
- env));
+ scm_eval_body (SCM_CLOSURE_BODY (tmp), env));
}
}
}
}
-
+
return obj;
}
#undef FUNC_NAME
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),
&& 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_must_malloc (n, FUNC_NAME) : 0;
+
+ s = n > 0 ? scm_malloc (n) : 0;
for (i = 0; i < n; i += 2)
{
long len;
- SCM type;
+ SCM type, allocation;
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);
+ allocation = scm_i_get_keyword (k_allocation, SCM_CDAR (slots),
+ len, k_instance, FUNC_NAME);
+ while (!SCM_EQ_P (allocation, k_instance))
+ {
+ slots = SCM_CDR (slots);
+ len = scm_ilength (SCM_CDAR (slots));
+ allocation = scm_i_get_keyword (k_allocation, SCM_CDAR (slots),
+ len, k_instance, FUNC_NAME);
+ }
+ type = scm_i_get_keyword (k_class, SCM_CDAR (slots),
+ len, SCM_BOOL_F, FUNC_NAME);
if (SCM_FALSEP (type))
{
p = 'p';
}
SCM_SET_SLOT (class, scm_si_layout, scm_mem2symbol (s, n));
if (s)
- scm_must_free (s);
+ free (s);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
long n = SCM_INUM (SCM_SLOT (class, scm_si_nfields));
#if 0
/*
- * We could avoid calling scm_must_malloc in the allocation code
+ * We could avoid calling scm_gc_malloc in the allocation code
* (in which case the following two lines are needed). Instead
* we make 0-slot instances non-light, so that the light case
* can be handled without special cases.
SCM_SET_CLASS_FLAGS (class, flags);
prep_hashsets (class);
-
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
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);
SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, SCM_EOL); /* will be changed */
/* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
SCM_SET_SLOT (scm_class_class, scm_si_direct_subclasses, SCM_EOL);
- SCM_SET_SLOT (scm_class_class, scm_si_direct_methods, 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_EOL));
DEFVAR(name, scm_class_top);
-
+
/**** <scm_class_object> ****/
name = scm_str2symbol ("<object>");
scm_class_object = scm_permanent_object (scm_basic_make_class (scm_class_class,
/******************************************************************************
- *
+ *
* Meta object accessors
*
******************************************************************************/
}
#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 fot the method @var{obj}.")
+ "Return the generic function for the method @var{obj}.")
#define FUNC_NAME s_scm_method_generic_function
{
SCM_VALIDATE_METHOD (1, obj);
return SCM_SLOT (obj, SCM_INUM (access));
else
{
- /* We must evaluate (apply (car access) (list obj))
+ /* We must evaluate (apply (car access) (list obj))
* where (car access) is known to be a closure of arity 1 */
register SCM code, env;
scm_list_1 (obj),
SCM_ENV (code));
/* Evaluate the closure body */
- return scm_eval_body (SCM_CDR (SCM_CODE (code)), env);
+ return scm_eval_body (SCM_CLOSURE_BODY (code), env);
}
}
scm_list_2 (obj, value),
SCM_ENV (code));
/* Evaluate the closure body */
- scm_eval_body (SCM_CDR (SCM_CODE (code)), env);
+ scm_eval_body (SCM_CLOSURE_BODY (code), env);
}
}
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_slots_exists_p, "slot-exists?", 2, 0, 0,
+SCM_DEFINE (scm_slot_exists_p, "slot-exists?", 2, 0, 0,
(SCM obj, SCM slot_name),
"Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
-#define FUNC_NAME s_scm_slots_exists_p
+#define FUNC_NAME s_scm_slot_exists_p
{
SCM class;
static SCM
wrap_init (SCM class, SCM *m, long n)
{
- SCM z;
long i;
-
+
/* Set all slots to unbound */
for (i = 0; i < n; i++)
m[i] = SCM_GOOPS_UNBOUND;
- SCM_NEWCELL2 (z);
- SCM_SET_STRUCT_GC_CHAIN (z, 0);
- SCM_SET_CELL_WORD_1 (z, m);
- SCM_SET_CELL_WORD_0 (z, (scm_t_bits) SCM_STRUCT_DATA (class)
- | scm_tc3_struct);
-
- return z;
+ return scm_double_cell ((((scm_t_bits) SCM_STRUCT_DATA (class))
+ | scm_tc3_struct),
+ (scm_t_bits) m, 0, 0);
}
SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT)
{
n = SCM_INUM (SCM_SLOT (class, scm_si_nfields));
- m = (SCM *) scm_must_malloc (n * sizeof (SCM), "instance");
+ m = (SCM *) scm_gc_malloc (n * sizeof (SCM), "struct");
return wrap_init (class, m, n);
}
-
+
/* Foreign objects */
if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN)
return scm_make_foreign_object (class, initargs);
n = SCM_INUM (SCM_SLOT (class, scm_si_nfields));
-
+
/* Entities */
if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY)
{
- m = (SCM *) scm_alloc_struct (n,
- scm_struct_entity_n_extra_words,
- "entity");
+ m = (SCM *) scm_alloc_struct (n, scm_struct_entity_n_extra_words,
+ "entity struct");
m[scm_struct_i_setter] = SCM_BOOL_F;
m[scm_struct_i_procedure] = SCM_BOOL_F;
/* Generic functions */
else
return wrap_init (class, m, n);
}
-
+
/* Class objects */
if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS)
{
return z;
}
-
+
/* Non-light instances */
{
- m = (SCM *) scm_alloc_struct (n,
- scm_struct_n_extra_words,
- "heavy instance");
+ m = (SCM *) scm_alloc_struct (n, scm_struct_n_extra_words, "heavy struct");
return wrap_init (class, m, n);
}
}
/******************************************************************************
*
* %modify-instance (used by change-class to modify in place)
- *
+ *
******************************************************************************/
SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0,
SCM_VALIDATE_INSTANCE (1, old);
SCM_VALIDATE_INSTANCE (2, new);
- /* Exchange the data contained in old and new. We exchange rather than
+ /* Exchange the data contained in old and new. We exchange rather than
* scratch the old value with new to be correct with GC.
* See "Class redefinition protocol above".
*/
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 = scm_must_realloc (hell, hell_size, new_size, "hell");
+ hell = scm_realloc (hell, new_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);
}
static SCM
purgatory (void *args)
{
- return scm_apply_0 (GETVAR (scm_sym_change_class),
+ return scm_apply_0 (GETVAR (scm_sym_change_class),
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)
{
/******************************************************************************
*
- * GGGG FFFFF
- * G F
- * G GG FFF
- * G G F
+ * GGGG FFFFF
+ * G F
+ * G GG FFF
+ * G G F
* GGG E N E R I C F U N C T I O N S
*
* This implementation provides
* - generic functions (with class specializers)
* - multi-methods
- * - next-method
+ * - next-method
* - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
*
******************************************************************************/
#undef FUNC_NAME
/******************************************************************************
- *
+ *
* Protocol for calling a generic fumction
- * This protocol is roughly equivalent to (parameter are a little bit different
+ * This protocol is roughly equivalent to (parameter are a little bit different
* for efficiency reasons):
*
* + apply-generic (gf args)
* + compute-applicable-methods (gf args ...)
* + sort-applicable-methods (methods args)
* + apply-methods (gf methods args)
- *
- * apply-methods calls make-next-method to build the "continuation" of a a
+ *
+ * apply-methods calls make-next-method to build the "continuation" of a a
* method. Applying a next-method will call apply-next-method which in
* turn will call apply again to call effectively the following method.
*
}
static int
-more_specificp (SCM m1, SCM m2, SCM *targs)
+more_specificp (SCM m1, SCM m2, SCM const *targs)
{
register SCM s1, s2;
register long i;
- /*
- * Note:
- * m1 and m2 can have != length (i.e. one can be one element longer than the
+ /*
+ * Note:
+ * m1 and m2 can have != length (i.e. one can be one element longer than the
* other when we have a dotted parameter list). For instance, with the call
* (M 1)
* with
* (define-method M (a . l) ....)
- * (define-method M (a) ....)
+ * (define-method M (a) ....)
*
* we consider that the second method is more specific.
*
* the end of this array).
*
*/
- for (i=0,s1=SPEC_OF(m1),s2=SPEC_OF(m2); ; i++,s1=SCM_CDR(s1),s2=SCM_CDR(s2)) {
+ 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_CAR(s1) != SCM_CAR(s2)) {
register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2);
-
+
for (l = SCM_SLOT (targs[i], scm_si_cpl); ; l = SCM_CDR(l)) {
if (cs1 == SCM_CAR(l))
return 1;
{
long j;
SCM z = scm_c_make_vector (len, SCM_UNDEFINED);
-
+
for (j = 0; j < len; j++, l = SCM_CDR (l)) {
- SCM_VELTS (z)[j] = SCM_CAR (l);
+ SCM_VECTOR_SET (z, j, SCM_CAR (l));
}
return z;
}
static SCM
-sort_applicable_methods (SCM method_list, long size, SCM *targs)
+sort_applicable_methods (SCM method_list, long size, SCM const *targs)
{
long i, j, incr;
SCM *v, vector = SCM_EOL;
method_list = SCM_CDR (method_list);
}
v = buffer;
- }
+ }
else
{
/* Too many elements in method_list to keep everything locally */
vector = scm_i_vector2list (save, size);
- v = SCM_VELTS (vector);
+
+ /*
+ 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);
}
- /* Use a simple shell sort since it is generally faster than qsort on
+ /* Use a simple shell sort since it is generally faster than qsort on
* small vectors (which is probably mostly the case when we have to
* sort a list of applicable methods).
*/
}
return save;
}
- /* If we are here, that's that we did it the hard way... */
+ /* If we are here, that's that we did it the hard way... */
return scm_vector_to_list (vector);
}
long count = 0;
SCM l, fl, applicable = SCM_EOL;
SCM save = args;
- SCM buffer[BUFFSIZE], *types, *p;
- SCM tmp;
-
+ SCM buffer[BUFFSIZE];
+ SCM const *types;
+ SCM *p;
+ SCM tmp = SCM_EOL;
+
/* 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_VELTS(tmp);
+ types = p = SCM_WRITABLE_VELTS(tmp);
+
+ /*
+ 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_NULLP (args); args = SCM_CDR (args))
*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. */
/* if we are here, it's because no-applicable-method hasn't signaled an error */
return SCM_BOOL_F;
}
+
+ 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
}
/******************************************************************************
* A simple make (which will be redefined later in Scheme)
* This version handles only creation of gf, methods and classes (no instances)
*
- * Since this code will disappear when Goops will be fully booted,
+ * Since this code will disappear when Goops will be fully booted,
* no precaution is taken to be efficient.
*
******************************************************************************/
if (class == scm_class_generic || class == scm_class_generic_with_setter)
{
-#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,
|| class == scm_class_simple_method
|| class == scm_class_accessor)
{
- SCM_SET_SLOT (z, scm_si_generic_function,
+ SCM_SET_SLOT (z, scm_si_generic_function,
scm_i_get_keyword (k_gf,
args,
len - 1,
SCM_BOOL_F,
FUNC_NAME));
- SCM_SET_SLOT (z, scm_si_specializers,
+ SCM_SET_SLOT (z, scm_si_specializers,
scm_i_get_keyword (k_specializers,
args,
len - 1,
SCM_EOL,
FUNC_NAME));
- SCM_SET_SLOT (z, scm_si_procedure,
+ SCM_SET_SLOT (z, scm_si_procedure,
scm_i_get_keyword (k_procedure,
args,
len - 1,
else
{
/* In all the others case, make a new class .... No instance here */
- SCM_SET_SLOT (z, scm_si_name,
+ SCM_SET_SLOT (z, scm_si_name,
scm_i_get_keyword (k_name,
args,
len - 1,
scm_str2symbol ("???"),
FUNC_NAME));
- SCM_SET_SLOT (z, scm_si_direct_supers,
+ SCM_SET_SLOT (z, scm_si_direct_supers,
scm_i_get_keyword (k_dsupers,
args,
len - 1,
SCM_EOL,
FUNC_NAME));
- SCM_SET_SLOT (z, scm_si_direct_slots,
+ SCM_SET_SLOT (z, scm_si_direct_slots,
scm_i_get_keyword (k_slots,
args,
len - 1,
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_VELTS(v)[i] = SCM_CAR(l);
+ SCM_VECTOR_SET (v, i, SCM_CAR(l));
}
return more_specificp (m1, m2, SCM_VELTS(v)) ? SCM_BOOL_T: SCM_BOOL_F;
}
#undef FUNC_NAME
-
-
+
+
/******************************************************************************
*
- * Initializations
+ * Initializations
*
******************************************************************************/
make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots)
{
SCM tmp = scm_str2symbol (name);
-
+
*var = scm_permanent_object (scm_basic_make_class (meta,
tmp,
SCM_CONSP (super)
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_str2symbol ("generic-function"),
+ scm_str2symbol ("specializers"),
sym_procedure,
scm_str2symbol ("code-table"));
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);
/* Continue initialization of class <class> */
-
+
slots = build_class_class_slots ();
SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots);
SCM_SET_SLOT (scm_class_class, scm_si_slots, slots);
SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
compute_getters_n_setters (slots));
-
+
make_stdcls (&scm_class_foreign_class, "<foreign-class>",
scm_class_class, scm_class_class,
scm_list_2 (scm_list_3 (scm_str2symbol ("constructor"),
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_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_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_EOL);
+ SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter,
+ SCM_CLASSF_PURE_GENERIC);
/* Primitive types classes */
make_stdcls (&scm_class_boolean, "<boolean>",
{
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;
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));
{
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,
+make_struct_class (void *closure SCM_UNUSED, SCM key SCM_UNUSED,
SCM data, SCM prev SCM_UNUSED)
{
if (!SCM_FALSEP (SCM_STRUCT_TABLE_NAME (data)))
SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light);
SCM_SET_CLASS_INSTANCE_SIZE (class, size);
}
-
+
SCM_SET_SLOT (class, scm_si_layout, scm_str2symbol (""));
SCM_SET_SLOT (class, scm_si_constructor, (SCM) constructor);
k_procedure,
setm)));
DEFVAR (aname, gf);
-
+
SCM_SET_SLOT (class, scm_si_slots,
scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots),
scm_list_1 (slot))));
scm_list_1 (gns))));
}
}
- {
+ {
long n = SCM_INUM (SCM_SLOT (class, scm_si_nfields));
SCM_SET_SLOT (class, scm_si_nfields, SCM_MAKINUM (n + 1));
SCM
scm_wrap_object (SCM class, void *data)
{
- SCM z;
- SCM_NEWCELL2 (z);
- SCM_SETCDR (z, SCM_PACK ((scm_t_bits) data));
- SCM_SET_STRUCT_GC_CHAIN (z, 0);
- SCM_SETCAR (z, SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct);
- return z;
+ return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct,
+ (scm_t_bits) data,
+ 0, 0);
}
SCM scm_components;
scm_module_goops = scm_current_module ();
scm_goops_lookup_closure = scm_module_lookup_closure (scm_module_goops);
- /* Not really necessary right now, but who knows...
+ /* Not really necessary right now, but who knows...
*/
scm_permanent_object (scm_module_goops);
scm_permanent_object (scm_goops_lookup_closure);
goops_rstate = scm_c_make_rstate ("GOOPS", 5);
-#ifndef SCM_MAGIC_SNARFER
#include "libguile/goops.x"
-#endif
list_of_no_method = scm_permanent_object (scm_list_1 (sym_no_method));
- hell = scm_must_malloc (hell_size, "hell");
-#ifdef USE_THREADS
- scm_mutex_init (&hell_mutex);
-#endif
+ hell = scm_malloc (hell_size);
+ hell_mutex = scm_permanent_object (scm_make_mutex ());
create_basic_classes ();
create_standard_classes ();
HCoop / bpt / guile.git / blobdiff