mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-02 21:10:27 +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.
*
*
* 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,
@ -247,12 +247,12 @@ remove_duplicate_slots (SCM l, SCM res, SCM slots_already_seen)
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);
}
@ -288,7 +288,7 @@ SCM_DEFINE (scm_sys_compute_slots, "%compute-slots", 1, 0, 0,
(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);
@ -301,8 +301,8 @@ SCM_DEFINE (scm_sys_compute_slots, "%compute-slots", 1, 0, 0,
/******************************************************************************
*
* 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.
*
******************************************************************************/
@ -406,10 +406,10 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
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);
@ -417,7 +417,7 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
{
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 */
@ -466,7 +466,7 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
}
}
}
return obj;
}
#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_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)
{
@ -595,7 +595,7 @@ SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0,
SCM_SET_CLASS_FLAGS (class, flags);
prep_hashsets (class);
return SCM_UNSPECIFIED;
}
#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_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));
@ -775,7 +775,7 @@ create_basic_classes (void)
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,
@ -805,7 +805,7 @@ SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0,
/******************************************************************************
*
*
* 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));
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;
@ -1273,10 +1273,10 @@ SCM_DEFINE (scm_slot_bound_p, "slot-bound?", 2, 0, 0,
}
#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;
@ -1301,7 +1301,7 @@ static SCM
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;
@ -1329,13 +1329,13 @@ SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
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)
{
@ -1353,7 +1353,7 @@ SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
else
return wrap_init (class, m, n);
}
/* Class objects */
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;
}
/* Non-light instances */
{
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)
*
*
******************************************************************************/
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 (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".
*/
@ -1528,7 +1528,7 @@ SCM_SYMBOL (scm_sym_change_class, "change-class");
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));
}
@ -1543,16 +1543,16 @@ 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
*
******************************************************************************/
@ -1660,17 +1660,17 @@ SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0,
#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.
*
@ -1688,14 +1688,14 @@ more_specificp (SCM m1, SCM m2, SCM *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.
*
@ -1709,7 +1709,7 @@ more_specificp (SCM m1, SCM m2, SCM *targs)
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;
@ -1729,7 +1729,7 @@ scm_i_vector2list (SCM l, long len)
{
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);
}
@ -1756,7 +1756,7 @@ sort_applicable_methods (SCM method_list, long size, SCM *targs)
method_list = SCM_CDR (method_list);
}
v = buffer;
}
}
else
{
/* 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);
}
/* 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).
*/
@ -1796,7 +1796,7 @@ sort_applicable_methods (SCM method_list, long size, SCM *targs)
}
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);
}
@ -1809,7 +1809,7 @@ scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
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);
@ -1820,10 +1820,10 @@ scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
}
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))
{
@ -1992,7 +1992,7 @@ scm_memoize_method (SCM x, SCM args)
* 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.
*
******************************************************************************/
@ -2051,19 +2051,19 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1,
|| 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,
@ -2074,19 +2074,19 @@ SCM_DEFINE (scm_make, "make", 0, 0, 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,
@ -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;
}
#undef FUNC_NAME
/******************************************************************************
*
* Initializations
* Initializations
*
******************************************************************************/
@ -2154,7 +2154,7 @@ static void
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)
@ -2171,8 +2171,8 @@ static void
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"),
@ -2227,13 +2227,13 @@ create_standard_classes (void)
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"),
@ -2277,7 +2277,7 @@ create_standard_classes (void)
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,
@ -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_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));
@ -2429,7 +2429,7 @@ create_port_classes (void)
}
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)))
@ -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_INSTANCE_SIZE (class, size);
}
SCM_SET_SLOT (class, scm_si_layout, scm_str2symbol (""));
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,
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))));
@ -2570,7 +2570,7 @@ scm_add_slot (SCM class, char *slot_name, SCM slot_class,
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));
@ -2664,7 +2664,7 @@ scm_init_goops_builtins (void)
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);