1 |
/* Copyright (C) 1998,1999,2000,2001 Free Software Foundation, Inc. |
/* Copyright (C) 1998,1999,2000,2001 Free Software Foundation, Inc. |
2 |
* |
* |
3 |
* This program is free software; you can redistribute it and/or modify |
* This program is free software; you can redistribute it and/or modify |
4 |
* 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 |
5 |
* the Free Software Foundation; either version 2, or (at your option) |
* the Free Software Foundation; either version 2, or (at your option) |
6 |
* any later version. |
* any later version. |
7 |
* |
* |
8 |
* This program is distributed in the hope that it will be useful, |
* This program is distributed in the hope that it will be useful, |
9 |
* but WITHOUT ANY WARRANTY; without even the implied warranty of |
* but WITHOUT ANY WARRANTY; without even the implied warranty of |
10 |
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
11 |
* GNU General Public License for more details. |
* GNU General Public License for more details. |
12 |
* |
* |
13 |
* You should have received a copy of the GNU General Public License |
* You should have received a copy of the GNU General Public License |
14 |
* along with this software; see the file COPYING. If not, write to |
* along with this software; see the file COPYING. If not, write to |
15 |
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
247 |
tmp = SCM_CAAR (l); |
tmp = SCM_CAAR (l); |
248 |
if (!SCM_SYMBOLP (tmp)) |
if (!SCM_SYMBOLP (tmp)) |
249 |
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)); |
250 |
|
|
251 |
if (SCM_FALSEP (scm_c_memq (tmp, slots_already_seen))) { |
if (SCM_FALSEP (scm_c_memq (tmp, slots_already_seen))) { |
252 |
res = scm_cons (SCM_CAR (l), res); |
res = scm_cons (SCM_CAR (l), res); |
253 |
slots_already_seen = scm_cons (tmp, slots_already_seen); |
slots_already_seen = scm_cons (tmp, slots_already_seen); |
254 |
} |
} |
255 |
|
|
256 |
return remove_duplicate_slots (SCM_CDR (l), res, slots_already_seen); |
return remove_duplicate_slots (SCM_CDR (l), res, slots_already_seen); |
257 |
} |
} |
258 |
|
|
288 |
(SCM class), |
(SCM class), |
289 |
"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" |
290 |
"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" |
291 |
"its superclasses.") |
"its superclasses.") |
292 |
#define FUNC_NAME s_scm_sys_compute_slots |
#define FUNC_NAME s_scm_sys_compute_slots |
293 |
{ |
{ |
294 |
SCM_VALIDATE_CLASS (1, class); |
SCM_VALIDATE_CLASS (1, class); |
301 |
/****************************************************************************** |
/****************************************************************************** |
302 |
* |
* |
303 |
* compute-getters-n-setters |
* compute-getters-n-setters |
304 |
* |
* |
305 |
* This version doesn't handle slot options. It serves only for booting |
* This version doesn't handle slot options. It serves only for booting |
306 |
* classes and will be overloaded in Scheme. |
* classes and will be overloaded in Scheme. |
307 |
* |
* |
308 |
******************************************************************************/ |
******************************************************************************/ |
406 |
SCM_VALIDATE_INSTANCE (1, obj); |
SCM_VALIDATE_INSTANCE (1, obj); |
407 |
n_initargs = scm_ilength (initargs); |
n_initargs = scm_ilength (initargs); |
408 |
SCM_ASSERT ((n_initargs & 1) == 0, initargs, SCM_ARG2, FUNC_NAME); |
SCM_ASSERT ((n_initargs & 1) == 0, initargs, SCM_ARG2, FUNC_NAME); |
409 |
|
|
410 |
get_n_set = SCM_SLOT (class, scm_si_getters_n_setters); |
get_n_set = SCM_SLOT (class, scm_si_getters_n_setters); |
411 |
slots = SCM_SLOT (class, scm_si_slots); |
slots = SCM_SLOT (class, scm_si_slots); |
412 |
|
|
413 |
/* See for each slot how it must be initialized */ |
/* See for each slot how it must be initialized */ |
414 |
for (; |
for (; |
415 |
!SCM_NULLP (slots); |
!SCM_NULLP (slots); |
417 |
{ |
{ |
418 |
SCM slot_name = SCM_CAR (slots); |
SCM slot_name = SCM_CAR (slots); |
419 |
SCM slot_value = 0; |
SCM slot_value = 0; |
420 |
|
|
421 |
if (!SCM_NULLP (SCM_CDR (slot_name))) |
if (!SCM_NULLP (SCM_CDR (slot_name))) |
422 |
{ |
{ |
423 |
/* This slot admits (perhaps) to be initialized at creation time */ |
/* This slot admits (perhaps) to be initialized at creation time */ |
466 |
} |
} |
467 |
} |
} |
468 |
} |
} |
469 |
|
|
470 |
return obj; |
return obj; |
471 |
} |
} |
472 |
#undef FUNC_NAME |
#undef FUNC_NAME |
494 |
&& SCM_SUBCLASSP (class, scm_class_class)) |
&& SCM_SUBCLASSP (class, scm_class_class)) |
495 |
SCM_MISC_ERROR ("class object doesn't have enough fields: ~S", |
SCM_MISC_ERROR ("class object doesn't have enough fields: ~S", |
496 |
scm_list_1 (nfields)); |
scm_list_1 (nfields)); |
497 |
|
|
498 |
s = n > 0 ? scm_malloc (n) : 0; |
s = n > 0 ? scm_malloc (n) : 0; |
499 |
for (i = 0; i < n; i += 2) |
for (i = 0; i < n; i += 2) |
500 |
{ |
{ |
595 |
SCM_SET_CLASS_FLAGS (class, flags); |
SCM_SET_CLASS_FLAGS (class, flags); |
596 |
|
|
597 |
prep_hashsets (class); |
prep_hashsets (class); |
598 |
|
|
599 |
return SCM_UNSPECIFIED; |
return SCM_UNSPECIFIED; |
600 |
} |
} |
601 |
#undef FUNC_NAME |
#undef FUNC_NAME |
753 |
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 */ |
754 |
/* 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); */ |
755 |
SCM_SET_SLOT (scm_class_class, scm_si_direct_subclasses, SCM_EOL); |
SCM_SET_SLOT (scm_class_class, scm_si_direct_subclasses, SCM_EOL); |
756 |
SCM_SET_SLOT (scm_class_class, scm_si_direct_methods, SCM_EOL); |
SCM_SET_SLOT (scm_class_class, scm_si_direct_methods, SCM_EOL); |
757 |
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 */ |
758 |
/* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */ |
/* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */ |
759 |
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 |
SCM_EOL)); |
SCM_EOL)); |
776 |
|
|
777 |
DEFVAR(name, scm_class_top); |
DEFVAR(name, scm_class_top); |
778 |
|
|
779 |
/**** <scm_class_object> ****/ |
/**** <scm_class_object> ****/ |
780 |
name = scm_str2symbol ("<object>"); |
name = scm_str2symbol ("<object>"); |
781 |
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 |
|
|
806 |
|
|
807 |
/****************************************************************************** |
/****************************************************************************** |
808 |
* |
* |
809 |
* Meta object accessors |
* Meta object accessors |
810 |
* |
* |
811 |
******************************************************************************/ |
******************************************************************************/ |
1077 |
return SCM_SLOT (obj, SCM_INUM (access)); |
return SCM_SLOT (obj, SCM_INUM (access)); |
1078 |
else |
else |
1079 |
{ |
{ |
1080 |
/* We must evaluate (apply (car access) (list obj)) |
/* We must evaluate (apply (car access) (list obj)) |
1081 |
* where (car access) is known to be a closure of arity 1 */ |
* where (car access) is known to be a closure of arity 1 */ |
1082 |
register SCM code, env; |
register SCM code, env; |
1083 |
|
|
1273 |
} |
} |
1274 |
#undef FUNC_NAME |
#undef FUNC_NAME |
1275 |
|
|
1276 |
SCM_DEFINE (scm_slots_exists_p, "slot-exists?", 2, 0, 0, |
SCM_DEFINE (scm_slot_exists_p, "slot-exists?", 2, 0, 0, |
1277 |
(SCM obj, SCM slot_name), |
(SCM obj, SCM slot_name), |
1278 |
"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}.") |
1279 |
#define FUNC_NAME s_scm_slots_exists_p |
#define FUNC_NAME s_scm_slot_exists_p |
1280 |
{ |
{ |
1281 |
SCM class; |
SCM class; |
1282 |
|
|
1301 |
wrap_init (SCM class, SCM *m, long n) |
wrap_init (SCM class, SCM *m, long n) |
1302 |
{ |
{ |
1303 |
long i; |
long i; |
1304 |
|
|
1305 |
/* Set all slots to unbound */ |
/* Set all slots to unbound */ |
1306 |
for (i = 0; i < n; i++) |
for (i = 0; i < n; i++) |
1307 |
m[i] = SCM_GOOPS_UNBOUND; |
m[i] = SCM_GOOPS_UNBOUND; |
1329 |
m = (SCM *) scm_gc_malloc (n * sizeof (SCM), "struct"); |
m = (SCM *) scm_gc_malloc (n * sizeof (SCM), "struct"); |
1330 |
return wrap_init (class, m, n); |
return wrap_init (class, m, n); |
1331 |
} |
} |
1332 |
|
|
1333 |
/* Foreign objects */ |
/* Foreign objects */ |
1334 |
if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN) |
if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN) |
1335 |
return scm_make_foreign_object (class, initargs); |
return scm_make_foreign_object (class, initargs); |
1336 |
|
|
1337 |
n = SCM_INUM (SCM_SLOT (class, scm_si_nfields)); |
n = SCM_INUM (SCM_SLOT (class, scm_si_nfields)); |
1338 |
|
|
1339 |
/* Entities */ |
/* Entities */ |
1340 |
if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY) |
if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY) |
1341 |
{ |
{ |
1353 |
else |
else |
1354 |
return wrap_init (class, m, n); |
return wrap_init (class, m, n); |
1355 |
} |
} |
1356 |
|
|
1357 |
/* Class objects */ |
/* Class objects */ |
1358 |
if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS) |
if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS) |
1359 |
{ |
{ |
1373 |
|
|
1374 |
return z; |
return z; |
1375 |
} |
} |
1376 |
|
|
1377 |
/* Non-light instances */ |
/* Non-light instances */ |
1378 |
{ |
{ |
1379 |
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 |
/****************************************************************************** |
/****************************************************************************** |
1405 |
* |
* |
1406 |
* %modify-instance (used by change-class to modify in place) |
* %modify-instance (used by change-class to modify in place) |
1407 |
* |
* |
1408 |
******************************************************************************/ |
******************************************************************************/ |
1409 |
|
|
1410 |
SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0, |
SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0, |
1415 |
SCM_VALIDATE_INSTANCE (1, old); |
SCM_VALIDATE_INSTANCE (1, old); |
1416 |
SCM_VALIDATE_INSTANCE (2, new); |
SCM_VALIDATE_INSTANCE (2, new); |
1417 |
|
|
1418 |
/* Exchange the data contained in old and new. We exchange rather than |
/* Exchange the data contained in old and new. We exchange rather than |
1419 |
* scratch the old value with new to be correct with GC. |
* scratch the old value with new to be correct with GC. |
1420 |
* See "Class redefinition protocol above". |
* See "Class redefinition protocol above". |
1421 |
*/ |
*/ |
1528 |
static SCM |
static SCM |
1529 |
purgatory (void *args) |
purgatory (void *args) |
1530 |
{ |
{ |
1531 |
return scm_apply_0 (GETVAR (scm_sym_change_class), |
return scm_apply_0 (GETVAR (scm_sym_change_class), |
1532 |
SCM_PACK ((scm_t_bits) args)); |
SCM_PACK ((scm_t_bits) args)); |
1533 |
} |
} |
1534 |
|
|
1543 |
|
|
1544 |
/****************************************************************************** |
/****************************************************************************** |
1545 |
* |
* |
1546 |
* GGGG FFFFF |
* GGGG FFFFF |
1547 |
* G F |
* G F |
1548 |
* G GG FFF |
* G GG FFF |
1549 |
* G G F |
* G G F |
1550 |
* 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 |
1551 |
* |
* |
1552 |
* This implementation provides |
* This implementation provides |
1553 |
* - generic functions (with class specializers) |
* - generic functions (with class specializers) |
1554 |
* - multi-methods |
* - multi-methods |
1555 |
* - next-method |
* - next-method |
1556 |
* - 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 |
1557 |
* |
* |
1558 |
******************************************************************************/ |
******************************************************************************/ |
1660 |
#undef FUNC_NAME |
#undef FUNC_NAME |
1661 |
|
|
1662 |
/****************************************************************************** |
/****************************************************************************** |
1663 |
* |
* |
1664 |
* Protocol for calling a generic fumction |
* Protocol for calling a generic fumction |
1665 |
* This protocol is roughly equivalent to (parameter are a little bit different |
* This protocol is roughly equivalent to (parameter are a little bit different |
1666 |
* for efficiency reasons): |
* for efficiency reasons): |
1667 |
* |
* |
1668 |
* + apply-generic (gf args) |
* + apply-generic (gf args) |
1669 |
* + compute-applicable-methods (gf args ...) |
* + compute-applicable-methods (gf args ...) |
1670 |
* + sort-applicable-methods (methods args) |
* + sort-applicable-methods (methods args) |
1671 |
* + apply-methods (gf methods args) |
* + apply-methods (gf methods args) |
1672 |
* |
* |
1673 |
* 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 |
1674 |
* method. Applying a next-method will call apply-next-method which in |
* method. Applying a next-method will call apply-next-method which in |
1675 |
* turn will call apply again to call effectively the following method. |
* turn will call apply again to call effectively the following method. |
1676 |
* |
* |
1688 |
{ |
{ |
1689 |
register SCM s1, s2; |
register SCM s1, s2; |
1690 |
register long i; |
register long i; |
1691 |
/* |
/* |
1692 |
* Note: |
* Note: |
1693 |
* 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 |
1694 |
* 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 |
1695 |
* (M 1) |
* (M 1) |
1696 |
* with |
* with |
1697 |
* (define-method M (a . l) ....) |
* (define-method M (a . l) ....) |
1698 |
* (define-method M (a) ....) |
* (define-method M (a) ....) |
1699 |
* |
* |
1700 |
* we consider that the second method is more specific. |
* we consider that the second method is more specific. |
1701 |
* |
* |
1709 |
if (SCM_NULLP(s2)) return 0; |
if (SCM_NULLP(s2)) return 0; |
1710 |
if (SCM_CAR(s1) != SCM_CAR(s2)) { |
if (SCM_CAR(s1) != SCM_CAR(s2)) { |
1711 |
register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2); |
register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2); |
1712 |
|
|
1713 |
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)) { |
1714 |
if (cs1 == SCM_CAR(l)) |
if (cs1 == SCM_CAR(l)) |
1715 |
return 1; |
return 1; |
1729 |
{ |
{ |
1730 |
long j; |
long j; |
1731 |
SCM z = scm_c_make_vector (len, SCM_UNDEFINED); |
SCM z = scm_c_make_vector (len, SCM_UNDEFINED); |
1732 |
|
|
1733 |
for (j = 0; j < len; j++, l = SCM_CDR (l)) { |
for (j = 0; j < len; j++, l = SCM_CDR (l)) { |
1734 |
SCM_VELTS (z)[j] = SCM_CAR (l); |
SCM_VELTS (z)[j] = SCM_CAR (l); |
1735 |
} |
} |
1756 |
method_list = SCM_CDR (method_list); |
method_list = SCM_CDR (method_list); |
1757 |
} |
} |
1758 |
v = buffer; |
v = buffer; |
1759 |
} |
} |
1760 |
else |
else |
1761 |
{ |
{ |
1762 |
/* Too many elements in method_list to keep everything locally */ |
/* Too many elements in method_list to keep everything locally */ |
1764 |
v = SCM_VELTS (vector); |
v = SCM_VELTS (vector); |
1765 |
} |
} |
1766 |
|
|
1767 |
/* 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 |
1768 |
* small vectors (which is probably mostly the case when we have to |
* small vectors (which is probably mostly the case when we have to |
1769 |
* sort a list of applicable methods). |
* sort a list of applicable methods). |
1770 |
*/ |
*/ |
1796 |
} |
} |
1797 |
return save; |
return save; |
1798 |
} |
} |
1799 |
/* 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... */ |
1800 |
return scm_vector_to_list (vector); |
return scm_vector_to_list (vector); |
1801 |
} |
} |
1802 |
|
|
1809 |
SCM save = args; |
SCM save = args; |
1810 |
SCM buffer[BUFFSIZE], *types, *p; |
SCM buffer[BUFFSIZE], *types, *p; |
1811 |
SCM tmp; |
SCM tmp; |
1812 |
|
|
1813 |
/* Build the list of arguments types */ |
/* Build the list of arguments types */ |
1814 |
if (len >= BUFFSIZE) { |
if (len >= BUFFSIZE) { |
1815 |
tmp = scm_c_make_vector (len, SCM_UNDEFINED); |
tmp = scm_c_make_vector (len, SCM_UNDEFINED); |
1820 |
} |
} |
1821 |
else |
else |
1822 |
types = p = buffer; |
types = p = buffer; |
1823 |
|
|
1824 |
for ( ; !SCM_NULLP (args); args = SCM_CDR (args)) |
for ( ; !SCM_NULLP (args); args = SCM_CDR (args)) |
1825 |
*p++ = scm_class_of (SCM_CAR (args)); |
*p++ = scm_class_of (SCM_CAR (args)); |
1826 |
|
|
1827 |
/* Build a list of all applicable methods */ |
/* Build a list of all applicable methods */ |
1828 |
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)) |
1829 |
{ |
{ |
1992 |
* A simple make (which will be redefined later in Scheme) |
* A simple make (which will be redefined later in Scheme) |
1993 |
* This version handles only creation of gf, methods and classes (no instances) |
* This version handles only creation of gf, methods and classes (no instances) |
1994 |
* |
* |
1995 |
* Since this code will disappear when Goops will be fully booted, |
* Since this code will disappear when Goops will be fully booted, |
1996 |
* no precaution is taken to be efficient. |
* no precaution is taken to be efficient. |
1997 |
* |
* |
1998 |
******************************************************************************/ |
******************************************************************************/ |
2051 |
|| class == scm_class_simple_method |
|| class == scm_class_simple_method |
2052 |
|| class == scm_class_accessor) |
|| class == scm_class_accessor) |
2053 |
{ |
{ |
2054 |
SCM_SET_SLOT (z, scm_si_generic_function, |
SCM_SET_SLOT (z, scm_si_generic_function, |
2055 |
scm_i_get_keyword (k_gf, |
scm_i_get_keyword (k_gf, |
2056 |
args, |
args, |
2057 |
len - 1, |
len - 1, |
2058 |
SCM_BOOL_F, |
SCM_BOOL_F, |
2059 |
FUNC_NAME)); |
FUNC_NAME)); |
2060 |
SCM_SET_SLOT (z, scm_si_specializers, |
SCM_SET_SLOT (z, scm_si_specializers, |
2061 |
scm_i_get_keyword (k_specializers, |
scm_i_get_keyword (k_specializers, |
2062 |
args, |
args, |
2063 |
len - 1, |
len - 1, |
2064 |
SCM_EOL, |
SCM_EOL, |
2065 |
FUNC_NAME)); |
FUNC_NAME)); |
2066 |
SCM_SET_SLOT (z, scm_si_procedure, |
SCM_SET_SLOT (z, scm_si_procedure, |
2067 |
scm_i_get_keyword (k_procedure, |
scm_i_get_keyword (k_procedure, |
2068 |
args, |
args, |
2069 |
len - 1, |
len - 1, |
2074 |
else |
else |
2075 |
{ |
{ |
2076 |
/* In all the others case, make a new class .... No instance here */ |
/* In all the others case, make a new class .... No instance here */ |
2077 |
SCM_SET_SLOT (z, scm_si_name, |
SCM_SET_SLOT (z, scm_si_name, |
2078 |
scm_i_get_keyword (k_name, |
scm_i_get_keyword (k_name, |
2079 |
args, |
args, |
2080 |
len - 1, |
len - 1, |
2081 |
scm_str2symbol ("???"), |
scm_str2symbol ("???"), |
2082 |
FUNC_NAME)); |
FUNC_NAME)); |
2083 |
SCM_SET_SLOT (z, scm_si_direct_supers, |
SCM_SET_SLOT (z, scm_si_direct_supers, |
2084 |
scm_i_get_keyword (k_dsupers, |
scm_i_get_keyword (k_dsupers, |
2085 |
args, |
args, |
2086 |
len - 1, |
len - 1, |
2087 |
SCM_EOL, |
SCM_EOL, |
2088 |
FUNC_NAME)); |
FUNC_NAME)); |
2089 |
SCM_SET_SLOT (z, scm_si_direct_slots, |
SCM_SET_SLOT (z, scm_si_direct_slots, |
2090 |
scm_i_get_keyword (k_slots, |
scm_i_get_keyword (k_slots, |
2091 |
args, |
args, |
2092 |
len - 1, |
len - 1, |
2140 |
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; |
2141 |
} |
} |
2142 |
#undef FUNC_NAME |
#undef FUNC_NAME |
2143 |
|
|
2144 |
|
|
2145 |
|
|
2146 |
/****************************************************************************** |
/****************************************************************************** |
2147 |
* |
* |
2148 |
* Initializations |
* Initializations |
2149 |
* |
* |
2150 |
******************************************************************************/ |
******************************************************************************/ |
2151 |
|
|
2154 |
make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots) |
make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots) |
2155 |
{ |
{ |
2156 |
SCM tmp = scm_str2symbol (name); |
SCM tmp = scm_str2symbol (name); |
2157 |
|
|
2158 |
*var = scm_permanent_object (scm_basic_make_class (meta, |
*var = scm_permanent_object (scm_basic_make_class (meta, |
2159 |
tmp, |
tmp, |
2160 |
SCM_CONSP (super) |
SCM_CONSP (super) |
2171 |
create_standard_classes (void) |
create_standard_classes (void) |
2172 |
{ |
{ |
2173 |
SCM slots; |
SCM slots; |
2174 |
SCM method_slots = scm_list_4 (scm_str2symbol ("generic-function"), |
SCM method_slots = scm_list_4 (scm_str2symbol ("generic-function"), |
2175 |
scm_str2symbol ("specializers"), |
scm_str2symbol ("specializers"), |
2176 |
sym_procedure, |
sym_procedure, |
2177 |
scm_str2symbol ("code-table")); |
scm_str2symbol ("code-table")); |
2178 |
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 |
scm_class_class, scm_class_foreign_slot, SCM_EOL); |
scm_class_class, scm_class_foreign_slot, SCM_EOL); |
2228 |
|
|
2229 |
/* Continue initialization of class <class> */ |
/* Continue initialization of class <class> */ |
2230 |
|
|
2231 |
slots = build_class_class_slots (); |
slots = build_class_class_slots (); |
2232 |
SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots); |
SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots); |
2233 |
SCM_SET_SLOT (scm_class_class, scm_si_slots, slots); |
SCM_SET_SLOT (scm_class_class, scm_si_slots, slots); |
2234 |
SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters, |
SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters, |
2235 |
compute_getters_n_setters (slots)); |
compute_getters_n_setters (slots)); |
2236 |
|
|
2237 |
make_stdcls (&scm_class_foreign_class, "<foreign-class>", |
make_stdcls (&scm_class_foreign_class, "<foreign-class>", |
2238 |
scm_class_class, scm_class_class, |
scm_class_class, scm_class_class, |
2239 |
scm_list_2 (scm_list_3 (scm_str2symbol ("constructor"), |
scm_list_2 (scm_list_3 (scm_str2symbol ("constructor"), |
2277 |
SCM_EOL); |
SCM_EOL); |
2278 |
#if 0 |
#if 0 |
2279 |
/* Patch cpl since compute_cpl doesn't support multiple inheritance. */ |
/* Patch cpl since compute_cpl doesn't support multiple inheritance. */ |
2280 |
SCM_SET_SLOT (scm_class_generic_with_setter, scm_si_cpl, |
SCM_SET_SLOT (scm_class_generic_with_setter, scm_si_cpl, |
2281 |
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, |
2282 |
scm_class_generic), |
scm_class_generic), |
2283 |
SCM_SLOT (scm_class_entity_with_setter, |
SCM_SLOT (scm_class_entity_with_setter, |
2385 |
scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_real)] = scm_class_real; |
scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_real)] = scm_class_real; |
2386 |
scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_complex)] = scm_class_complex; |
scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_complex)] = scm_class_complex; |
2387 |
scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_keyword)] = scm_class_keyword; |
scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_keyword)] = scm_class_keyword; |
2388 |
|
|
2389 |
for (i = 0; i < scm_numsmob; ++i) |
for (i = 0; i < scm_numsmob; ++i) |
2390 |
if (!scm_smob_class[i]) |
if (!scm_smob_class[i]) |
2391 |
scm_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i)); |
scm_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i)); |
2429 |
} |
} |
2430 |
|
|
2431 |
static SCM |
static SCM |
2432 |
make_struct_class (void *closure SCM_UNUSED, SCM key SCM_UNUSED, |
make_struct_class (void *closure SCM_UNUSED, SCM key SCM_UNUSED, |
2433 |
SCM data, SCM prev SCM_UNUSED) |
SCM data, SCM prev SCM_UNUSED) |
2434 |
{ |
{ |
2435 |
if (!SCM_FALSEP (SCM_STRUCT_TABLE_NAME (data))) |
if (!SCM_FALSEP (SCM_STRUCT_TABLE_NAME (data))) |
2502 |
SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light); |
SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light); |
2503 |
SCM_SET_CLASS_INSTANCE_SIZE (class, size); |
SCM_SET_CLASS_INSTANCE_SIZE (class, size); |
2504 |
} |
} |
2505 |
|
|
2506 |
SCM_SET_SLOT (class, scm_si_layout, scm_str2symbol ("")); |
SCM_SET_SLOT (class, scm_si_layout, scm_str2symbol ("")); |
2507 |
SCM_SET_SLOT (class, scm_si_constructor, (SCM) constructor); |
SCM_SET_SLOT (class, scm_si_constructor, (SCM) constructor); |
2508 |
|
|
2561 |
k_procedure, |
k_procedure, |
2562 |
setm))); |
setm))); |
2563 |
DEFVAR (aname, gf); |
DEFVAR (aname, gf); |
2564 |
|
|
2565 |
SCM_SET_SLOT (class, scm_si_slots, |
SCM_SET_SLOT (class, scm_si_slots, |
2566 |
scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots), |
scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots), |
2567 |
scm_list_1 (slot)))); |
scm_list_1 (slot)))); |
2570 |
scm_list_1 (gns)))); |
scm_list_1 (gns)))); |
2571 |
} |
} |
2572 |
} |
} |
2573 |
{ |
{ |
2574 |
long n = SCM_INUM (SCM_SLOT (class, scm_si_nfields)); |
long n = SCM_INUM (SCM_SLOT (class, scm_si_nfields)); |
2575 |
|
|
2576 |
SCM_SET_SLOT (class, scm_si_nfields, SCM_MAKINUM (n + 1)); |
SCM_SET_SLOT (class, scm_si_nfields, SCM_MAKINUM (n + 1)); |
2664 |
scm_module_goops = scm_current_module (); |
scm_module_goops = scm_current_module (); |
2665 |
scm_goops_lookup_closure = scm_module_lookup_closure (scm_module_goops); |
scm_goops_lookup_closure = scm_module_lookup_closure (scm_module_goops); |
2666 |
|
|
2667 |
/* Not really necessary right now, but who knows... |
/* Not really necessary right now, but who knows... |
2668 |
*/ |
*/ |
2669 |
scm_permanent_object (scm_module_goops); |
scm_permanent_object (scm_module_goops); |
2670 |
scm_permanent_object (scm_goops_lookup_closure); |
scm_permanent_object (scm_goops_lookup_closure); |