/* Copyright (C) 1998,1999,2000,2001 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,
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.
*
******************************************************************************/
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 */
}
}
}
-
+
return obj;
}
#undef FUNC_NAME
&& SCM_SUBCLASSP (class, scm_class_class))
SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
scm_list_1 (nfields));
-
+
s = n > 0 ? scm_malloc (n) : 0;
for (i = 0; i < n; i += 2)
{
SCM_SET_CLASS_FLAGS (class, flags);
prep_hashsets (class);
-
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
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
*
******************************************************************************/
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;
}
#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;
wrap_init (SCM class, SCM *m, long n)
{
long i;
-
+
/* Set all slots to unbound */
for (i = 0; i < n; i++)
m[i] = SCM_GOOPS_UNBOUND;
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)
{
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 struct");
/******************************************************************************
*
* %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
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));
}
/******************************************************************************
*
- * 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.
*
{
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.
*
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);
}
method_list = SCM_CDR (method_list);
}
v = buffer;
- }
+ }
else
{
/* Too many elements in method_list to keep everything locally */
v = SCM_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);
}
SCM save = args;
SCM buffer[BUFFSIZE], *types, *p;
SCM tmp;
-
+
/* Build the list of arguments types */
if (len >= BUFFSIZE) {
tmp = scm_c_make_vector (len, SCM_UNDEFINED);
}
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))
{
* 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.
*
******************************************************************************/
|| 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,
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"),
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"),
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_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_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));
}
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_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);
HCoop / bpt / guile.git / commitdiff