mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-03 05:20:16 +02:00
Code Activity

(scm_slot_exists_p): Rename from scm_slots_exists_p.

Browse source 
(s_scm_slot_exists_p): Rename from s_scm_slots_exists_p.
This commit is contained in:
Thien-Thi Nguyen 2002-04-22 17:46:06 +00:00
parent 1841c44acc
commit 6d77c894fe
1 changed files with 72 additions and 72 deletions
Download patch file Download diff file Expand all files Collapse all files

144
libguile/goops.c
View file

@ -1,15 +1,15 @@
/* Copyright (C) 1998,1999,2000,2001 Free Software Foundation, Inc. /* Copyright (C) 1998,1999,2000,2001 Free Software Foundation, Inc.
* *
* This program is free software; you can redistribute it and/or modify * 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 * it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option) * the Free Software Foundation; either version 2, or (at your option)
* any later version. * any later version.
* *
* This program is distributed in the hope that it will be useful, * This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of * but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details. * GNU General Public License for more details.
* *
* You should have received a copy of the GNU General Public License * You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to * along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330, * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
@ -247,12 +247,12 @@ remove_duplicate_slots (SCM l, SCM res, SCM slots_already_seen)
tmp = SCM_CAAR (l); tmp = SCM_CAAR (l);
if (!SCM_SYMBOLP (tmp)) if (!SCM_SYMBOLP (tmp))
scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (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_FALSEP (scm_c_memq (tmp, slots_already_seen))) {
res = scm_cons (SCM_CAR (l), res); res = scm_cons (SCM_CAR (l), res);
slots_already_seen = scm_cons (tmp, slots_already_seen); slots_already_seen = scm_cons (tmp, slots_already_seen);
} }
return remove_duplicate_slots (SCM_CDR (l), res, slots_already_seen); return remove_duplicate_slots (SCM_CDR (l), res, slots_already_seen);
} }
@ -288,7 +288,7 @@ SCM_DEFINE (scm_sys_compute_slots, "%compute-slots", 1, 0, 0,
(SCM class), (SCM class),
"Return a list consisting of the names of all slots belonging to\n" "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" "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 #define FUNC_NAME s_scm_sys_compute_slots
{ {
SCM_VALIDATE_CLASS (1, class); SCM_VALIDATE_CLASS (1, class);
@ -301,8 +301,8 @@ SCM_DEFINE (scm_sys_compute_slots, "%compute-slots", 1, 0, 0,
/****************************************************************************** /******************************************************************************
* *
* compute-getters-n-setters * 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. * classes and will be overloaded in Scheme.
* *
******************************************************************************/ ******************************************************************************/
@ -406,10 +406,10 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
SCM_VALIDATE_INSTANCE (1, obj); SCM_VALIDATE_INSTANCE (1, obj);
n_initargs = scm_ilength (initargs); n_initargs = scm_ilength (initargs);
SCM_ASSERT ((n_initargs & 1) == 0, initargs, SCM_ARG2, FUNC_NAME); SCM_ASSERT ((n_initargs & 1) == 0, initargs, SCM_ARG2, FUNC_NAME);
get_n_set = SCM_SLOT (class, scm_si_getters_n_setters); get_n_set = SCM_SLOT (class, scm_si_getters_n_setters);
slots = SCM_SLOT (class, scm_si_slots); slots = SCM_SLOT (class, scm_si_slots);
/* See for each slot how it must be initialized */ /* See for each slot how it must be initialized */
for (; for (;
!SCM_NULLP (slots); !SCM_NULLP (slots);
@ -417,7 +417,7 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
{ {
SCM slot_name = SCM_CAR (slots); SCM slot_name = SCM_CAR (slots);
SCM slot_value = 0; SCM slot_value = 0;
if (!SCM_NULLP (SCM_CDR (slot_name))) if (!SCM_NULLP (SCM_CDR (slot_name)))
{ {
/* This slot admits (perhaps) to be initialized at creation time */ /* This slot admits (perhaps) to be initialized at creation time */
@ -466,7 +466,7 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
} }
} }
} }
return obj; return obj;
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -494,7 +494,7 @@ SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0,
&& SCM_SUBCLASSP (class, scm_class_class)) && SCM_SUBCLASSP (class, scm_class_class))
SCM_MISC_ERROR ("class object doesn't have enough fields: ~S", SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
scm_list_1 (nfields)); scm_list_1 (nfields));
s = n > 0 ? scm_malloc (n) : 0; s = n > 0 ? scm_malloc (n) : 0;
for (i = 0; i < n; i += 2) for (i = 0; i < n; i += 2)
{ {
@ -595,7 +595,7 @@ SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0,
SCM_SET_CLASS_FLAGS (class, flags); SCM_SET_CLASS_FLAGS (class, flags);
prep_hashsets (class); prep_hashsets (class);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -753,7 +753,7 @@ create_basic_classes (void)
SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, SCM_EOL); /* will be changed */ 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_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_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_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_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_MAKINUM (SCM_N_CLASS_SLOTS));
@ -775,7 +775,7 @@ create_basic_classes (void)
SCM_EOL)); SCM_EOL));
DEFVAR(name, scm_class_top); DEFVAR(name, scm_class_top);
/**** <scm_class_object> ****/ /**** <scm_class_object> ****/
name = scm_str2symbol ("<object>"); name = scm_str2symbol ("<object>");
scm_class_object = scm_permanent_object (scm_basic_make_class (scm_class_class, scm_class_object = scm_permanent_object (scm_basic_make_class (scm_class_class,
@ -805,7 +805,7 @@ SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0,
/****************************************************************************** /******************************************************************************
* *
* Meta object accessors * Meta object accessors
* *
******************************************************************************/ ******************************************************************************/
@ -1077,7 +1077,7 @@ get_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef)
return SCM_SLOT (obj, SCM_INUM (access)); return SCM_SLOT (obj, SCM_INUM (access));
else 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 */ * where (car access) is known to be a closure of arity 1 */
register SCM code, env; register SCM code, env;
@ -1273,10 +1273,10 @@ SCM_DEFINE (scm_slot_bound_p, "slot-bound?", 2, 0, 0,
} }
#undef FUNC_NAME #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), (SCM obj, SCM slot_name),
"Return @code{#t} if @var{obj} has a slot named @var{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; SCM class;
@ -1301,7 +1301,7 @@ static SCM
wrap_init (SCM class, SCM *m, long n) wrap_init (SCM class, SCM *m, long n)
{ {
long i; long i;
/* Set all slots to unbound */ /* Set all slots to unbound */
for (i = 0; i < n; i++) for (i = 0; i < n; i++)
m[i] = SCM_GOOPS_UNBOUND; m[i] = SCM_GOOPS_UNBOUND;
@ -1329,13 +1329,13 @@ SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
m = (SCM *) scm_gc_malloc (n * sizeof (SCM), "struct"); m = (SCM *) scm_gc_malloc (n * sizeof (SCM), "struct");
return wrap_init (class, m, n); return wrap_init (class, m, n);
} }
/* Foreign objects */ /* Foreign objects */
if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN) if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN)
return scm_make_foreign_object (class, initargs); return scm_make_foreign_object (class, initargs);
n = SCM_INUM (SCM_SLOT (class, scm_si_nfields)); n = SCM_INUM (SCM_SLOT (class, scm_si_nfields));
/* Entities */ /* Entities */
if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY) if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY)
{ {
@ -1353,7 +1353,7 @@ SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
else else
return wrap_init (class, m, n); return wrap_init (class, m, n);
} }
/* Class objects */ /* Class objects */
if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS) if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS)
{ {
@ -1373,7 +1373,7 @@ SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
return z; return z;
} }
/* Non-light instances */ /* Non-light instances */
{ {
m = (SCM *) scm_alloc_struct (n, scm_struct_n_extra_words, "heavy struct"); m = (SCM *) scm_alloc_struct (n, scm_struct_n_extra_words, "heavy struct");
@ -1404,7 +1404,7 @@ SCM_DEFINE (scm_sys_set_object_setter_x, "%set-object-setter!", 2, 0, 0,
/****************************************************************************** /******************************************************************************
* *
* %modify-instance (used by change-class to modify in place) * %modify-instance (used by change-class to modify in place)
* *
******************************************************************************/ ******************************************************************************/
SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0, SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0,
@ -1415,7 +1415,7 @@ SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0,
SCM_VALIDATE_INSTANCE (1, old); SCM_VALIDATE_INSTANCE (1, old);
SCM_VALIDATE_INSTANCE (2, new); 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. * scratch the old value with new to be correct with GC.
* See "Class redefinition protocol above". * See "Class redefinition protocol above".
*/ */
@ -1528,7 +1528,7 @@ SCM_SYMBOL (scm_sym_change_class, "change-class");
static SCM static SCM
purgatory (void *args) 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)); SCM_PACK ((scm_t_bits) args));
} }
@ -1543,16 +1543,16 @@ scm_change_object_class (SCM obj, SCM old_class SCM_UNUSED, SCM new_class)
/****************************************************************************** /******************************************************************************
* *
* GGGG FFFFF * GGGG FFFFF
* G F * G F
* G GG FFF * G GG FFF
* G G F * G G F
* GGG E N E R I C F U N C T I O N S * GGG E N E R I C F U N C T I O N S
* *
* This implementation provides * This implementation provides
* - generic functions (with class specializers) * - generic functions (with class specializers)
* - multi-methods * - multi-methods
* - next-method * - next-method
* - a hard-coded MOP for standard gf, which can be overloaded for non-std gf * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
* *
******************************************************************************/ ******************************************************************************/
@ -1660,17 +1660,17 @@ SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0,
#undef FUNC_NAME #undef FUNC_NAME
/****************************************************************************** /******************************************************************************
* *
* Protocol for calling a generic fumction * 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): * for efficiency reasons):
* *
* + apply-generic (gf args) * + apply-generic (gf args)
* + compute-applicable-methods (gf args ...) * + compute-applicable-methods (gf args ...)
* + sort-applicable-methods (methods args) * + sort-applicable-methods (methods args)
* + apply-methods (gf 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 * method. Applying a next-method will call apply-next-method which in
* turn will call apply again to call effectively the following method. * turn will call apply again to call effectively the following method.
* *
@ -1688,14 +1688,14 @@ more_specificp (SCM m1, SCM m2, SCM *targs)
{ {
register SCM s1, s2; register SCM s1, s2;
register long i; register long i;
/* /*
* Note: * Note:
* m1 and m2 can have != length (i.e. one can be one element longer than the * 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 * other when we have a dotted parameter list). For instance, with the call
* (M 1) * (M 1)
* with * with
* (define-method M (a . l) ....) * (define-method M (a . l) ....)
* (define-method M (a) ....) * (define-method M (a) ....)
* *
* we consider that the second method is more specific. * we consider that the second method is more specific.
* *
@ -1709,7 +1709,7 @@ more_specificp (SCM m1, SCM m2, SCM *targs)
if (SCM_NULLP(s2)) return 0; if (SCM_NULLP(s2)) return 0;
if (SCM_CAR(s1) != SCM_CAR(s2)) { if (SCM_CAR(s1) != SCM_CAR(s2)) {
register SCM l, cs1 = SCM_CAR(s1), cs2 = 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)) { for (l = SCM_SLOT (targs[i], scm_si_cpl); ; l = SCM_CDR(l)) {
if (cs1 == SCM_CAR(l)) if (cs1 == SCM_CAR(l))
return 1; return 1;
@ -1729,7 +1729,7 @@ scm_i_vector2list (SCM l, long len)
{ {
long j; long j;
SCM z = scm_c_make_vector (len, SCM_UNDEFINED); SCM z = scm_c_make_vector (len, SCM_UNDEFINED);
for (j = 0; j < len; j++, l = SCM_CDR (l)) { for (j = 0; j < len; j++, l = SCM_CDR (l)) {
SCM_VELTS (z)[j] = SCM_CAR (l); SCM_VELTS (z)[j] = SCM_CAR (l);
} }
@ -1756,7 +1756,7 @@ sort_applicable_methods (SCM method_list, long size, SCM *targs)
method_list = SCM_CDR (method_list); method_list = SCM_CDR (method_list);
} }
v = buffer; v = buffer;
} }
else else
{ {
/* Too many elements in method_list to keep everything locally */ /* Too many elements in method_list to keep everything locally */
@ -1764,7 +1764,7 @@ sort_applicable_methods (SCM method_list, long size, SCM *targs)
v = SCM_VELTS (vector); 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 * small vectors (which is probably mostly the case when we have to
* sort a list of applicable methods). * sort a list of applicable methods).
*/ */
@ -1796,7 +1796,7 @@ sort_applicable_methods (SCM method_list, long size, SCM *targs)
} }
return save; 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); return scm_vector_to_list (vector);
} }
@ -1809,7 +1809,7 @@ scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
SCM save = args; SCM save = args;
SCM buffer[BUFFSIZE], *types, *p; SCM buffer[BUFFSIZE], *types, *p;
SCM tmp; SCM tmp;
/* Build the list of arguments types */ /* Build the list of arguments types */
if (len >= BUFFSIZE) { if (len >= BUFFSIZE) {
tmp = scm_c_make_vector (len, SCM_UNDEFINED); tmp = scm_c_make_vector (len, SCM_UNDEFINED);
@ -1820,10 +1820,10 @@ scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
} }
else else
types = p = buffer; 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)); *p++ = scm_class_of (SCM_CAR (args));
/* Build a list of all applicable methods */ /* 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_SLOT (gf, scm_si_methods); !SCM_NULLP (l); l = SCM_CDR (l))
{ {
@ -1992,7 +1992,7 @@ scm_memoize_method (SCM x, SCM args)
* A simple make (which will be redefined later in Scheme) * A simple make (which will be redefined later in Scheme)
* This version handles only creation of gf, methods and classes (no instances) * 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. * no precaution is taken to be efficient.
* *
******************************************************************************/ ******************************************************************************/
@ -2051,19 +2051,19 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1,
|| class == scm_class_simple_method || class == scm_class_simple_method
|| class == scm_class_accessor) || 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, scm_i_get_keyword (k_gf,
args, args,
len - 1, len - 1,
SCM_BOOL_F, SCM_BOOL_F,
FUNC_NAME)); FUNC_NAME));
SCM_SET_SLOT (z, scm_si_specializers, SCM_SET_SLOT (z, scm_si_specializers,
scm_i_get_keyword (k_specializers, scm_i_get_keyword (k_specializers,
args, args,
len - 1, len - 1,
SCM_EOL, SCM_EOL,
FUNC_NAME)); FUNC_NAME));
SCM_SET_SLOT (z, scm_si_procedure, SCM_SET_SLOT (z, scm_si_procedure,
scm_i_get_keyword (k_procedure, scm_i_get_keyword (k_procedure,
args, args,
len - 1, len - 1,
@ -2074,19 +2074,19 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1,
else else
{ {
/* In all the others case, make a new class .... No instance here */ /* 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, scm_i_get_keyword (k_name,
args, args,
len - 1, len - 1,
scm_str2symbol ("???"), scm_str2symbol ("???"),
FUNC_NAME)); FUNC_NAME));
SCM_SET_SLOT (z, scm_si_direct_supers, SCM_SET_SLOT (z, scm_si_direct_supers,
scm_i_get_keyword (k_dsupers, scm_i_get_keyword (k_dsupers,
args, args,
len - 1, len - 1,
SCM_EOL, SCM_EOL,
FUNC_NAME)); FUNC_NAME));
SCM_SET_SLOT (z, scm_si_direct_slots, SCM_SET_SLOT (z, scm_si_direct_slots,
scm_i_get_keyword (k_slots, scm_i_get_keyword (k_slots,
args, args,
len - 1, len - 1,
@ -2140,12 +2140,12 @@ SCM_DEFINE (scm_sys_method_more_specific_p, "%method-more-specific?", 3, 0, 0,
return more_specificp (m1, m2, SCM_VELTS(v)) ? SCM_BOOL_T: SCM_BOOL_F; return more_specificp (m1, m2, SCM_VELTS(v)) ? SCM_BOOL_T: SCM_BOOL_F;
} }
#undef FUNC_NAME #undef FUNC_NAME
/****************************************************************************** /******************************************************************************
* *
* Initializations * Initializations
* *
******************************************************************************/ ******************************************************************************/
@ -2154,7 +2154,7 @@ static void
make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots) make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots)
{ {
SCM tmp = scm_str2symbol (name); SCM tmp = scm_str2symbol (name);
*var = scm_permanent_object (scm_basic_make_class (meta, *var = scm_permanent_object (scm_basic_make_class (meta,
tmp, tmp,
SCM_CONSP (super) SCM_CONSP (super)
@ -2171,8 +2171,8 @@ static void
create_standard_classes (void) create_standard_classes (void)
{ {
SCM slots; SCM slots;
SCM method_slots = scm_list_4 (scm_str2symbol ("generic-function"), SCM method_slots = scm_list_4 (scm_str2symbol ("generic-function"),
scm_str2symbol ("specializers"), scm_str2symbol ("specializers"),
sym_procedure, sym_procedure,
scm_str2symbol ("code-table")); scm_str2symbol ("code-table"));
SCM amethod_slots = scm_list_1 (scm_list_3 (scm_str2symbol ("slot-definition"), SCM amethod_slots = scm_list_1 (scm_list_3 (scm_str2symbol ("slot-definition"),
@ -2227,13 +2227,13 @@ create_standard_classes (void)
scm_class_class, scm_class_foreign_slot, SCM_EOL); scm_class_class, scm_class_foreign_slot, SCM_EOL);
/* Continue initialization of class <class> */ /* Continue initialization of class <class> */
slots = build_class_class_slots (); slots = build_class_class_slots ();
SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, 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_slots, slots);
SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters, SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
compute_getters_n_setters (slots)); compute_getters_n_setters (slots));
make_stdcls (&scm_class_foreign_class, "<foreign-class>", make_stdcls (&scm_class_foreign_class, "<foreign-class>",
scm_class_class, scm_class_class, scm_class_class, scm_class_class,
scm_list_2 (scm_list_3 (scm_str2symbol ("constructor"), scm_list_2 (scm_list_3 (scm_str2symbol ("constructor"),
@ -2277,7 +2277,7 @@ create_standard_classes (void)
SCM_EOL); SCM_EOL);
#if 0 #if 0
/* Patch cpl since compute_cpl doesn't support multiple inheritance. */ /* 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_append (scm_list_3 (scm_list_2 (scm_class_generic_with_setter,
scm_class_generic), scm_class_generic),
SCM_SLOT (scm_class_entity_with_setter, SCM_SLOT (scm_class_entity_with_setter,
@ -2385,7 +2385,7 @@ create_smob_classes (void)
scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_real)] = scm_class_real; 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_complex)] = scm_class_complex;
scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_keyword)] = scm_class_keyword; scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_keyword)] = scm_class_keyword;
for (i = 0; i < scm_numsmob; ++i) for (i = 0; i < scm_numsmob; ++i)
if (!scm_smob_class[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));
@ -2429,7 +2429,7 @@ create_port_classes (void)
} }
static SCM 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) SCM data, SCM prev SCM_UNUSED)
{ {
if (!SCM_FALSEP (SCM_STRUCT_TABLE_NAME (data))) if (!SCM_FALSEP (SCM_STRUCT_TABLE_NAME (data)))
@ -2502,7 +2502,7 @@ scm_make_class (SCM meta, char *s_name, SCM supers, size_t size,
SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light); SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light);
SCM_SET_CLASS_INSTANCE_SIZE (class, size); SCM_SET_CLASS_INSTANCE_SIZE (class, size);
} }
SCM_SET_SLOT (class, scm_si_layout, scm_str2symbol ("")); SCM_SET_SLOT (class, scm_si_layout, scm_str2symbol (""));
SCM_SET_SLOT (class, scm_si_constructor, (SCM) constructor); SCM_SET_SLOT (class, scm_si_constructor, (SCM) constructor);
@ -2561,7 +2561,7 @@ scm_add_slot (SCM class, char *slot_name, SCM slot_class,
k_procedure, k_procedure,
setm))); setm)));
DEFVAR (aname, gf); DEFVAR (aname, gf);
SCM_SET_SLOT (class, scm_si_slots, SCM_SET_SLOT (class, scm_si_slots,
scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots), scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots),
scm_list_1 (slot)))); scm_list_1 (slot))));
@ -2570,7 +2570,7 @@ scm_add_slot (SCM class, char *slot_name, SCM slot_class,
scm_list_1 (gns)))); scm_list_1 (gns))));
} }
} }
{ {
long n = SCM_INUM (SCM_SLOT (class, scm_si_nfields)); long n = SCM_INUM (SCM_SLOT (class, scm_si_nfields));
SCM_SET_SLOT (class, scm_si_nfields, SCM_MAKINUM (n + 1)); SCM_SET_SLOT (class, scm_si_nfields, SCM_MAKINUM (n + 1));
@ -2664,7 +2664,7 @@ scm_init_goops_builtins (void)
scm_module_goops = scm_current_module (); scm_module_goops = scm_current_module ();
scm_goops_lookup_closure = scm_module_lookup_closure (scm_module_goops); 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_module_goops);
scm_permanent_object (scm_goops_lookup_closure); scm_permanent_object (scm_goops_lookup_closure);